| blob | 6fd8d95fdb3691003b0e1a827e03bea500f3df96 |
1 ; -*- Lisp -*-
2 ;; file warmelt-hooks.melt
3 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4 (comment "***
5 Copyright 2012 - 2014 Free Software Foundation, Inc.
6 Contributed by Basile Starynkevitch <basile@starynkevitch.net>
8 This file is part of GCC.
10 GCC is free software; you can redistribute it and/or modify
11 it under the terms of the GNU General Public License as published by
12 the Free Software Foundation; either version 3, or (at your option)
13 any later version.
15 GCC is distributed in the hope that it will be useful,
16 but WITHOUT ANY WARRANTY; without even the implied warranty of
17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 GNU General Public License for more details.
20 You should have received a copy of the GNU General Public License
21 along with GCC; see the file COPYING3. If not see
22 <http://www.gnu.org/licenses/>.
23 ***")
25 ;; the copyright notice above apply both to warmelt-hooks.melt and
26 ;; to the generated files warmelt-hooks*.c
28 ;; This MELT module is GPL compatible since it is GPLv3+ licensed.
29 (module_is_gpl_compatible "GPLv3+")
32 ;;;====================================================================
33 ;;;******************* low level debug at routine *********************
34 ;;;see the melt_low_debug_value macro in melt-runtime.h
35 (defhook hook_low_debug_value_at (:value val
36 :cstring filename :long lineno
37 :cstring msg :long count) () :void
38 :predef HOOK_LOW_DEBUG_VALUE_AT
39 :doc #{$HOOK_LOW_DEBUG_VALUE_AT is an internal hook for the
40 melt_low_debug_value macro in @file{melt-runtime.h}. Output on the
41 dump file or else the standard errror.}#
42 (melt_debug_fun () count filename lineno msg val)
43 )
45 (defhook hook_low_stderr_value_at (:value val
46 :cstring filename :long lineno
47 :cstring msg :long count) () :void
48 :predef HOOK_LOW_STDERR_VALUE_AT
49 :doc #{$HOOK_LOW_STDERR_VALUE_AT is an internal hook for the
50 melt_low_stderr_value macro in @file{melt-runtime.h}.
51 Output always on standard errror.}#
52 (block_signals
53 () ()
54 (let ( (:long dbgcounter 0)
55 (stderrf (get_field :sysdata_stderr initial_system_data))
56 (occmap (make_mapobject discr_map_objects 50))
57 (boxedmaxdepth (constant_box (+i 2 (debug_depth)))) ;;;; @@@ DEBUGDEPTH
58 (dbgi (instance class_debug_information
59 :dbgi_out stderrf
60 :dbgi_occmap occmap
61 :dbgi_maxdepth boxedmaxdepth))
62 (:long framdepth (the_framedepth))
63 )
64 (code_chunk getdbgcounter
65 #{/*hook_low_stderr_value_at $GETDBGCOUNTER*/ $DBGCOUNTER = melt_dbgcounter ;
66 }#)
67 (add2out_strconst stderrf "!!!!****####")
68 (add2out_longdec stderrf dbgcounter)
69 (add2out_strconst stderrf "#^")
70 (add2out_longdec stderrf (-i framdepth 1))
71 (add2out_strconst stderrf ":")
72 (when filename
73 (add2out_strconst stderrf filename)
74 (add2out_strconst stderrf ":")
75 (add2out_longdec stderrf lineno)
76 (add2out_strconst stderrf ":")
77 )
78 (add2out_strconst stderrf msg)
79 (when (>i count 0)
80 (add2out_strconst stderrf " !")
81 (add2out_longdec stderrf count)
82 (add2out_strconst stderrf ": ")
83 )
84 (if val
85 (dbg_out val dbgi 0)
86 (add2out_strconst stderrf "() ;;;NIL!!!")
87 )
88 (add2out_indentnl stderrf 0)
89 ))
90 )
92 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
93 ;;; Nota Bene: environment management hooks are so crucial that they
94 ;;; have to be in warmelt-first.melt,
95 ;;; i.e. hook_fresh_environment_reference_maker, hook_value_importer,
96 ;;; hook_value_exporter, hook_macro_exporter, hook_patmacro_exporter...
99 ;;;====================================================================
100 ;;;******************* OVERRIDE_GATE plugin event *********************
101 (definstance override_gate_delayed_queue class_delayed_queue
102 :named_name '"override_gate_delayed_queue"
103 :delqu_first (make_list discr_list)
104 :delqu_last (make_list discr_list)
105 )
107 (defhook hook_override_gate (:long beforegate) (:long aftergate) :void
108 :predef HOOK_OVERRIDE_GATE
109 :doc #{The internal $HOOK_OVERRIDE_GATE handles
110 @t{PLUGIN_OVERRIDE_GATE} events. See $REGISTER_OVERRIDE_GATE_FIRST
111 etc...}#
112 (debug "hook_override_gate beforegate=" beforegate)
113 (let (
114 (gateflag (if beforegate :true ()))
115 (passname ())
116 (:long passnum 0)
117 (memref (reference ()))
118 (revlastlist (make_list discr_list))
119 (qufirst (get_field :delqu_first override_gate_delayed_queue))
120 (qulast (get_field :delqu_last override_gate_delayed_queue))
121 )
122 ;; retrieve the passname and pass number
123 (code_chunk
124 getpassname_chk
125 #{ /* hook_override_gate $GETPASSNAME_CHK */
126 gcc_assert (current_pass != NULL);
127 $PASSNAME = meltgc_new_stringdup
128 ((meltobject_ptr_t) MELT_PREDEF(DISCR_STRING), current_pass->name);
129 $PASSNUM = current_pass->static_pass_number;
130 }#)
131 ;; call the first closures in natural order
132 (debug "hook_override_gate memref=" memref
133 "\n gateflag=" gateflag
134 "\n override_gate_delayed_queue=" override_gate_delayed_queue
135 "\n passname=" passname " passnum=" passnum)
136 ;; apply the first closures in order
137 (foreach_pair_component_in_list
138 (qufirst)
139 (curpair curclo)
140 (debug "hook_override_gate first curclo=" curclo " memref=" memref)
141 (if (is_closure curclo)
142 (let ( (clores (curclo gateflag memref passname passnum))
143 )
144 (debug "hook_override_gate first clores=" clores)
145 (setq gateflag clores)
146 )))
147 ;; reverse the last closures list
148 (foreach_pair_component_in_list
149 (qulast)
150 (curlpair curlclo)
151 (if (is_closure curlclo)
152 (list_append revlastlist curlclo)))
153 ;; apply the last closures in reverse order
154 (foreach_pair_component_in_list
155 (revlastlist)
156 (curlpair curlclo)
157 (debug "hook_override_gate last curlclo=" curlclo " memref=" memref)
158 (assert_msg "check curlclo" (is_closure curlclo) curlclo)
159 (let ( (clores (curlclo gateflag memref passname passnum))
160 )
161 (debug "hook_override_gate last clores=" clores)
162 (setq gateflag clores)))
163 ;;
164 (debug "hook_override_gate final gateflag=" gateflag
165 "\n passname=" passname " passnum=" passnum)
166 (if gateflag
167 (setq aftergate 1)
168 (setq aftergate 0))
169 )
170 )
172 (cheader
173 #{ /* cheader for override gate in warmelt-hooks.melt */
174 static void
175 melt_override_gate_callback (void* gccdata,
176 void* userdata ATTRIBUTE_UNUSED)
177 {
178 bool *pgatestatus = (bool*) gccdata;
179 bool gatsta = false;
180 long oldgatstalng = 0, newgatstalng = 0;
181 gcc_assert (pgatestatus != NULL);
182 gatsta = *pgatestatus;
183 oldgatstalng = newgatstalng = (long)gatsta;
184 melthookproc_HOOK_OVERRIDE_GATE (oldgatstalng, &newgatstalng);
185 gatsta = (newgatstalng != 0L);
186 *pgatestatus = gatsta;
187 } /* end of melt_override_gate_callback */
188 }#)
191 ;; internal flag set when PLUGIN_OVERRIDE_GATE registered
193 (cheader #{/* flag for PLUGIN_OVERRIDE_GATE */
194 MELT_EXTERN bool MELT_MODULE_VISIBILITY melthk_override_gate_registered_flag;
195 }#)
197 (cimplement #{/* flag for PLUGIN_OVERRIDE_GATE */
198 bool melthk_override_gate_registered_flag;
199 }#)
201 ;; internal function to enable the plugin hook
202 (defun enable_override_gate ()
203 (code_chunk
204 regpluginoverride_gate_chk
205 #{ /* enable_override_gate $REGPLUGINOVERRIDE_GATE_CHK */
206 if (!melthk_override_gate_registered_flag)
207 {
208 melthk_override_gate_registered_flag = true;
209 register_callback (melt_plugin_name, PLUGIN_OVERRIDE_GATE,
210 melt_override_gate_callback,
211 NULL);
212 }
213 }#)
214 )
216 ;; internal function to disable the plugin hook
217 (defun maybe_disable_override_gate ()
218 (when (and
219 (null (list_first (get_field :delqu_first override_gate_delayed_queue)))
220 (null (list_first (get_field :delqu_last override_gate_delayed_queue))))
221 (code_chunk
222 unregpluginoverride_gate_chk
223 #{ /* disable_override_gate $UNREGPLUGINOVERRIDE_GATE_CHK */
224 if (melthk_override_gate_registered_flag)
225 {
226 melthk_override_gate_registered_flag = false;
227 unregister_callback (melt_plugin_name, PLUGIN_OVERRIDE_GATE);
228 }
229 }#)
230 ))
232 ;; public functions to register
233 (defun register_override_gate_first (clo)
234 :doc #{Register a function $CLO for @code{PLUGIN_OVERRIDE_GATE} at first place.
235 See also $UNREGISTER_OVERRIDE_GATE_FIRST, $REGISTER_OVERRIDE_GATE_LAST, etc..}#
236 (debug "register_override_gate_first clo=" clo)
237 (when (is_closure clo)
238 (list_append (get_field :delqu_first override_gate_delayed_queue) clo)
239 (enable_override_gate)))
241 (defun register_override_gate_last (clo)
242 :doc #{Register a function $CLO for @code{PLUGIN_OVERRIDE_GATE} at last place.
243 See also $UNREGISTER_OVERRIDE_GATE_LAST, $REGISTER_OVERRIDE_GATE_FIRST, etc...}#
244 (debug "register_override_gate_last clo=" clo)
245 (when (is_closure clo)
246 (list_append (get_field :delqu_last override_gate_delayed_queue) clo)
247 (enable_override_gate)))
249 (defun unregister_override_gate_first (clo)
250 :doc #{Unregister a function $CLO previously registered with
251 $REGISTER_OVERRIDE_GATE_FIRST for @code{PLUGIN_OVERRIDE_GATE},
252 return the boxed count of removed closures or null on failure.}#
253 (debug "unregister_override_gate_first clo=" clo)
254 (let ( (oldlis (get_field :delqu_first override_gate_delayed_queue))
255 (newlis (make_list discr_list))
256 (:long count 0)
257 )
258 (foreach_pair_component_in_list
259 (oldlis)
260 (curpair curclo)
261 (if (== curclo clo)
262 (setq count (+i count 1))
263 (list_append newlis curclo)))
264 (when count
265 (put_fields override_gate_delayed_queue :delqu_first newlis)
266 (maybe_disable_override_gate)
267 (debug "unregister_override_gate_first count=" count)
268 (return (constant_box count)))
269 (debug "unregister_override_gate_first fail")
270 (return ())))
272 (defun unregister_override_gate_last (clo)
273 :doc #{Unregister a function $CLO previously registered with
274 $REGISTER_OVERRIDE_GATE_LAST for @code{PLUGIN_OVERRIDE_GATE},
275 return the boxed count of removed closures or null on failure.}#
276 (debug "unregister_override_gate_last clo=" clo)
277 (let ( (oldlis (get_field :delqu_last override_gate_delayed_queue))
278 (newlis (make_list discr_list))
279 (:long count 0)
280 )
281 (foreach_pair_component_in_list
282 (oldlis)
283 (curpair curclo)
284 (if (== curclo clo)
285 (setq count (+i count 1))
286 (list_append newlis curclo)))
287 (when count
288 (put_fields override_gate_delayed_queue :delqu_last newlis)
289 (maybe_disable_override_gate)
290 (debug "unregister_override_gate_last count=" count)
291 (return (constant_box count)))
292 (debug "unregister_override_gate_last fail")
293 (return ())))
295 ;;;====================================================================
296 ;;;******************* START_UNIT plugin event *********************
297 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
299 (cheader #{/* flag for PLUGIN_START_UNIT */
300 MELT_EXTERN bool MELT_MODULE_VISIBILITY melthk_start_unit_registered_flag;
301 }#)
303 (cimplement #{/* flag for for PLUGIN_START_UNIT */
304 bool melthk_start_unit_registered_flag;
305 }#)
307 ;;;;;; private queue for start of compilation unit
308 (definstance start_unit_delayed_queue class_delayed_queue
309 :named_name '"start_unit_delayed_queue"
310 :delqu_first (make_list discr_list)
311 :delqu_last (make_list discr_list)
312 )
314 ;; this internal hook needs to be predefined to remain alive for the
315 ;; MELT & Ggc garbage collectors...
316 (defhook hook_start_unit () () :void
317 :predef HOOK_START_UNIT
318 (let ( (firstlist (unsafe_get_field :delqu_first start_unit_delayed_queue))
319 (lastlist (unsafe_get_field :delqu_last start_unit_delayed_queue))
320 (revlastlist (make_list discr_list))
321 (rescont (instance class_reference))
322 )
323 ;;; call the first routines in natural order
324 (list_every
325 firstlist
326 (lambda (firstproc)
327 (let ( (prevres (unsafe_get_field :referenced_value rescont))
328 (nextres (firstproc prevres start_unit_delayed_queue))
329 )
330 (unsafe_put_fields rescont :referenced_value nextres)
331 )))
332 ;;; reverse the last list
333 (list_every
334 lastlist
335 (lambda (lastproc)
336 (if (is_closure lastproc) (list_prepend revlastlist lastproc))))
337 ;;; call the last routines in reverse order
338 (list_every
339 revlastlist
340 (lambda (lastproc)
341 (let ( (prevres (unsafe_get_field :referenced_value rescont))
342 (nextres (lastproc prevres start_unit_delayed_queue))
343 )
344 (unsafe_put_fields rescont :referenced_value nextres)
345 )))
346 ))
348 (cheader #{
349 void MELT_MODULE_VISIBILITY
350 melt_startunithook_callback (void* gcc_data ATTRIBUTE_UNUSED,
351 void* user_data ATTRIBUTE_UNUSED);
352 }#)
354 (cimplement #{
355 void
356 melt_startunithook_callback (void* gcc_data ATTRIBUTE_UNUSED,
357 void* user_data ATTRIBUTE_UNUSED)
358 {
359 melthookproc_HOOK_START_UNIT ();
360 }
361 }#)
363 ;; internal function to enable the plugin hook
364 (defun enable_start_unit ()
365 (code_chunk
366 enabstartunit_chk
367 #{
368 if (!melthk_start_unit_registered_flag)
369 {
370 melthk_start_unit_registered_flag = true;
371 register_callback (melt_plugin_name, PLUGIN_START_UNIT,
372 melt_startunithook_callback,
373 NULL);
374 }
375 }#)
376 )
379 (defun at_start_unit_first (fun)
380 :doc #{Use $AT_START_UNIT_FIRST to register a function to be run at start of translation unit, in first place.}#
381 (let ( (firstlist (unsafe_get_field :delqu_first start_unit_delayed_queue))
382 )
383 (when (is_closure fun)
384 (enable_start_unit)
385 (list_append firstlist fun)))
386 )
388 (defun at_start_unit_last (fun)
389 :doc #{Use $AT_START_UNIT_LAST to register a function to be run at start of translation unit, in first place.}#
390 (let ( (lastlist (unsafe_get_field :delqu_last start_unit_delayed_queue))
391 )
392 (when (is_closure fun)
393 (enable_start_unit)
394 (list_append lastlist fun)))
395 )
398 ;;;====================================================================
399 ;;;******************* FINISH_UNIT plugin event *********************
400 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
403 ;;;; the private queue for compilation unit finish
404 (definstance finish_unit_delayed_queue class_delayed_queue
405 :named_name '"finish_unit_delayed_queue"
406 :delqu_first (make_list discr_list)
407 :delqu_last (make_list discr_list)
408 )
410 (cheader #{/* flag for PLUGIN_FINISH_UNIT */
411 MELT_EXTERN bool MELT_MODULE_VISIBILITY melthk_finish_unit_registered_flag;
412 }#)
414 (cimplement #{/* flag for PLUGIN_FINISH_UNIT */
415 bool MELT_MODULE_VISIBILITY melthk_finish_unit_registered_flag;
416 }#)
418 (defhook hook_finish_unit () () :void
419 :predef HOOK_FINISH_UNIT
420 (let ( (firstlist (unsafe_get_field :delqu_first finish_unit_delayed_queue))
421 (lastlist (unsafe_get_field :delqu_last finish_unit_delayed_queue))
422 (revlastlist (make_list discr_list))
423 (rescont (instance class_reference))
424 )
425 ;;; call the first routines in natural order
426 (list_every
427 firstlist
428 (lambda (firstproc)
429 (let ( (prevres (unsafe_get_field :referenced_value rescont))
430 (nextres (firstproc prevres finish_unit_delayed_queue))
431 )
432 (unsafe_put_fields rescont :referenced_value nextres)
433 )))
434 ;;; reverse the last list
435 (list_every
436 lastlist
437 (lambda (lastproc)
438 (if (is_closure lastproc) (list_prepend revlastlist lastproc))))
439 ;;; call the last routines in reverse order
440 (list_every
441 revlastlist
442 (lambda (lastproc)
443 (let ( (prevres (unsafe_get_field :referenced_value rescont))
444 (nextres (lastproc prevres finish_unit_delayed_queue))
445 )
446 (unsafe_put_fields rescont :referenced_value nextres)
447 )))
448 ;;; force a minor GC to ensure nothing stays in the young region
449 (code_chunk finishunitminorgc_chk
450 #{/*hook_finish_unit $FINISHUNITMINORGC_CHK*/ melt_garbcoll (0, MELT_ONLY_MINOR)}#)
451 ))
454 (cheader
455 #{
456 void MELT_MODULE_VISIBILITY
457 melt_finishunithook_callback (void* gcc_data ATTRIBUTE_UNUSED,
458 void* user_data ATTRIBUTE_UNUSED);
459 }#)
461 (cimplement
462 #{
463 void
464 melt_finishunithook_callback (void* gcc_data ATTRIBUTE_UNUSED,
465 void* user_data ATTRIBUTE_UNUSED)
466 {
467 melthookproc_HOOK_FINISH_UNIT ();
468 }
469 }#)
470 (defun enable_finish_unit ()
471 (code_chunk
472 enfinishunit_chk
473 #{ /* enable_finish_unit $ENFINISHUNIT_CHK */
474 if (!melthk_finish_unit_registered_flag)
475 {
476 melthk_finish_unit_registered_flag = true;
477 register_callback (melt_plugin_name, PLUGIN_FINISH_UNIT,
478 melt_finishunithook_callback,
479 NULL);
480 }
481 }#)
482 )
484 (defun at_finish_unit_first (fun)
485 :doc #{Use $AT_FINISH_UNIT_FIRST to register a function to be run at
486 end of compilation unit in first place}#
487 (let ( (firstlist (unsafe_get_field :delqu_first finish_unit_delayed_queue))
488 )
489 (when (is_closure fun)
490 (enable_finish_unit)
491 (list_append firstlist fun)))
492 )
494 (defun at_finish_unit_last (fun)
495 :doc #{Use $AT_FINISH_UNIT_LAST to register a function to be run at
496 end of compilation unit in last place}#
497 (let ( (lastlist (unsafe_get_field :delqu_last finish_unit_delayed_queue))
498 )
499 (when (is_closure fun)
500 (enable_finish_unit)
501 (list_append lastlist fun)))
502 )
508 ;;;====================================================================
509 ;;;****************** ALL_PASSES_START plugin event *******************
510 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
512 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
513 ;;; handling PLUGIN_ALL_PASSES_START
514 ;; private all_passes_start handling queue
515 (definstance all_passes_start_delayed_queue class_delayed_queue
516 :named_name '"all_passes_start_delayed_queue"
517 :delqu_first ()
518 :delqu_last ()
519 )
521 (cheader #{/* flag for PLUGIN_ALL_PASSES_START declare */
522 MELT_EXTERN bool MELT_MODULE_VISIBILITY melthk_all_passes_start_registered_flag;
523 }#)
524 (cimplement #{/* flag for PLUGIN_ALL_PASSES_START define */
525 bool melthk_all_passes_start_registered_flag;
526 }#)
528 ;; internal hook for PLUGIN_ALL_PASSES_START
529 (defhook hook_all_passes_start () () :void
530 :predef HOOK_ALL_PASSES_START
531 (let ( (firstlist (get_field :delqu_first all_passes_start_delayed_queue))
532 (lastlist (get_field :delqu_last all_passes_start_delayed_queue))
533 (revlastlist (make_list discr_list))
534 (res ())
535 )
536 ;;; call the first routines in natural order
537 (foreach_pair_component_in_list
538 (firstlist)
539 (firstpair firstproc)
540 (setq res (firstproc res))
541 )
542 ;;; reverse the last list
543 (foreach_pair_component_in_list
544 (lastlist)
545 (lastpair lastproc)
546 (if (is_closure lastproc) (list_prepend revlastlist lastproc)))
547 ;;; call the last routines in reverse order
548 (if lastlist
549 (foreach_pair_component_in_list
550 (revlastlist)
551 (revlastpair revlastproc)
552 (setq res (revlastproc res))
553 ))))
555 (cheader #{
556 void MELT_MODULE_VISIBILITY
557 melt_all_passes_start_hook_callback (void* gcc_data ATTRIBUTE_UNUSED,
558 void* user_data ATTRIBUTE_UNUSED);
559 }#)
561 (cimplement #{
562 void
563 melt_all_passes_start_hook_callback (void* gcc_data ATTRIBUTE_UNUSED,
564 void* user_data ATTRIBUTE_UNUSED)
565 {
566 melthookproc_HOOK_ALL_PASSES_START ();
567 }
568 }#)
570 (defun enable_all_passes_start ()
571 (code_chunk
572 enallpassesstart_chk
573 #{ /* enable_all_passes_start $ENALLPASSESSTART_CHK */
574 if (!melthk_all_passes_start_registered_flag) {
575 melthk_all_passes_start_registered_flag = true;
576 register_callback (melt_plugin_name, PLUGIN_ALL_PASSES_START,
577 melt_all_passes_start_hook_callback,
578 NULL);
579 }
580 }#
581 ))
583 (defun register_all_passes_start_first (fun)
584 :doc #{Use $REGISTER_ALL_PASSES_START_FIRST to register a function $FUN to
585 be run at PLUGIN_ALL_PASSES_START, in first place. $FUN must be a closure
586 which takes no arguments and whose result is ignored.}#
587 (if (is_closure fun)
588 (let ( (firstlist (get_field :delqu_first all_passes_start_delayed_queue))
589 )
590 (enable_all_passes_start)
591 (if (null firstlist)
592 (progn
593 (setq firstlist (make_list discr_list))
594 (put_fields
595 all_passes_start_delayed_queue
596 :delqu_first firstlist
597 :delqu_last (make_list discr_list))
598 ))
599 (list_append firstlist fun)
600 )
601 ;; fun not a closure
602 (errormsg_plain
603 "Bad function (non closure) passed to register_all_passes_start_hook_first")
604 ))
606 (defun register_all_passes_start_last (fun)
607 :doc #{Use $REGISTER_ALL_PASSES_START_LAST to register a function $FUN to
608 be run at PLUGIN_ALL_PASSES_START, in last place. $FUN must be a closure
609 which takes no argument and whose result is ignored.}#
610 (if (is_closure fun)
611 (let ( (lastlist (get_field :delqu_last all_passes_start_delayed_queue))
612 )
613 (enable_all_passes_start)
614 (if (null lastlist)
615 (progn
616 (setq lastlist (make_list discr_list))
617 (put_fields
618 all_passes_start_delayed_queue
619 :delqu_first (make_list discr_list)
620 :delqu_last lastlist)
621 ))
622 (list_append lastlist fun)
623 )
624 ;; fun not a closure
625 (errormsg_plain
626 "Bad function (non closure) passed to register_all_passes_start_hook_last")
627 ))
630 ;;;====================================================================
631 ;;;****************** ALL_PASSES_END plugin event *******************
632 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
636 (cheader #{/* flag for PLUGIN_ALL_PASSES_END declare */
637 MELT_EXTERN bool MELT_MODULE_VISIBILITY melthk_all_passes_end_registered_flag;
638 }#)
639 (cimplement #{/* flag for PLUGIN_ALL_PASSES_END define */
640 bool melthk_all_passes_end_registered_flag;
641 }#)
642 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
643 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
644 ;;; handling PLUGIN_ALL_PASSES_END
645 ;; private all_passes_end handling queue
646 (definstance all_passes_end_delayed_queue class_delayed_queue
647 :named_name '"all_passes_end_delayed_queue"
648 :delqu_first ()
649 :delqu_last ()
650 )
652 ;; internal private hook for PLUGIN_ALL_PASSES_END
653 (defhook hook_all_passes_end () () :void
654 :predef HOOK_ALL_PASSES_END
655 (let ( (firstlist (get_field :delqu_first all_passes_end_delayed_queue))
656 (lastlist (get_field :delqu_last all_passes_end_delayed_queue))
657 (revlastlist (make_list discr_list))
658 (res ())
659 )
660 ;;; call the first routines in natural order
661 (foreach_pair_component_in_list
662 (firstlist)
663 (firstpair firstproc)
664 (setq res (firstproc res))
665 )
666 ;;; reverse the last list
667 (foreach_pair_component_in_list
668 (lastlist)
669 (lastpair lastproc)
670 (if (is_closure lastproc) (list_prepend revlastlist lastproc)))
671 ;;; call the last routines in reverse order
672 (foreach_pair_component_in_list
673 (revlastlist)
674 (revlastpair revlastproc)
675 (setq res (revlastproc res))
676 )
677 ;;; remove the entire the pass dictionnary, to help releasing some
678 ;;; resources
679 ;; see https://groups.google.com/d/msg/gcc-melt/Xd2_pi42GA0/oKEMjGimgB8J
680 ;; and https://gcc.gnu.org/ml/gcc/2014-08/msg00313.html
681 (put_fields initial_system_data :sysdata_pass_dict ())
682 ))
684 (cheader #{
685 void MELT_MODULE_VISIBILITY
686 melt_all_passes_end_hook_callback (void* gcc_data ATTRIBUTE_UNUSED,
687 void* user_data ATTRIBUTE_UNUSED);
688 }#)
690 (cimplement #{
691 void
692 melt_all_passes_end_hook_callback (void* gcc_data ATTRIBUTE_UNUSED,
693 void* user_data ATTRIBUTE_UNUSED)
694 {
695 melthookproc_HOOK_ALL_PASSES_END ();
696 }
697 }#)
699 (defun enable_all_passes_end ()
700 (code_chunk
701 enallpassesend_chk
702 #{ /* enable_all_passes_end $ENALLPASSESEND_CHK */
703 if (!melthk_all_passes_end_registered_flag) {
704 melthk_all_passes_end_registered_flag = true;
705 register_callback (melt_plugin_name, PLUGIN_ALL_PASSES_END,
706 melt_all_passes_end_hook_callback,
707 NULL);
708 }
709 }#
710 ))
712 (defun register_all_passes_end_first (fun)
713 :doc #{Use $REGISTER_ALL_PASSES_END_FIRST to register a function $FUN to
714 be run at PLUGIN_ALL_PASSES_END, in first place. $FUN must be a closure
715 which takes no argument and whose result is ignored.}#
716 (if (is_closure fun)
717 (let ( (firstlist (get_field :delqu_first all_passes_end_delayed_queue))
718 )
719 (enable_all_passes_end)
720 (if (null firstlist)
721 (progn
722 (setq firstlist (make_list discr_list))
723 (put_fields
724 all_passes_end_delayed_queue
725 :delqu_first firstlist
726 :delqu_last (make_list discr_list))
727 ))
728 (list_append firstlist fun)
729 )
730 ;; fun not a closure
731 (errormsg_plain
732 "Bad function (non closure) passed to register_all_passes_end_first")
733 ))
735 (defun register_all_passes_end_last (fun)
736 :doc #{Use $REGISTER_ALL_PASSES_END_LAST to register a function $FUN to
737 be run at PLUGIN_ALL_PASSES_END, in last place. $FUN must be a closure
738 which takes no arguments and whose result is ignored.}#
739 (if (is_closure fun)
740 (let ( (lastlist (get_field :delqu_last all_passes_end_delayed_queue))
741 )
742 (enable_all_passes_end)
743 (if (null lastlist)
744 (progn
745 (setq lastlist (make_list discr_list))
746 (put_fields
747 all_passes_end_delayed_queue
748 :delqu_first (make_list discr_list)
749 :delqu_last lastlist)
750 ))
751 (list_append lastlist fun)
752 )
753 ;; fun not a closure
754 (errormsg_plain
755 "Bad function (non closure) passed to register_all_passes_end_last")
756 ))
759 ;;;====================================================================
760 ;;;****************** ALL_IPA_PASSES_START plugin event *******************
761 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
763 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
764 ;;; handling PLUGIN_ALL_IPA_PASSES_START
765 ;; private all_ipa_passes_start handling queue
766 (definstance all_ipa_passes_start_delayed_queue class_delayed_queue
767 :named_name '"all_ipa_passes_start_delayed_queue"
768 :delqu_first ()
769 :delqu_last ()
770 )
772 (cheader #{/* flag for PLUGIN_ALL_IPA_PASSES_START declare */
773 MELT_EXTERN bool MELT_MODULE_VISIBILITY melthk_all_ipa_passes_start_registered_flag;
774 }#)
775 (cimplement #{/* flag for PLUGIN_ALL_IPA_PASSES_START define */
776 bool melthk_all_ipa_passes_start_registered_flag;
777 }#)
779 ;; internal hook for PLUGIN_ALL_IPA_PASSES_START
780 (defhook hook_all_ipa_passes_start () () :void
781 :predef HOOK_ALL_IPA_PASSES_START
782 (let ( (firstlist (get_field :delqu_first all_ipa_passes_start_delayed_queue))
783 (lastlist (get_field :delqu_last all_ipa_passes_start_delayed_queue))
784 (revlastlist (make_list discr_list))
785 (res ())
786 )
787 ;;; call the first routines in natural order
788 (foreach_pair_component_in_list
789 (firstlist)
790 (firstpair firstproc)
791 (setq res (firstproc res))
792 )
793 ;;; reverse the last list
794 (foreach_pair_component_in_list
795 (lastlist)
796 (lastpair lastproc)
797 (if (is_closure lastproc) (list_prepend revlastlist lastproc)))
798 ;;; call the last routines in reverse order
799 (if lastlist
800 (foreach_pair_component_in_list
801 (revlastlist)
802 (revlastpair revlastproc)
803 (setq res (revlastproc res))
804 ))))
806 (cheader #{
807 void MELT_MODULE_VISIBILITY
808 melt_all_ipa_passes_start_hook_callback (void* gcc_data ATTRIBUTE_UNUSED,
809 void* user_data ATTRIBUTE_UNUSED);
810 }#)
812 (cimplement #{
813 void
814 melt_all_ipa_passes_start_hook_callback (void* gcc_data ATTRIBUTE_UNUSED,
815 void* user_data ATTRIBUTE_UNUSED)
816 {
817 melthookproc_HOOK_ALL_IPA_PASSES_START ();
818 }
819 }#)
821 (defun enable_all_ipa_passes_start ()
822 (code_chunk
823 enallpassesstart_chk
824 #{ /* enable_all_ipa_passes_start $ENALLPASSESSTART_CHK */
825 if (!melthk_all_ipa_passes_start_registered_flag) {
826 melthk_all_ipa_passes_start_registered_flag = true;
827 register_callback (melt_plugin_name, PLUGIN_ALL_IPA_PASSES_START,
828 melt_all_ipa_passes_start_hook_callback,
829 NULL);
830 }
831 }#
832 ))
834 (defun register_all_ipa_passes_start_first (fun)
835 :doc #{Use $REGISTER_ALL_IPA_PASSES_START_FIRST to register a function $FUN to
836 be run at PLUGIN_ALL_IPA_PASSES_START, in first place. $FUN must be a closure
837 which takes no arguments and whose result is ignored.}#
838 (if (is_closure fun)
839 (let ( (firstlist (get_field :delqu_first all_ipa_passes_start_delayed_queue))
840 )
841 (enable_all_ipa_passes_start)
842 (if (null firstlist)
843 (progn
844 (setq firstlist (make_list discr_list))
845 (put_fields
846 all_ipa_passes_start_delayed_queue
847 :delqu_first firstlist
848 :delqu_last (make_list discr_list))
849 ))
850 (list_append firstlist fun)
851 )
852 ;; fun not a closure
853 (errormsg_plain
854 "Bad function (non closure) passed to register_all_ipa_passes_start_hook_first")
855 ))
857 (defun register_all_ipa_passes_start_last (fun)
858 :doc #{Use $REGISTER_ALL_IPA_PASSES_START_LAST to register a function $FUN to
859 be run at PLUGIN_ALL_IPA_PASSES_START, in last place. $FUN must be a closure
860 which takes no argument and whose result is ignored.}#
861 (if (is_closure fun)
862 (let ( (lastlist (get_field :delqu_last all_ipa_passes_start_delayed_queue))
863 )
864 (enable_all_ipa_passes_start)
865 (if (null lastlist)
866 (progn
867 (setq lastlist (make_list discr_list))
868 (put_fields
869 all_ipa_passes_start_delayed_queue
870 :delqu_first (make_list discr_list)
871 :delqu_last lastlist)
872 ))
873 (list_append lastlist fun)
874 )
875 ;; fun not a closure
876 (errormsg_plain
877 "Bad function (non closure) passed to register_all_ipa_passes_start_hook_last")
878 ))
881 ;;;====================================================================
882 ;;;****************** ALL_IPA_PASSES_END plugin event *******************
883 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
887 (cheader #{/* flag for PLUGIN_ALL_IPA_PASSES_END declare */
888 MELT_EXTERN bool MELT_MODULE_VISIBILITY melthk_all_ipa_passes_end_registered_flag;
889 }#)
890 (cimplement #{/* flag for PLUGIN_ALL_IPA_PASSES_END define */
891 bool melthk_all_ipa_passes_end_registered_flag;
892 }#)
893 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
894 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
895 ;;; handling PLUGIN_ALL_IPA_PASSES_END
896 ;; private all_ipa_passes_end handling queue
897 (definstance all_ipa_passes_end_delayed_queue class_delayed_queue
898 :named_name '"all_ipa_passes_end_delayed_queue"
899 :delqu_first ()
900 :delqu_last ()
901 )
903 ;; internal private hook for PLUGIN_ALL_IPA_PASSES_END
904 (defhook hook_all_ipa_passes_end () () :void
905 :predef HOOK_ALL_IPA_PASSES_END
906 (let ( (firstlist (get_field :delqu_first all_ipa_passes_end_delayed_queue))
907 (lastlist (get_field :delqu_last all_ipa_passes_end_delayed_queue))
908 (revlastlist (make_list discr_list))
909 (res ())
910 )
911 ;;; call the first routines in natural order
912 (foreach_pair_component_in_list
913 (firstlist)
914 (firstpair firstproc)
915 (setq res (firstproc res))
916 )
917 ;;; reverse the last list
918 (foreach_pair_component_in_list
919 (lastlist)
920 (lastpair lastproc)
921 (if (is_closure lastproc) (list_prepend revlastlist lastproc)))
922 ;;; call the last routines in reverse order
923 (foreach_pair_component_in_list
924 (revlastlist)
925 (revlastpair revlastproc)
926 (setq res (revlastproc res))
927 )))
929 (cheader #{
930 void MELT_MODULE_VISIBILITY
931 melt_all_ipa_passes_end_hook_callback (void* gcc_data ATTRIBUTE_UNUSED,
932 void* user_data ATTRIBUTE_UNUSED);
933 }#)
935 (cimplement #{
936 void
937 melt_all_ipa_passes_end_hook_callback (void* gcc_data ATTRIBUTE_UNUSED,
938 void* user_data ATTRIBUTE_UNUSED)
939 {
940 melthookproc_HOOK_ALL_IPA_PASSES_END ();
941 }
942 }#)
944 (defun enable_all_ipa_passes_end ()
945 (code_chunk
946 enallpassesend_chk
947 #{ /* enable_all_ipa_passes_end $ENALLPASSESEND_CHK */
948 if (!melthk_all_ipa_passes_end_registered_flag) {
949 melthk_all_ipa_passes_end_registered_flag = true;
950 register_callback (melt_plugin_name, PLUGIN_ALL_IPA_PASSES_END,
951 melt_all_ipa_passes_end_hook_callback,
952 NULL);
953 }
954 }#
955 ))
957 (defun register_all_ipa_passes_end_first (fun)
958 :doc #{Use $REGISTER_ALL_IPA_PASSES_END_FIRST to register a function $FUN to
959 be run at PLUGIN_ALL_IPA_PASSES_END, in first place. $FUN must be a closure
960 which takes no argument and whose result is ignored.}#
961 (if (is_closure fun)
962 (let ( (firstlist (get_field :delqu_first all_ipa_passes_end_delayed_queue))
963 )
964 (enable_all_ipa_passes_end)
965 (if (null firstlist)
966 (progn
967 (setq firstlist (make_list discr_list))
968 (put_fields
969 all_ipa_passes_end_delayed_queue
970 :delqu_first firstlist
971 :delqu_last (make_list discr_list))
972 ))
973 (list_append firstlist fun)
974 )
975 ;; fun not a closure
976 (errormsg_plain
977 "Bad function (non closure) passed to register_all_ipa_passes_end_first")
978 ))
980 (defun register_all_ipa_passes_end_last (fun)
981 :doc #{Use $REGISTER_ALL_IPA_PASSES_END_LAST to register a function $FUN to
982 be run at PLUGIN_ALL_IPA_PASSES_END, in last place. $FUN must be a closure
983 which takes no arguments and whose result is ignored.}#
984 (if (is_closure fun)
985 (let ( (lastlist (get_field :delqu_last all_ipa_passes_end_delayed_queue))
986 )
987 (enable_all_ipa_passes_end)
988 (if (null lastlist)
989 (progn
990 (setq lastlist (make_list discr_list))
991 (put_fields
992 all_ipa_passes_end_delayed_queue
993 :delqu_first (make_list discr_list)
994 :delqu_last lastlist)
995 ))
996 (list_append lastlist fun)
997 )
998 ;; fun not a closure
999 (errormsg_plain
1000 "Bad function (non closure) passed to register_all_ipa_passes_end_last")
1001 ))
1005 ;;;====================================================================
1006 ;;;************** EARLY_GIMPLE_PASSES_START plugin event **************
1007 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1009 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1010 ;;; handling PLUGIN_EARLY_GIMPLE_PASSES_START
1011 ;; private early_gimple_passes_start handling queue
1012 (definstance early_gimple_passes_start_delayed_queue class_delayed_queue
1013 :named_name '"early_gimple_passes_start_delayed_queue"
1014 :delqu_first ()
1015 :delqu_last ()
1016 )
1018 (cheader #{/* flag for PLUGIN_EARLY_GIMPLE_PASSES_START declare */
1019 MELT_EXTERN bool MELT_MODULE_VISIBILITY melthk_early_gimple_passes_start_registered_flag;
1020 }#)
1021 (cimplement #{/* flag for PLUGIN_EARLY_GIMPLE_PASSES_START define */
1022 bool melthk_early_gimple_passes_start_registered_flag;
1023 }#)
1025 ;; internal hook for PLUGIN_EARLY_GIMPLE_PASSES_START
1026 (defhook hook_early_gimple_passes_start () () :void
1027 :predef HOOK_EARLY_GIMPLE_PASSES_START
1028 (let ( (firstlist (get_field :delqu_first early_gimple_passes_start_delayed_queue))
1029 (lastlist (get_field :delqu_last early_gimple_passes_start_delayed_queue))
1030 (revlastlist (make_list discr_list))
1031 (res ())
1032 )
1033 ;;; call the first routines in natural order
1034 (foreach_pair_component_in_list
1035 (firstlist)
1036 (firstpair firstproc)
1037 (setq res (firstproc res))
1038 )
1039 ;;; reverse the last list
1040 (foreach_pair_component_in_list
1041 (lastlist)
1042 (lastpair lastproc)
1043 (if (is_closure lastproc) (list_prepend revlastlist lastproc)))
1044 ;;; call the last routines in reverse order
1045 (if lastlist
1046 (foreach_pair_component_in_list
1047 (revlastlist)
1048 (revlastpair revlastproc)
1049 (setq res (revlastproc res))
1050 ))))
1052 (cheader #{
1053 void MELT_MODULE_VISIBILITY
1054 melt_early_gimple_passes_start_hook_callback (void* gcc_data ATTRIBUTE_UNUSED,
1055 void* user_data ATTRIBUTE_UNUSED);
1056 }#)
1058 (cimplement #{
1059 void
1060 melt_early_gimple_passes_start_hook_callback (void* gcc_data ATTRIBUTE_UNUSED,
1061 void* user_data ATTRIBUTE_UNUSED)
1062 {
1063 melthookproc_HOOK_EARLY_GIMPLE_PASSES_START ();
1064 }
1065 }#)
1067 (defun enable_early_gimple_passes_start ()
1068 (code_chunk
1069 enallpassesstart_chk
1070 #{ /* enable_early_gimple_passes_start $ENALLPASSESSTART_CHK */
1071 if (!melthk_early_gimple_passes_start_registered_flag) {
1072 melthk_early_gimple_passes_start_registered_flag = true;
1073 register_callback (melt_plugin_name, PLUGIN_EARLY_GIMPLE_PASSES_START,
1074 melt_early_gimple_passes_start_hook_callback,
1075 NULL);
1076 }
1077 }#
1078 ))
1080 (defun register_early_gimple_passes_start_first (fun)
1081 :doc #{Use $REGISTER_EARLY_GIMPLE_PASSES_START_FIRST to register a function $FUN to
1082 be run at PLUGIN_EARLY_GIMPLE_PASSES_START, in first place. $FUN must be a closure
1083 which takes no arguments and whose result is ignored.}#
1084 (if (is_closure fun)
1085 (let ( (firstlist (get_field :delqu_first early_gimple_passes_start_delayed_queue))
1086 )
1087 (enable_early_gimple_passes_start)
1088 (if (null firstlist)
1089 (progn
1090 (setq firstlist (make_list discr_list))
1091 (put_fields
1092 early_gimple_passes_start_delayed_queue
1093 :delqu_first firstlist
1094 :delqu_last (make_list discr_list))
1095 ))
1096 (list_append firstlist fun)
1097 )
1098 ;; fun not a closure
1099 (errormsg_plain
1100 "Bad function (non closure) passed to register_early_gimple_passes_start_hook_first")
1101 ))
1103 (defun register_early_gimple_passes_start_last (fun)
1104 :doc #{Use $REGISTER_EARLY_GIMPLE_PASSES_START_LAST to register a function $FUN to
1105 be run at PLUGIN_EARLY_GIMPLE_PASSES_START, in last place. $FUN must be a closure
1106 which takes no argument and whose result is ignored.}#
1107 (if (is_closure fun)
1108 (let ( (lastlist (get_field :delqu_last early_gimple_passes_start_delayed_queue))
1109 )
1110 (enable_early_gimple_passes_start)
1111 (if (null lastlist)
1112 (progn
1113 (setq lastlist (make_list discr_list))
1114 (put_fields
1115 early_gimple_passes_start_delayed_queue
1116 :delqu_first (make_list discr_list)
1117 :delqu_last lastlist)
1118 ))
1119 (list_append lastlist fun)
1120 )
1121 ;; fun not a closure
1122 (errormsg_plain
1123 "Bad function (non closure) passed to register_early_gimple_passes_start_hook_last")
1124 ))
1127 ;;;=====================================================================
1128 ;;;*************** EARLY_GIMPLE_PASSES_END plugin event ****************
1129 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1133 (cheader #{/* flag for PLUGIN_EARLY_GIMPLE_PASSES_END declare */
1134 MELT_EXTERN bool MELT_MODULE_VISIBILITY melthk_early_gimple_passes_end_registered_flag;
1135 }#)
1136 (cimplement #{/* flag for PLUGIN_EARLY_GIMPLE_PASSES_END define */
1137 bool melthk_early_gimple_passes_end_registered_flag;
1138 }#)
1139 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1140 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1141 ;;; handling PLUGIN_EARLY_GIMPLE_PASSES_END
1142 ;; private early_gimple_passes_end handling queue
1143 (definstance early_gimple_passes_end_delayed_queue class_delayed_queue
1144 :named_name '"early_gimple_passes_end_delayed_queue"
1145 :delqu_first ()
1146 :delqu_last ()
1147 )
1149 ;; internal private hook for PLUGIN_EARLY_GIMPLE_PASSES_END
1150 (defhook hook_early_gimple_passes_end () () :void
1151 :predef HOOK_EARLY_GIMPLE_PASSES_END
1152 (let ( (firstlist (get_field :delqu_first early_gimple_passes_end_delayed_queue))
1153 (lastlist (get_field :delqu_last early_gimple_passes_end_delayed_queue))
1154 (revlastlist (make_list discr_list))
1155 (res ())
1156 )
1157 ;;; call the first routines in natural order
1158 (foreach_pair_component_in_list
1159 (firstlist)
1160 (firstpair firstproc)
1161 (setq res (firstproc res))
1162 )
1163 ;;; reverse the last list
1164 (foreach_pair_component_in_list
1165 (lastlist)
1166 (lastpair lastproc)
1167 (if (is_closure lastproc) (list_prepend revlastlist lastproc)))
1168 ;;; call the last routines in reverse order
1169 (foreach_pair_component_in_list
1170 (revlastlist)
1171 (revlastpair revlastproc)
1172 (setq res (revlastproc res))
1173 )))
1175 (cheader #{
1176 void MELT_MODULE_VISIBILITY
1177 melt_early_gimple_passes_end_hook_callback (void* gcc_data ATTRIBUTE_UNUSED,
1178 void* user_data ATTRIBUTE_UNUSED);
1179 }#)
1181 (cimplement #{
1182 void
1183 melt_early_gimple_passes_end_hook_callback (void* gcc_data ATTRIBUTE_UNUSED,
1184 void* user_data ATTRIBUTE_UNUSED)
1185 {
1186 melthookproc_HOOK_EARLY_GIMPLE_PASSES_END ();
1187 }
1188 }#)
1190 (defun enable_early_gimple_passes_end ()
1191 (code_chunk
1192 enallpassesend_chk
1193 #{ /* enable_early_gimple_passes_end $ENALLPASSESEND_CHK */
1194 if (!melthk_early_gimple_passes_end_registered_flag) {
1195 melthk_early_gimple_passes_end_registered_flag = true;
1196 register_callback (melt_plugin_name, PLUGIN_EARLY_GIMPLE_PASSES_END,
1197 melt_early_gimple_passes_end_hook_callback,
1198 NULL);
1199 }
1200 }#
1201 ))
1203 (defun register_early_gimple_passes_end_first (fun)
1204 :doc #{Use $REGISTER_EARLY_GIMPLE_PASSES_END_FIRST to register a function $FUN to
1205 be run at PLUGIN_EARLY_GIMPLE_PASSES_END, in first place. $FUN must be a closure
1206 which takes no argument and whose result is ignored.}#
1207 (if (is_closure fun)
1208 (let ( (firstlist (get_field :delqu_first early_gimple_passes_end_delayed_queue))
1209 )
1210 (enable_early_gimple_passes_end)
1211 (if (null firstlist)
1212 (progn
1213 (setq firstlist (make_list discr_list))
1214 (put_fields
1215 early_gimple_passes_end_delayed_queue
1216 :delqu_first firstlist
1217 :delqu_last (make_list discr_list))
1218 ))
1219 (list_append firstlist fun)
1220 )
1221 ;; fun not a closure
1222 (errormsg_plain
1223 "Bad function (non closure) passed to register_early_gimple_passes_end_first")
1224 ))
1226 (defun register_early_gimple_passes_end_last (fun)
1227 :doc #{Use $REGISTER_EARLY_GIMPLE_PASSES_END_LAST to register a function $FUN to
1228 be run at PLUGIN_EARLY_GIMPLE_PASSES_END, in last place. $FUN must be a closure
1229 which takes no arguments and whose result is ignored.}#
1230 (if (is_closure fun)
1231 (let ( (lastlist (get_field :delqu_last early_gimple_passes_end_delayed_queue))
1232 )
1233 (enable_early_gimple_passes_end)
1234 (if (null lastlist)
1235 (progn
1236 (setq lastlist (make_list discr_list))
1237 (put_fields
1238 early_gimple_passes_end_delayed_queue
1239 :delqu_first (make_list discr_list)
1240 :delqu_last lastlist)
1241 ))
1242 (list_append lastlist fun)
1243 )
1244 ;; fun not a closure
1245 (errormsg_plain
1246 "Bad function (non closure) passed to register_early_gimple_passes_end_last")
1247 ))
1251 ;;;=====================================================================
1252 ;;;******************* PRE_GENERICIZE plugin event *********************
1253 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1255 ;; private pregenericize queue
1256 (definstance pregenericize_delayed_queue class_delayed_queue
1257 :named_name '"pregenericize_delayed_queue"
1258 :delqu_first ()
1259 :delqu_last ()
1260 )
1263 (cheader #{/* flag for PLUGIN_PRE_GENERICIZE declare */
1264 MELT_EXTERN bool MELT_MODULE_VISIBILITY melthk_pre_genericize_registered_flag;
1265 }#)
1267 (cimplement #{/* flag for PLUGIN_PRE_GENERICIZE define */
1268 bool melthk_pre_genericize_registered_flag;
1269 }#)
1271 (cheader #{
1272 void MELT_MODULE_VISIBILITY
1273 melt_pre_genericize_hook_callback (void* gcc_data ATTRIBUTE_UNUSED,
1274 void* user_data ATTRIBUTE_UNUSED);
1275 }#)
1277 (cimplement #{
1278 void
1279 melt_pre_genericize_hook_callback (void* gcc_data,
1280 void* user_data ATTRIBUTE_UNUSED)
1281 {
1282 melthookproc_HOOK_PRE_GENERICIZE ((tree)gcc_data);
1283 }
1284 }#)
1286 (defun enable_pre_genericize ()
1287 (code_chunk
1288 enablepregen_chk
1289 #{ /* enable_pre_genericize $enablepregen_chk */
1290 if (!melthk_pre_genericize_registered_flag) {
1291 melthk_pre_genericize_registered_flag = true;
1292 register_callback (melt_plugin_name, PLUGIN_PRE_GENERICIZE,
1293 melt_pre_genericize_hook_callback, NULL);
1294 }
1295 }#)
1296 )
1298 (defhook hook_pre_genericize (:tree tfndecl) () :void
1299 :predef HOOK_PRE_GENERICIZE
1300 (let ( (firstlist (get_field :delqu_first pregenericize_delayed_queue))
1301 (lastlist (get_field :delqu_last pregenericize_delayed_queue))
1302 (revlastlist (make_list discr_list))
1303 (res ())
1304 )
1305 (let ( (cfndeclv (constant_box tfndecl))
1306 )
1307 ;;; call the first routines in natural order
1308 (foreach_pair_component_in_list
1309 (firstlist)
1310 (firstpair firstproc)
1311 (setq res (firstproc cfndeclv res))
1312 )
1313 ;;; reverse the last list
1314 (foreach_pair_component_in_list
1315 (lastlist)
1316 (lastpair lastproc)
1317 (if (is_closure lastproc) (list_prepend revlastlist lastproc)))
1318 ;;; call the last routines in reverse order
1319 (foreach_pair_component_in_list
1320 (revlastlist)
1321 (revlastpair revlastproc)
1322 (setq res (revlastproc cfndeclv res))
1323 )
1324 )
1325 )
1326 ) ;end hook_pre_genericize
1329 (defun register_pre_genericize_first (fun)
1330 :doc #{Use $REGISTER_PRE_GENERICIZE_FIRST to register a function $FUN to
1331 be run at PLUGIN_PRE_GENERICIZE hook, in first place. $FUN must be a closure
1332 which take 1 argument (the boxed tree of function declaration being parsed).}#
1333 (let ( (firstlist (get_field :delqu_first pregenericize_delayed_queue))
1334 )
1335 (if (null firstlist)
1336 (progn
1337 (setq firstlist (make_list discr_list))
1338 (put_fields
1339 pregenericize_delayed_queue
1340 :delqu_first firstlist
1341 :delqu_last (make_list discr_list))
1342 ))
1343 (if (is_closure fun)
1344 (progn
1345 (list_append firstlist fun)
1346 (enable_pre_genericize))
1347 (errormsg_plain
1348 "Bad hook passed to register_pre_genericize_hook")
1349 ))
1350 )
1352 (defun register_pre_genericize_last (fun)
1353 :doc #{Use $REGISTER_PRE_GENERICIZE_LAST to register a function $FUN to
1354 be run at PLUGIN_PRE_GENERICIZE hook, in last place. $FUN must be a closure
1355 which take 1 argument (the boxed tree of function declaration being parsed).}#
1356 (let ( (lastlist (get_field :delqu_first pregenericize_delayed_queue))
1357 )
1358 (if (null lastlist)
1359 (progn
1360 (setq lastlist (make_list discr_list))
1361 (put_fields
1362 pregenericize_delayed_queue
1363 :delqu_first lastlist
1364 :delqu_last (make_list discr_list))
1365 ))
1366 (if (is_closure fun)
1367 (progn
1368 (list_append lastlist fun)
1369 (enable_pre_genericize))
1370 (errormsg_plain
1371 "Bad hook passed to register_pre_genericize_hook")
1372 ))
1373 )
1376 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1380 ;;;=====================================================================
1381 ;;;******************* FINISH_TYPE plugin event *********************
1382 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1384 ;; private finishtype queue
1385 (definstance finishtype_delayed_queue class_delayed_queue
1386 :named_name '"finishtype_delayed_queue"
1387 :delqu_first ()
1388 :delqu_last ()
1389 )
1392 (cheader #{/* flag for PLUGIN_FINISH_TYPE declare */
1393 MELT_EXTERN bool MELT_MODULE_VISIBILITY melthk_finish_type_registered_flag;
1394 }#)
1396 (cimplement #{/* flag for PLUGIN_FINISH_TYPE define */
1397 bool melthk_finish_type_registered_flag;
1398 }#)
1400 (cheader #{
1401 void MELT_MODULE_VISIBILITY
1402 melt_finish_type_hook_callback (void* gcc_data ATTRIBUTE_UNUSED,
1403 void* user_data ATTRIBUTE_UNUSED);
1404 }#)
1406 (cimplement #{
1407 void
1408 melt_finish_type_hook_callback (void* gcc_data,
1409 void* user_data ATTRIBUTE_UNUSED)
1410 {
1411 melthookproc_HOOK_FINISH_TYPE ((tree)gcc_data);
1412 }
1413 }#)
1415 (defun enable_finish_type ()
1416 (code_chunk
1417 enablepregen_chk
1418 #{ /* enable_finish_type $enablepregen_chk */
1419 if (!melthk_finish_type_registered_flag) {
1420 melthk_finish_type_registered_flag = true;
1421 register_callback (melt_plugin_name, PLUGIN_FINISH_TYPE,
1422 melt_finish_type_hook_callback, NULL);
1423 }
1424 }#)
1425 )
1427 (defhook hook_finish_type (:tree tfndecl) () :void
1428 :predef HOOK_FINISH_TYPE
1429 (let ( (firstlist (get_field :delqu_first finishtype_delayed_queue))
1430 (lastlist (get_field :delqu_last finishtype_delayed_queue))
1431 (revlastlist (make_list discr_list))
1432 (res ())
1433 )
1434 (let ( (cfndeclv (constant_box tfndecl))
1435 )
1436 ;;; call the first routines in natural order
1437 (foreach_pair_component_in_list
1438 (firstlist)
1439 (firstpair firstproc)
1440 (setq res (firstproc cfndeclv res))
1441 )
1442 ;;; reverse the last list
1443 (foreach_pair_component_in_list
1444 (lastlist)
1445 (lastpair lastproc)
1446 (if (is_closure lastproc) (list_prepend revlastlist lastproc)))
1447 ;;; call the last routines in reverse order
1448 (foreach_pair_component_in_list
1449 (revlastlist)
1450 (revlastpair revlastproc)
1451 (setq res (revlastproc cfndeclv res))
1452 )
1453 )
1454 )
1455 ) ;end hook_finish_type
1458 (defun register_finish_type_first (fun)
1459 :doc #{Use $REGISTER_FINISH_TYPE_FIRST to register a function $FUN to
1460 be run at PLUGIN_FINISH_TYPE hook, in first place. $FUN must be a closure
1461 which take 1 argument (the boxed tree of function declaration being parsed).}#
1462 (let ( (firstlist (get_field :delqu_first finishtype_delayed_queue))
1463 )
1464 (if (null firstlist)
1465 (progn
1466 (setq firstlist (make_list discr_list))
1467 (put_fields
1468 finishtype_delayed_queue
1469 :delqu_first firstlist
1470 :delqu_last (make_list discr_list))
1471 ))
1472 (if (is_closure fun)
1473 (progn
1474 (list_append firstlist fun)
1475 (enable_finish_type))
1476 (errormsg_plain
1477 "Bad hook passed to register_finish_type_first")
1478 ))
1479 )
1481 (defun register_finish_type_last (fun)
1482 :doc #{Use $REGISTER_FINISH_TYPE_LAST to register a function $FUN to
1483 be run at PLUGIN_FINISH_TYPE hook, in last place. $FUN must be a closure
1484 which take 1 argument (the boxed tree of function declaration being parsed).}#
1485 (let ( (lastlist (get_field :delqu_first finishtype_delayed_queue))
1486 )
1487 (if (null lastlist)
1488 (progn
1489 (setq lastlist (make_list discr_list))
1490 (put_fields
1491 finishtype_delayed_queue
1492 :delqu_first lastlist
1493 :delqu_last (make_list discr_list))
1494 ))
1495 (if (is_closure fun)
1496 (progn
1497 (list_append lastlist fun)
1498 (enable_finish_type))
1499 (errormsg_plain
1500 "Bad hook passed to register_finish_type_last")
1501 ))
1502 )
1505 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1507 ;;; private endmeltpass queue
1509 (definstance endmeltpass_delayed_queue class_delayed_queue
1510 :named_name '"endmeltpass_delayed_queue"
1511 :delqu_first ()
1512 :delqu_last ()
1513 )
1515 (defun run_endmeltpass_functions ()
1516 (let ( (firstlist (get_field :delqu_first endmeltpass_delayed_queue))
1517 (lastlist (get_field :delqu_last endmeltpass_delayed_queue))
1518 (revlastlist (make_list discr_list))
1519 (res (instance class_container))
1520 )
1521 (put_fields endmeltpass_delayed_queue
1522 :delqu_first ()
1523 :delqu_last ())
1524 ;;; call the first routines in natural order
1525 (foreach_pair_component_in_list
1526 (firstlist)
1527 (firstpair firstproc)
1528 (if (is_closure firstproc)
1529 (firstproc res))
1530 )
1531 ;;; reverse the last list
1532 (foreach_pair_component_in_list
1533 (lastlist)
1534 (lastpair lastproc)
1535 (if (is_closure lastproc) (list_prepend revlastlist lastproc)))
1536 ;;; call the last routines in reverse order
1537 (foreach_pair_component_in_list
1538 (revlastlist)
1539 (revlastpair revlastproc)
1540 (revlastproc res)
1541 )
1542 )
1543 )
1545 (defun at_end_of_this_melt_pass_first (fun)
1546 :doc #{Use $AT_END_OF_THIS_MELT_PASS_FIRST to register a function to be called at the end of the current MELT provided GCC pass, in first place.}#
1547 (let ( (firstlist (unsafe_get_field :delqu_first endmeltpass_delayed_queue))
1548 )
1549 (when (null firstlist)
1550 (setq firstlist (make_list discr_list))
1551 (put_fields endmeltpass_delayed_queue :delqu_first firstlist))
1552 (if (is_closure fun)
1553 (list_append firstlist fun))))
1556 (defun at_end_of_this_melt_pass_last (fun)
1557 :doc #{Use $AT_END_OF_THIS_MELT_PASS_LAST to register a function to be called
1558 at the end of the current MELT provided GCC pass, in last place.}#
1559 (let ( (lastlist (unsafe_get_field :delqu_last endmeltpass_delayed_queue))
1560 )
1561 (when (null lastlist)
1562 (setq lastlist (make_list discr_list))
1563 (put_fields endmeltpass_delayed_queue :delqu_last lastlist))
1564 (if (is_closure fun)
1565 (list_append lastlist fun))))
1569 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1572 ;;;=====================================================================
1573 ;;;******************* FINISH_DECL plugin event *********************
1574 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1576 ;; private finishdecl queue
1577 (definstance finishdecl_delayed_queue class_delayed_queue
1578 :named_name '"finishdecl_delayed_queue"
1579 :delqu_first ()
1580 :delqu_last ()
1581 )
1584 (cheader #{/* flag for PLUGIN_FINISH_DECL declare */
1585 MELT_EXTERN bool MELT_MODULE_VISIBILITY melthk_finish_decl_registered_flag;
1586 }#)
1588 (cimplement #{/* flag for PLUGIN_FINISH_DECL define */
1589 bool melthk_finish_decl_registered_flag;
1590 }#)
1592 (cheader #{
1593 void MELT_MODULE_VISIBILITY
1594 melt_finish_decl_hook_callback (void* gcc_data ATTRIBUTE_UNUSED,
1595 void* user_data ATTRIBUTE_UNUSED);
1596 }#)
1598 (cimplement #{
1599 void
1600 melt_finish_decl_hook_callback (void* gcc_data,
1601 void* user_data ATTRIBUTE_UNUSED)
1602 {
1603 melthookproc_HOOK_FINISH_DECL ((tree)gcc_data);
1604 }
1605 }#)
1607 (defun enable_finish_decl ()
1608 (code_chunk
1609 enablepregen_chk
1610 #{ /* enable_finish_decl $enablepregen_chk */
1611 if (!melthk_finish_decl_registered_flag) {
1612 melthk_finish_decl_registered_flag = true;
1613 register_callback (melt_plugin_name, PLUGIN_FINISH_DECL,
1614 melt_finish_decl_hook_callback, NULL);
1615 }
1616 }#)
1617 )
1619 (defhook hook_finish_decl (:tree tfndecl) () :void
1620 :predef HOOK_FINISH_DECL
1621 (let ( (firstlist (get_field :delqu_first finishdecl_delayed_queue))
1622 (lastlist (get_field :delqu_last finishdecl_delayed_queue))
1623 (revlastlist (make_list discr_list))
1624 (res ())
1625 )
1626 (let ( (cfndeclv (constant_box tfndecl))
1627 )
1628 ;;; call the first routines in natural order
1629 (foreach_pair_component_in_list
1630 (firstlist)
1631 (firstpair firstproc)
1632 (setq res (firstproc cfndeclv res))
1633 )
1634 ;;; reverse the last list
1635 (foreach_pair_component_in_list
1636 (lastlist)
1637 (lastpair lastproc)
1638 (if (is_closure lastproc) (list_prepend revlastlist lastproc)))
1639 ;;; call the last routines in reverse order
1640 (foreach_pair_component_in_list
1641 (revlastlist)
1642 (revlastpair revlastproc)
1643 (setq res (revlastproc cfndeclv res))
1644 )
1645 )
1646 )
1647 ) ;end hook_finish_decl
1650 (defun register_finish_decl_first (fun)
1651 :doc #{Use $REGISTER_FINISH_DECL_FIRST to register a function $FUN to
1652 be run at PLUGIN_FINISH_DECL hook, in first place. $FUN must be a closure
1653 which take 1 argument (the boxed tree of function declaration being parsed).}#
1654 (let ( (firstlist (get_field :delqu_first finishdecl_delayed_queue))
1655 )
1656 (if (null firstlist)
1657 (progn
1658 (setq firstlist (make_list discr_list))
1659 (put_fields
1660 finishdecl_delayed_queue
1661 :delqu_first firstlist
1662 :delqu_last (make_list discr_list))
1663 ))
1664 (if (is_closure fun)
1665 (progn
1666 (list_append firstlist fun)
1667 (enable_finish_decl))
1668 (errormsg_plain
1669 "Bad hook passed to register_finish_decl_first")
1670 ))
1671 )
1673 (defun register_finish_decl_last (fun)
1674 :doc #{Use $REGISTER_FINISH_DECL_LAST to register a function $FUN to
1675 be run at PLUGIN_FINISH_DECL hook, in last place. $FUN must be a closure
1676 which take 1 argument (the boxed tree of function declaration being parsed).}#
1677 (let ( (lastlist (get_field :delqu_first finishdecl_delayed_queue))
1678 )
1679 (if (null lastlist)
1680 (progn
1681 (setq lastlist (make_list discr_list))
1682 (put_fields
1683 finishdecl_delayed_queue
1684 :delqu_first lastlist
1685 :delqu_last (make_list discr_list))
1686 ))
1687 (if (is_closure fun)
1688 (progn
1689 (list_append lastlist fun)
1690 (enable_finish_decl))
1691 (errormsg_plain
1692 "Bad hook passed to register_finish_decl_last")
1693 ))
1694 )
1697 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1701 ;;;=====================================================================
1702 ;;;******************* PASS_EXECUTION plugin event *********************
1703 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1705 ;; private pass_execution queue
1706 (definstance pass_execution_delayed_queue class_delayed_queue
1707 :named_name '"pass_execution_delayed_queue"
1708 :delqu_first ()
1709 :delqu_last ()
1710 )
1712 (cheader #{/* flag for PLUGIN_PASS_EXECUTION declare */
1713 MELT_EXTERN bool MELT_MODULE_VISIBILITY melthk_pass_execution_registered_flag;
1714 }#)
1715 (cimplement #{/* flag for PLUGIN_PASS_EXECUTION define */
1716 bool melthk_pass_execution_registered_flag;
1717 }#)
1719 (cheader #{
1720 void MELT_MODULE_VISIBILITY
1721 melt_pass_execution_hook_callback (void* gcc_data ATTRIBUTE_UNUSED,
1722 void* user_data ATTRIBUTE_UNUSED);
1723 }#)
1725 (cimplement #{
1726 void
1727 melt_pass_execution_hook_callback (void* gcc_data ATTRIBUTE_UNUSED,
1728 void* user_data ATTRIBUTE_UNUSED)
1729 {
1730 struct opt_pass* pass = (struct opt_pass*) gcc_data;
1731 melthookproc_HOOK_PASS_EXECUTION (pass->name, (long) pass->static_pass_number, (long) pass->type);
1732 }
1733 }#)
1736 ;; we always register the pass_execution hook, because we want the GC
1737 ;; to run there
1738 (code_chunk
1739 register_pass_execution_hook_chk
1740 #{ /* we always $register_pass_execution_hook_chk */
1741 register_callback (melt_plugin_name, PLUGIN_PASS_EXECUTION,
1742 melt_pass_execution_hook_callback, NULL);
1743 }#)
1745 (defhook hook_pass_execution (:cstring passname :long passnum typenum) () :void
1746 :predef HOOK_PASS_EXECUTION
1747 (let (
1748 (passnameval (expr_chunk
1749 makepassname_chk
1750 :value
1751 #{/*hook_pass_execution $MAKEPASSNAME_CHK*/
1752 meltgc_new_stringdup
1753 ((meltobject_ptr_t) MELT_PREDEF(DISCR_STRING),
1754 $PASSNAME)
1755 }#))
1756 (ptype ())
1757 (firstlist (get_field :delqu_first pass_execution_delayed_queue))
1758 (lastlist (get_field :delqu_last pass_execution_delayed_queue))
1759 (revlastlist (make_list discr_list))
1760 )
1761 (code_chunk
1762 fillptype_chk #{ /* hook_pass_execution $FILLPTYPE_CHK */
1763 switch ($TYPENUM) {
1764 case (int) GIMPLE_PASS:
1765 $(progn (setq ptype :gimple_pass) (void));
1766 break;
1767 case (int) RTL_PASS:
1768 $(progn (setq ptype :rtl_pass) (void));
1769 break;
1770 case (int) SIMPLE_IPA_PASS:
1771 $(progn (setq ptype :simple_ipa_pass) (void));
1772 break;
1773 case (int) IPA_PASS:
1774 $(progn (setq ptype :ipa_pass) (void));
1775 break;
1776 default:
1777 $(progn (setq ptype (constant_box typenum)) (void));
1778 break;
1779 } /* end switch typenum in $FILLPTYPE_CHK*/
1780 }#)
1781 ;;; call the first routines in natural order
1782 (foreach_pair_component_in_list
1783 (firstlist)
1784 (firstpair firstproc)
1785 (firstproc passnameval passnum ptype)
1786 )
1787 ;;; reverse the last list
1788 (foreach_pair_component_in_list
1789 (lastlist)
1790 (lastpair lastproc)
1791 (if (is_closure lastproc) (list_prepend revlastlist lastproc)))
1792 ;;; call the last routines in reverse order
1793 (foreach_pair_component_in_list
1794 (revlastlist)
1795 (revlastpair revlastproc)
1796 (revlastproc passnameval passnum ptype)
1797 )
1798 )
1799 ;; always force a minor garbage collection, otherwise other GCC
1800 ;; passes could break havoc
1801 (minor_garbcoll 1024)
1802 ) ;end hook_pass_execution
1805 (defun register_pass_execution_first (fun)
1806 :doc #{Use $REGISTER_PASS_EXECUTION_FIRST to register a function $FUN to
1807 be run at PLUGIN_PASS_EXECUTION hook, in first place. $FUN must be a closure
1808 which take as arguments @var{boxed-pass-name} @var{raw-pass-number} @var{pass-type-keyword}.}#
1809 (let ( (firstlist (get_field :delqu_first pass_execution_delayed_queue))
1810 )
1811 (if (null firstlist)
1812 (progn
1813 (setq firstlist (make_list discr_list))
1814 (put_fields
1815 pass_execution_delayed_queue
1816 :delqu_first firstlist
1817 :delqu_last (make_list discr_list))
1818 ))
1819 (if (is_closure fun)
1820 (list_append firstlist fun)
1821 (errormsg_plain
1822 "Bad hook passed to register_pass_execution_hook")
1823 ))
1824 )
1826 (defun register_pass_execution_last (fun)
1827 :doc #{Use $REGISTER_PASS_EXECUTION_LAST to register a function $FUN to
1828 be run at PLUGIN_PASS_EXECUTION hook, in last place. $FUN must be a closure
1829 which take as arguments @var{boxed-pass-name} @var{raw-pass-number} @var{pass-type-keyword}.}#
1830 (let ( (lastlist (get_field :delqu_first pass_execution_delayed_queue))
1831 )
1832 (if (null lastlist)
1833 (progn
1834 (setq lastlist (make_list discr_list))
1835 (put_fields
1836 pass_execution_delayed_queue
1837 :delqu_first lastlist
1838 :delqu_last (make_list discr_list))
1839 ))
1840 (if (is_closure fun)
1841 (list_append lastlist fun)
1842 (errormsg_plain
1843 "Bad hook passed to register_pass_execution_last_hook")
1844 ))
1845 )
1847 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1848 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1849 ;;; gate hook for gimple passes
1850 (defhook hook_gimple_gate
1851 () () :long
1852 :predef HOOK_GIMPLE_GATE
1853 (let ( (:long hasmodeflag 0)
1854 (:long okres 0)
1855 (passdict (unsafe_get_field :sysdata_pass_dict initial_system_data))
1856 (mypass ())
1857 (:long passnum 0)
1858 )
1859 (code_chunk gethasmode_chk
1860 #{ /* hook_gimple_gate $GETHASMODE_CHK */
1861 static const char* $GETHASMODE_CHK#modstr ;
1862 if (!$GETHASMODE_CHK#modstr)
1863 $GETHASMODE_CHK#modstr = melt_argument("mode") ;
1864 $HASMODEFLAG = $GETHASMODE_CHK#modstr != NULL && $GETHASMODE_CHK#modstr[0] != (char)0 ;
1865 }#)
1866 (if (not hasmodeflag)
1867 (return 0))
1868 (debug "hook_gimple_gate passdict=" passdict "\n initial_system_data=" initial_system_data)
1869 (code_chunk
1870 thispass_chk
1871 #{ /* hook_gimple_gate $THISPASS_CHK */
1872 opt_pass* this_pass = NULL ;
1873 this_pass = melt_current_pass_ptr ;
1874 if (!this_pass) this_pass = current_pass ;
1875 //
1876 $(code_chunk
1877 getmypass_chk
1878 #{ /* hook_gimple_gate $GETMYPASS_CHK */
1879 gcc_assert(this_pass != NULL) ;
1880 gcc_assert(this_pass->name != NULL) ;
1881 debugeprintf ("hook_gimple_gate this_pass %p named %s",
1882 (void*) this_pass->name, this_pass->name) ;
1883 gcc_assert(this_pass->type == GIMPLE_PASS) ;
1884 $MYPASS = melt_get_mapstrings ((struct meltmapstrings_st*) $PASSDICT,
1885 this_pass->name) ;
1886 $PASSNUM = this_pass->static_pass_number ;
1887 }#)
1888 $(debug "hook_gimple_gate mypass=" mypass "\n.. passnum=" passnum)
1889 $(debug "hook_gimple_gate class_gcc_gimple_pass=" class_gcc_gimple_pass)
1890 $(if (is_a mypass class_gcc_gimple_pass)
1891 (let ( (gatefun (get_field :gccpass_gate mypass))
1892 (:cstring curpassname (the_null_cstring))
1893 )
1894 (debug "hook_gimple_gate gatefun=" gatefun)
1895 (if (is_closure gatefun)
1896 (code_chunk
1897 dogatefun_chk
1898 #{ /* hook_gimple_gate $DOGATEFUN_CHK */
1899 FILE* oldf = meltgc_set_dump_file (dump_file) ;
1900 $CURPASSNAME = this_pass->name ;
1901 $(progn
1902 (debug "hook_gimple_gate curpassname=" curpassname " mypass=" mypass)
1903 (if (gatefun mypass)
1904 (setq okres 1))
1905 (debug "hook_gimple_gate after call okres=" okres)
1906 (void)
1907 )
1908 meltgc_restore_dump_file (oldf) ;
1909 oldf = NULL ;
1910 }#)
1911 (setq okres 1) ;no closure
1912 )
1913 (void)
1914 )
1915 (debug "hook_gimple_gate strange mypass=" mypass "\n.. of discrim=" (discrim mypass))
1916 )
1917 /* end hook_gimple_gate $THISPASS_CHK */ }#
1918 )
1919 (debug "hook_gimple_gate final okres=" okres)
1920 (return okres)
1921 )
1922 )
1924 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1925 ;;; execute hook for gimple passes
1926 (defhook hook_gimple_execute
1927 () () :long
1928 :predef HOOK_GIMPLE_EXECUTE
1929 (let ( (:long hasmodeflag 0)
1930 (:long okres 0)
1931 (:long passnum 0)
1932 (passdict (get_field :sysdata_pass_dict initial_system_data))
1933 (mypass ())
1934 )
1935 (debug "hook_gimple_execute start")
1936 (code_chunk gethasmode_chk
1937 #{ /* hook_gimple_execute $GETHASMODE_CHK */
1938 static const char* $GETHASMODE_CHK#modstr ;
1939 if (!$GETHASMODE_CHK#modstr)
1940 $GETHASMODE_CHK#modstr = melt_argument("mode") ;
1941 $HASMODEFLAG = $GETHASMODE_CHK#modstr != NULL && $GETHASMODE_CHK#modstr[0] ;
1942 }#)
1943 (when (not hasmodeflag)
1944 (debug "hook_gimple_execute no mode")
1945 (return 0))
1946 (code_chunk
1947 getmypass_chk
1948 #{ /* hook_gimple_execute $GETMYPASS_CHK */
1949 gcc_assert(current_pass != NULL) ;
1950 gcc_assert(current_pass->name != NULL) ;
1951 gcc_assert(current_pass->type == GIMPLE_PASS) ;
1952 $MYPASS = melt_get_mapstrings ((struct meltmapstrings_st*) $PASSDICT,
1953 current_pass->name) ;
1954 $PASSNUM = current_pass->static_pass_number ;
1955 }#)
1956 (debug "hook_gimple_execute mypass=" mypass "\n.. passnum=" passnum)
1957 (if (is_a mypass class_gcc_gimple_pass)
1958 (let ( (execfun (get_field :gccpass_exec mypass))
1959 (:cstring curpassname (the_null_cstring))
1960 )
1961 (when (is_closure execfun)
1962 (code_chunk
1963 doexecfun_chk
1964 #{ /* hook_gimple_execute $DOEXECFUN_CHK */
1965 FILE* oldf = meltgc_set_dump_file (dump_file) ;
1966 $CURPASSNAME = current_pass->name ;
1967 $(progn
1968 (debug "hook_gimple_execute curpassname=" curpassname " mypass=" mypass
1969 " passnum=" passnum)
1970 (multicall
1971 (resexec :long flagexec)
1972 (execfun mypass passnum)
1973 (debug "hook_gimple_execute after call resexec=" resexec
1974 " flagexec=" flagexec)
1975 (if (null resexec)
1976 (setq okres flagexec)
1977 (setq okres 1))
1978 )
1979 (void)
1980 )
1981 meltgc_restore_dump_file (oldf) ;
1982 oldf = NULL ;
1983 }#)
1984 (run_endmeltpass_functions)
1985 )))
1986 (return okres)
1987 ))
1989 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1990 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1992 ;;; gate hook for rtl passes
1993 (defhook hook_rtl_gate
1994 () () :long
1995 :predef HOOK_RTL_GATE
1996 (let ( (:long hasmodeflag 0)
1997 (:long okres 0)
1998 (passdict (get_field :sysdata_pass_dict initial_system_data))
1999 (mypass ())
2000 (:long passnum 0)
2001 )
2002 (code_chunk gethasmode_chk
2003 #{ /* hook_rtl_gate $GETHASMODE_CHK */
2004 static const char* $GETHASMODE_CHK#modstr ;
2005 if (!$GETHASMODE_CHK#modstr)
2006 $GETHASMODE_CHK#modstr = melt_argument("mode") ;
2007 $HASMODEFLAG = $GETHASMODE_CHK#modstr != NULL && $GETHASMODE_CHK#modstr[0] ;
2008 }#)
2009 (if (not hasmodeflag)
2010 (return 0))
2011 (code_chunk
2012 getmypass_chk
2013 #{ /* hook_rtl_gate $GETMYPASS_CHK */
2014 gcc_assert(current_pass != NULL) ;
2015 gcc_assert(current_pass->name != NULL) ;
2016 gcc_assert(current_pass->type == RTL_PASS) ;
2017 $MYPASS = melt_get_mapstrings ((struct meltmapstrings_st*) $PASSDICT,
2018 current_pass->name) ;
2019 }#)
2020 (if (is_a mypass class_gcc_rtl_pass)
2021 (let ( (gatefun (get_field :gccpass_gate mypass))
2022 (:cstring curpassname (the_null_cstring))
2023 )
2024 (if (is_closure gatefun)
2025 (code_chunk
2026 dogatefun_chk
2027 #{ /* hook_rtl_gate $DOGATEFUN_CHK */
2028 FILE* oldf = meltgc_set_dump_file (dump_file) ;
2029 $CURPASSNAME = current_pass->name;
2030 $PASSNUM = current_pass->static_pass_number;
2031 $(progn
2032 (debug "hook_rtl_gate curpassname=" curpassname " mypass=" mypass)
2033 (if (gatefun mypass passnum)
2034 (setq okres 1))
2035 (debug "hook_rtl_gate after call okres=" okres)
2036 (void)
2037 )
2038 meltgc_restore_dump_file (oldf) ;
2039 oldf = NULL ;
2040 }#)
2041 (setq okres 1) ;no closure
2042 )))
2043 (return okres)
2044 ))
2046 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2047 ;;; execute hook for rtl passes
2048 (defhook hook_rtl_execute
2049 () () :long
2050 :predef HOOK_RTL_EXECUTE
2051 (let ( (:long hasmodeflag 0)
2052 (:long okres 0)
2053 (passdict (get_field :sysdata_pass_dict initial_system_data))
2054 (mypass ())
2055 (:long passnum 0)
2056 )
2057 (code_chunk gethasmode_chk
2058 #{ /* hook_rtl_execute $GETHASMODE_CHK */
2059 static const char* $GETHASMODE_CHK#modstr ;
2060 if (!$GETHASMODE_CHK#modstr)
2061 $GETHASMODE_CHK#modstr = melt_argument("mode") ;
2062 $HASMODEFLAG = $GETHASMODE_CHK#modstr != NULL && $GETHASMODE_CHK#modstr[0] ;
2063 }#)
2064 (if (not hasmodeflag)
2065 (return 0))
2066 (code_chunk
2067 getmypass_chk
2068 #{ /* hook_rtl_execute $GETMYPASS_CHK */
2069 gcc_assert(current_pass != NULL) ;
2070 gcc_assert(current_pass->name != NULL) ;
2071 gcc_assert(current_pass->type == RTL_PASS) ;
2072 $MYPASS = melt_get_mapstrings ((struct meltmapstrings_st*) $PASSDICT,
2073 current_pass->name) ;
2074 }#)
2075 (if (is_a mypass class_gcc_rtl_pass)
2076 (let ( (execfun (get_field :gccpass_exec mypass))
2077 (:cstring curpassname (the_null_cstring))
2078 )
2079 (when (is_closure execfun)
2080 (code_chunk
2081 doexecfun_chk
2082 #{ /* hook_rtl_execute $DOEXECFUN_CHK */
2083 $PASSNUM = current_pass->static_pass_number;
2084 FILE* oldf = meltgc_set_dump_file (dump_file) ;
2085 $CURPASSNAME = current_pass->name ;
2086 $(progn
2087 (debug "hook_rtl_execute curpassname=" curpassname " mypass=" mypass
2088 " passnum=" passnum)
2089 (multicall
2090 (resexec :long flagexec)
2091 (execfun mypass passnum)
2092 (debug "hook_rtl_execute after call resexec=" resexec
2093 " flagexec=" flagexec)
2094 (if (null resexec)
2095 (setq okres flagexec)
2096 (setq okres 1))
2097 )
2098 (void)
2099 )
2100 meltgc_restore_dump_file (oldf) ;
2101 oldf = NULL ;
2102 }#)
2103 (run_endmeltpass_functions)
2104 )))
2105 (return okres)
2106 ))
2107 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2108 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2110 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2111 ;;; execute hook for simple_ipa passes
2112 (defhook hook_simple_ipa_execute
2113 () () :long
2114 :predef HOOK_SIMPLE_IPA_EXECUTE
2115 (let ( (:long hasmodeflag 0)
2116 (:long okres 0)
2117 (passdict (get_field :sysdata_pass_dict initial_system_data))
2118 (mypass ())
2119 (:long passnum 0)
2120 )
2121 (code_chunk gethasmode_chk
2122 #{ /* hook_simple_ipa_execute $GETHASMODE_CHK */
2123 static const char* $GETHASMODE_CHK#modstr ;
2124 if (!$GETHASMODE_CHK#modstr)
2125 $GETHASMODE_CHK#modstr = melt_argument("mode") ;
2126 $HASMODEFLAG = $GETHASMODE_CHK#modstr != NULL && $GETHASMODE_CHK#modstr[0] ;
2127 }#)
2128 (if (not hasmodeflag)
2129 (return 0))
2130 (code_chunk
2131 getmypass_chk
2132 #{ /* hook_simple_ipa_execute $GETMYPASS_CHK */
2133 gcc_assert(current_pass != NULL) ;
2134 gcc_assert(current_pass->name != NULL) ;
2135 gcc_assert(current_pass->type == SIMPLE_IPA_PASS) ;
2136 $MYPASS = melt_get_mapstrings ((struct meltmapstrings_st*) $PASSDICT,
2137 current_pass->name) ;
2138 }#)
2139 (if (is_a mypass class_gcc_simple_ipa_pass)
2140 (let ( (execfun (get_field :gccpass_exec mypass))
2141 (:cstring curpassname (the_null_cstring))
2142 )
2143 (when (is_closure execfun)
2144 (code_chunk
2145 doexecfun_chk
2146 #{ /* hook_simple_ipa_execute $DOEXECFUN_CHK */
2147 $PASSNUM = current_pass->static_pass_number;
2148 FILE* oldf = meltgc_set_dump_file (dump_file) ;
2149 $CURPASSNAME = current_pass->name ;
2150 $(progn
2151 (debug "hook_simple_ipa_execute curpassname=" curpassname " mypass=" mypass
2152 " passnum=" passnum)
2153 (multicall
2154 (resexec :long flagexec)
2155 (execfun mypass passnum)
2156 (debug "hook_simple_ipa_execute after call resexec=" resexec
2157 " flagexec=" flagexec)
2158 (if (null resexec)
2159 (setq okres flagexec)
2160 (setq okres 1))
2161 )
2162 (void)
2163 )
2164 meltgc_restore_dump_file (oldf) ;
2165 oldf = NULL ;
2166 }#)
2167 (run_endmeltpass_functions)
2168 )))
2169 (return okres)
2170 ))
2174 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2175 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2176 (defhook hook_melt_do_initial_mode
2177 (:value modata :cstring modstr)
2178 ()
2179 :void
2180 :predef HOOK_MELT_DO_INITIAL_MODE
2181 (let ( (modict (get_field :sysdata_mode_dict initial_system_data))
2182 (modlist (expr_chunk modlist_chk :value
2183 #{ /*hook_melt_do_initial_mode $MODLIST_CHK*/
2184 (meltgc_new_split_string ($MODSTR, ',',
2185 (melt_ptr_t) $DISCR_STRING)) }#))
2187 )
2188 (assert_msg "check modict" (is_mapstring modict) modict initial_system_data)
2189 (assert_msg "check modlist" (is_list modlist) modlist)
2190 (foreach_pair_component_in_list
2191 (modlist)
2192 (curpair curmodstr)
2193 (debug "hook_melt_do_initial_mode curmodstr=" curmodstr)
2194 (let ( (curmod (mapstring_getstr modict curmodstr))
2195 )
2196 (debug "hook_melt_do_initial_mode curmod=" curmod)
2197 (if (null curmod)
2198 (error_at () "unknown MELT mode $1" curmodstr))
2199 (when curmod
2200 (assert_msg "check curmod" (is_a curmod class_melt_mode) curmod class_melt_mode)
2201 (let ( (curmodfun (get_field :meltmode_fun curmod))
2202 (curmodname (get_field :named_name curmod))
2203 )
2204 (assert_msg "check curmodfun" (is_closure curmodfun) curmodfun curmod)
2205 (assert_msg "check curmodname" (is_string curmodname) curmodname curmod)
2206 (let ( (curmodres (curmodfun curmod modata))
2207 )
2208 (debug "hook_melt_do_initial_mode curmodres=" curmodres " for curmod=" curmod)
2209 (cond
2210 (curmodres
2211 (code_chunk
2212 donewellmode_chk
2213 #{ /* hook_melt_do_initial_mode $DONEWELLMODE_CHK */
2214 std::string curmodstr(melt_string_str($CURMODNAME)) ;
2215 melt_done_modes_vector.push_back(curmodstr) ;
2216 }#)
2217 )
2218 (:else
2219 (code_chunk
2220 failedmode_chk
2221 #{ /* hook_melt_do_initial_mode $FAILEDMODE_CHK */
2222 warning(0, "MELT mode %s failed, so compilation disabled",
2223 melt_string_str($CURMODNAME)) ;
2224 exit_after_options = TRUE ;
2225 }#)
2226 )))))
2227 ))))
2229 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2234 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2236 ;;;;; extended attribute support is in warmelt-hooks.melt since it
2237 ;;;;; uses tree but does not depend on tree operations, but needs the
2238 ;;;;; hook_handle_attribute predefined hook
2240 (cheader #{ /* cheader for attributes in warmelt-hooks.melt */
2241 #if MELT_GCC_VERSION >= 4009 /* GCC 4.9 or later */
2242 #include "attribs.h"
2243 #endif /*GCC 4.9*/
2244 MELT_EXTERN tree MELT_MODULE_VISIBILITY melt_attribute_handler_glue
2245 (tree *pnode, tree name, tree args, int flags, bool *no_add_attrs);
2246 }#)
2248 (cimplement #{ /* cimplement for attributes in warmelt-hooks.melt */
2249 tree
2250 melt_attribute_handler_glue (tree *pnode, tree name, tree args, int flags, bool *pno_add_attrs) {
2251 tree res= NULL_TREE;
2252 tree orignode = *pnode;
2253 tree outnode= NULL_TREE;
2254 long out_no_add_attrs= (*pno_add_attrs);
2255 debugeprintf("melt_attribute_handler_glue pnode@%p orignode=%p outnode=%p name=%p args@%p flags=%d pno_add_attrs@%p: %ld"
2256 " before HOOK_HANDLE_ATTRIBUTE",
2257 (void*)pnode, (void*)orignode, (void*)outnode,
2258 (void*)name, (void*)args, flags,
2259 (void*)pno_add_attrs, out_no_add_attrs);
2260 res =
2261 melthookproc_HOOK_HANDLE_ATTRIBUTE (orignode, name, args, flags,
2262 &outnode,
2263 &out_no_add_attrs);
2264 debugeprintf("melt_attribute_handler_glue orignode=%p outnode=%p res=%p out_no_add_attrs=%ld after HOOK_HANDLE_ATTRIBUTE",
2265 (void*)orignode, (void*)outnode, (void*)res, out_no_add_attrs);
2266 if (outnode)
2267 *pnode = outnode;
2268 *pno_add_attrs = (bool)out_no_add_attrs;
2269 debugeprintf("melt_attribute_handler_glue *pno_add_attrs=%d *pnode=%p",
2270 (int)(*pno_add_attrs), (void*)(*pnode));
2271 melt_cbreak("ending melt_attribute_handler_glue");
2272 return res;
2273 } /* end melt_attribute_handler_glue */
2274 }#)
2277 (defvar gcc_attribute_dict)
2278 (defvar gcc_attribute_installer_list)
2279 (setq gcc_attribute_installer_list (make_list discr_list))
2281 (defclass class_gcc_attribute
2282 :super class_named
2283 :doc #{The $CLASS_GCC_ATTRIBUTE describes general GCC attributes
2284 known by MELT. Its $GCCATTR_DATA field can contain arbitrary data.
2285 Its $GCCATTR_HANDER should be a closure (see @var{handler} field in
2286 @code{attribute_spec} field of @file{gcc/tree-core.h} of GCC). The
2287 closure is given the attribute, a list of flag keywords such as
2288 @code{:attr_flag_decl_next}, @code{:attr_flag_function_next},
2289 @code{:attr_flag_array_next}, @code{:attr_flag_type_in_place},
2290 @code{:attr_flag_built_in}, @code{:attr_flag_cxx11},
2291 the tree @var{node}, the tree @var{name}, and the
2292 tree @var{args} as arguments, and should give a
2293 primary boolean result value (non-nil to clear @var{no_add_attrs}) and
2294 secondarily the tree @var{result} and the output tree @var{node}.}#
2295 :fields (gccattr_data
2296 gccattr_handler
2297 ))
2298 (export_class class_gcc_attribute)
2300 (defhook hook_install_attributes
2301 ()
2302 ()
2303 :void
2304 :predef HOOK_INSTALL_ATTRIBUTES
2305 (debug "hook_install_attributes" " start gcc_attribute_dict="
2306 gcc_attribute_dict)
2307 (if (null gcc_attribute_dict)
2308 (return))
2309 (forever
2310 atloop
2311 (unless (is_non_empty_list gcc_attribute_installer_list)
2312 (exit atloop))
2313 (let ( (clo1 (list_pop_first gcc_attribute_installer_list))
2314 )
2315 (debug "hook_install_attributes" " loop clo1=" clo1)
2316 (assert_msg "check clo1" (is_closure clo1) clo1)
2317 (clo1)
2318 )
2319 )
2320 (debug "hook_install_attributes" " final gcc_attribute_installer_list=" gcc_attribute_installer_list)
2321 )
2323 (defhook hook_handle_attribute
2324 (:tree tr_in_node tr_name tr_args :long flags)
2325 (:tree tr_out_node :long out_no_add_attrs)
2326 :tree
2327 :predef HOOK_HANDLE_ATTRIBUTE
2328 (debug "hook_handle_attribute" " tr_in_node=" tr_in_node
2329 "; tr_name=" tr_name "; tr_args=" tr_args
2330 "; flags=" flags )
2331 (let (
2332 (attrv ())
2333 )
2334 (code_chunk getname_chk #{ /* hook_handle_attribute $GETNAME_CHK start */
2335 melt_assertmsg ("check good name",
2336 $TR_NAME
2337 && TREE_CODE($TR_NAME) == IDENTIFIER_NODE) ;
2338 $ATTRV = melt_get_mapstrings
2339 ((meltmapstrings_st*) $GCC_ATTRIBUTE_DICT,
2340 IDENTIFIER_POINTER($TR_NAME)) ;
2341 /* hook_handle_attribute $GETNAME_CHK end */
2342 }#)
2343 (debug "hook_handle_attribute " "attrv=" attrv)
2344 (assert_msg "check attrv" (is_a attrv class_gcc_attribute))
2345 (let ( (handler (get_field :gccattr_handler attrv))
2346 (flaglist (make_list discr_list))
2347 )
2348 (debug "hook_handle_attribute" " got handler=" handler
2349 "\n.. in attrv=" attrv)
2350 (when (not (is_closure handler))
2351 (debug "hook_handle_attribute" " bad handler in attrv=" attrv)
2352 (error_at () "non closure handler in attribute $1" attrv)
2353 (return))
2354 (code_chunk makeflaglist_chk
2355 #{ /* hook_handle_attribute $MAKEFLAGLIST_CHK start */
2356 if ($FLAGS & ATTR_FLAG_DECL_NEXT)
2357 $(list_append flaglist :attr_flag_decl_next) ;
2358 if ($FLAGS & ATTR_FLAG_FUNCTION_NEXT)
2359 $(list_append flaglist :attr_flag_function_next) ;
2360 if ($FLAGS & ATTR_FLAG_ARRAY_NEXT)
2361 $(list_append flaglist :attr_flag_array_next) ;
2362 if ($FLAGS & ATTR_FLAG_TYPE_IN_PLACE)
2363 $(list_append flaglist :attr_flag_type_in_place) ;
2364 if ($FLAGS & ATTR_FLAG_BUILT_IN)
2365 $(list_append flaglist :attr_flag_built_in) ;
2366 /* hook_handle_attribute $MAKEFLAGLIST_CHK start */
2367 if ($FLAGS & ATTR_FLAG_CXX11)
2368 $(list_append flaglist :attr_flag_cxx11) ;
2369 /* hook_handle_attribute $MAKEFLAGLIST_CHK end */
2370 }#)
2371 (debug "hook_handle_attribute" "before handler flags=" flags "; flaglist=" flaglist)
2372 (multicall
2373 (noaddv :tree tr_res tr_out_node)
2374 (handler attrv flaglist tr_in_node tr_name tr_args)
2375 (debug "hook_handle_attribute" " after handler noaddv=" noaddv
2376 "\n.. tr_res=" tr_res
2377 "\n.. tr_out_node=" tr_out_node)
2378 (or tr_out_node
2379 (setq tr_out_node tr_in_node))
2380 (setq out_no_add_attrs (non-null noaddv))
2381 (debug "hook_handle_attribute" " ending with tr_res=" tr_res
2382 "\n.. tr_out_node=" tr_out_node
2383 "\n.. out_no_add_attrs=" out_no_add_attrs)
2384 (return tr_res)
2385 )
2386 )
2387 )
2388 )
2392 (defmacro register_gcc_attribute (sexp env mexpander modctx)
2393 :doc #{The variadic macro $REGISTER_GCC_ATTRIBUTE is registering a
2394 GCC attribute $ATTR of $CLASS_GCC_ATTRIBUTE by expanding to a call to
2395 $MELT_REGISTER_GCC_ATTRIBUTE_AT internal function. Memory used by the
2396 attribute is never freed. After it can occur variadically equivalents
2397 of @code{struct attribute_spec} fields: @code{:MIN_LENGTH}
2398 @var{minimal-length} (default 0). @code{:MAX_LENGTH}
2399 @var{maximal-length} (default -1). @code{:DECL_REQUIRED}
2400 @var{decl-required-flag}. @code{:TYPE_REQUIRED}
2401 @var{type-required-flag}. @code{:FUNCTION_TYPE_REQUIRED}
2402 @var{function-type-required-flag} @code{:AFFECTS_TYPE_IDENTITY}
2403 @var{affects-type-identity-flag}. Notice that checking of variadic arguments happen at run-time. }#
2404 (debug "register_gcc_attribute macro sexp=" sexp "\n env=" debug_less env)
2405 (let (
2406 (sloc (get_field :loca_location sexp))
2407 (sexcont (get_field :sexp_contents sexp))
2408 (regatbnd (find_env env 'melt_register_gcc_attribute_at))
2409 )
2410 (unless regatbnd
2411 (error_at sloc "REGISTER_GCC_ATTRIBUTE used when MELT_REGISTER_GCC_ATTRIBUTE_AT is unbound")
2412 (return))
2413 (let ( (xarglist (expand_pairlist_as_list (pair_tail (list_first sexcont)) env mexpander modctx))
2414 )
2415 (debug "register_gcc_attribute macro xarglist=" xarglist)
2416 (when (<i (list_length xarglist) 1)
2417 (error_at sloc "REGISTER_GCC_ATTRIBUTE needs at least one argument")
2418 (return))
2419 (list_prepend xarglist sloc)
2420 (debug "register_gcc_attribute macro prepended xarglist=" xarglist)
2421 (let ( (res (instance class_source_apply
2422 :loca_location sloc
2423 :sapp_fun 'melt_register_gcc_attribute_at
2424 :sargop_args (list_to_multiple xarglist discr_multiple)))
2425 )
2426 (debug "register_gcc_attribute macro returns res=" res)
2427 (return res)
2428 )
2429 )))
2430 (export_macro register_gcc_attribute)
2432 (defun melt_register_gcc_attribute_at (loc attr :rest)
2433 :doc #{The $MELT_REGISTER_GCC_ATTRIBUTE_AT is an internal variadic function,
2434 used by $REGISTER_GCC_ATTRIBUTE macro.}#
2435 (debug "melt_register_gcc_attribute_at" " start loc=" loc " attr=" attr)
2436 (unless (is_a attr class_gcc_attribute)
2437 (error_at loc "register_gcc_attribute got invalid attr $1" attr)
2438 (return ()))
2439 ;;
2440 (when (get_int attr)
2441 (error_at loc "register_gcc_attribute already registered #$1 attribute $2"
2442 (get_int attr)
2443 attr)
2444 (return ()))
2445 ;;
2446 (if (not (is_mapstring gcc_attribute_dict))
2447 (let ( (atdic (make_mapstring discr_map_strings 31)) )
2448 (setq gcc_attribute_dict atdic)
2449 (debug "melt_register_gcc_attribute_at" " atdic=" atdic)
2450 ))
2451 (debug "melt_register_gcc_attribute_at" " gcc_attribute_dict=" gcc_attribute_dict)
2452 (assert_msg "check gcc_attribute_dict" (is_mapstring gcc_attribute_dict) gcc_attribute_dict)
2453 ;;
2454 (let (
2455 (name (get_field :named_name attr))
2456 (min_length 0)
2457 (max_length -1)
2458 (decl_required_flag 0)
2459 (type_required_flag 0)
2460 (function_type_required_flag 0)
2461 (affects_type_identity_flag 0)
2462 (:long attix (+i (mapstring_count gcc_attribute_dict) 1))
2463 )
2464 (debug "register_gcc_attribute " "gcc_attribute_dict=" gcc_attribute_dict ";\n attix=" attix)
2465 (unless (is_string name)
2466 (error_at loc "register_gcc_attribute got badly named attr $1" attr)
2467 (return))
2468 (when (mapstring_getstr gcc_attribute_dict name)
2469 (error_at loc "register_gcc_attribute got already named attr $1" name)
2470 (return))
2471 ;; variadic parsing loop
2472 (forever
2473 argsloop
2474 (variadic
2475 ;; end of args
2476 (()
2477 (exit argsloop))
2478 ((:value key)
2479 (match
2480 key
2481 ;; :min_length <number>
2482 (:MIN_LENGTH
2483 (variadic
2484 ((:long l)
2485 (setq min_length l))
2486 ((:value vl)
2487 (cond
2488 ((is_integerbox vl)
2489 (setq min_length (unbox :long vl))
2490 (void))
2491 (:else
2492 (error_at loc "register_gcc_attribute for attr $1 got bad :MIN_LENGTH value" name)
2493 (return))))
2494 (:else
2495 (error_at loc "register_gcc_attribute for attr $1 got bad :MIN_LENGTH" name)
2496 (return))))
2497 ;; :max_length <number>
2498 (:MAX_LENGTH
2499 (variadic
2500 ((:long l)
2501 (setq max_length l))
2502 ((:value vl)
2503 (cond
2504 ((is_integerbox vl)
2505 (setq max_length (unbox :long vl))
2506 (void))
2507 (:else
2508 (error_at loc "register_gcc_attribute for attr $1 got bad :MAX_LENGTH value" name)
2509 (return))))
2510 (:else
2511 (error_at loc "register_gcc_attribute for attr $1 got bad :MAX_LENGTH" name)
2512 (return))))
2513 ;; :decl_required <flag>
2514 (:DECL_REQUIRED
2515 (variadic
2516 ((:long l)
2517 (setq decl_required_flag l))
2518 ((:value vl)
2519 (cond
2520 ((is_integerbox vl)
2521 (setq decl_required_flag (unbox :long vl))
2522 (void))
2523 (:else
2524 (setq decl_required_flag (non-null vl)))))
2525 (:else
2526 (error_at loc "register_gcc_attribute for attr $1 got bad :DECL_REQUIRED" name)
2527 (return))))
2528 ;; :type_required <flag>
2529 (:TYPE_REQUIRED
2530 (variadic
2531 ((:long l)
2532 (setq type_required_flag l))
2533 ((:value vl)
2534 (cond
2535 ((is_integerbox vl)
2536 (setq type_required_flag (unbox :long vl))
2537 (void))
2538 (:else
2539 (setq type_required_flag (non-null vl)))))
2540 (:else
2541 (error_at loc "register_gcc_attribute for attr $1 got bad :TYPE_REQUIRED" name)
2542 (return))))
2543 ;; :function_type_required <flag>
2544 (:FUNCTION_TYPE_REQUIRED
2545 (variadic
2546 ((:long l)
2547 (setq function_type_required_flag l))
2548 ((:value vl)
2549 (cond
2550 ((is_integerbox vl)
2551 (setq function_type_required_flag (unbox :long vl))
2552 (void)
2553 )
2554 (:else
2555 (setq function_type_required_flag (non-null vl)))))
2556 (:else
2557 (error_at loc "register_gcc_attribute for attr $1 got bad :FUNCTION_TYPE_REQUIRED" name)
2558 (return))))
2559 ;; :affects_type_identity <flag>
2560 (:AFFECTS_TYPE_IDENTITY
2561 (variadic
2562 ((:long l)
2563 (setq affects_type_identity_flag l))
2564 ((:value vl)
2565 (cond
2566 ((is_integerbox vl)
2567 (setq affects_type_identity_flag (unbox :long vl))
2568 (void)
2569 )
2570 (:else
2571 (setq affects_type_identity_flag (non-null vl)))))
2572 (:else
2573 (error_at loc "register_gcc_attribute for attr $1 got bad :AFFECTS_TYPE_IDENTITY" name)
2574 (return))))
2575 ;; unexpected key
2576 (?_
2577 (error_at loc "register_gcc_attribute for attr $1 got unexpected key $2" name key)
2578 (return))
2579 )
2580 )
2581 (:else
2582 (error_at loc "register_gcc_attribute for $1 got invalid key" name)
2583 (return))
2584 )
2585 ) ; end forever argloop
2586 (put_int attr attix)
2587 ;; add the installing closure to the installer list
2588 (list_append
2589 gcc_attribute_installer_list
2590 ;; we are boxing all the parameters, since they are closed under lambda
2591 (let ( (vminlength (constant_box min_length))
2592 (vmaxlength (constant_box max_length))
2593 (vdeclrequired (if decl_required_flag :true))
2594 (vtyperequired (if type_required_flag :true))
2595 (vfunctiontyperequired (if function_type_required_flag :true))
2596 (vaffectstypeidentity (if affects_type_identity_flag :true))
2597 )
2598 (lambda ()
2599 (debug "melt_register_gcc_attribute_at/lambda attr=" attr)
2600 (let (
2601 (:long iminlength (get_int vminlength))
2602 (:long imaxlength (get_int vmaxlength))
2603 )
2604 (code_chunk
2605 gccattr_chk
2606 #{ /* ++ melt_register_gcc_attribute_at/lambda $GCCATTR_CHK start */
2607 struct attribute_spec *atspec
2608 /* will never be freed! */
2609 = (struct attribute_spec*)xmalloc(sizeof(struct attribute_spec)) ;
2610 if (!atspec)
2611 melt_fatal_error("failed to allocate attribute_spec in melt_register_gcc_attribute_at (%s)",
2612 xstrerror(errno)) ;
2613 memset (atspec, 0, sizeof(struct attribute_spec)) ;
2614 atspec->name = melt_intern_cstring (melt_string_str ($NAME)) ;
2615 atspec->min_length = (int) $IMINLENGTH ;
2616 atspec->max_length = (int) $IMAXLENGTH ;
2617 atspec->decl_required = $VDECLREQUIRED != NULL ;
2618 atspec->type_required = $VTYPEREQUIRED != NULL ;
2619 atspec->function_type_required = $VFUNCTIONTYPEREQUIRED != NULL ;
2620 atspec->affects_type_identity = $VAFFECTSTYPEIDENTITY != NULL ;
2621 atspec->handler = melt_attribute_handler_glue ;
2622 debugeprintf("melt_attribute_handler_glue/lambda atspec@%p "
2623 "name %s min_length %d, max_length %d",
2624 (void*)atspec,
2625 atspec->name, atspec->min_length, atspec->max_length);
2626 debugeprintf("decl_required %s, type_required %s,\n.. "
2627 "function_type_required %s, affects_type_identity %s,\n.. "
2628 "handler@%p",
2629 (atspec->decl_required)?"yes":"no",
2630 (atspec->type_required)?"yes":"no",
2631 (atspec->function_type_required)?"yes":"no",
2632 (atspec->affects_type_identity)?"yes":"no",
2633 (void*)atspec->handler);
2634 register_attribute (atspec) ;
2635 debugeprintf ("melt_register_gcc_attribute_at/lambda registered atspec=%p",
2636 (void*)atspec);
2637 /* -- melt_register_gcc_attribute_at/lambda $GCCATTR_CHK end */
2638 }#)
2639 )
2640 (debug "melt_register_gcc_attribute_at/lambda" " end, attr=" attr)
2641 (return)
2642 )
2643 )
2644 );end append gcc_attribute_installer_list
2645 (mapstring_putstr gcc_attribute_dict name attr)
2646 (debug "melt_register_gcc_attribute_at end attr=" attr
2647 ";\n gcc_attribute_dict=" gcc_attribute_dict)
2648 )
2649 )
2651 (export_values melt_register_gcc_attribute_at)
2652 ;;
2653 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2655 ;; private final exit queue
2656 (definstance final_exit_delayed_queue class_delayed_queue
2657 :named_name '"final_exit_delayed_queue"
2658 :delqu_first (make_list discr_list)
2659 :delqu_last (make_list discr_list)
2660 )
2662 ;;; exit hook
2663 (defhook hook_exit_finalizer () () :void
2664 :predef HOOK_EXIT_FINALIZER
2665 (debug "hook_exit_finalizer final_exit_delayed_queue=" final_exit_delayed_queue)
2666 (let ( (firstlist (get_field :delqu_first final_exit_delayed_queue))
2667 (lastlist (get_field :delqu_last final_exit_delayed_queue))
2668 (revlastlist (make_list discr_list))
2669 )
2670 ;;; call the first routines in natural order
2671 (foreach_pair_component_in_list
2672 (firstlist)
2673 (curpair firstproc)
2674 (firstproc ())
2675 )
2676 ;;; reverse the last list
2677 (foreach_pair_component_in_list
2678 (lastlist)
2679 (curpair lastproc)
2680 (if (is_closure lastproc) (list_prepend revlastlist lastproc)))
2681 ;;; call the last routines in reverse order
2682 (foreach_pair_component_in_list
2683 (revlastlist)
2684 (curpair lastproc)
2685 (lastproc ())
2686 )))
2689 (defun at_exit_first (fun)
2690 :doc #{Use $AT_EXIT_FIRST to register a function to be run at MELT
2691 exit, in first place.}#
2692 (let ( (firstlist (unsafe_get_field :delqu_first final_exit_delayed_queue))
2693 )
2694 (if (is_closure fun) (list_append firstlist fun)))
2695 )
2697 (defun at_exit_last (fun)
2698 :doc #{Use $AT_EXIT_LAST to register a function to be run at MELT
2699 exit, in last place.}#
2700 (let ( (lastlist (unsafe_get_field :delqu_last final_exit_delayed_queue))
2701 )
2702 (if (is_closure fun) (list_append lastlist fun)))
2703 )
2706 ;; pragma support is related to trees, so most of it is done in
2707 ;; libmelt-ana-tree.melt however, the hook is predefined so should
2708 ;; appear here. In fact, it calls a forward reference variable.
2711 (defvar pragma_processor)
2713 (defun register_pragma_processor (pfun)
2714 (debug "register_pragma_processor pfun=" pfun " pragma_processor=" pragma_processor)
2715 (assert_msg "check no pragma_processor" (null pragma_processor) pragma_processor)
2716 (shortbacktrace_dbg "register_pragma_processor" 12)
2717 (if (is_closure pfun)
2718 (setq pragma_processor pfun))
2719 (debug "register_pragma_processor now pragma_processor=" pragma_processor)
2720 )
2722 (defvar pragma_handler_tuple)
2724 (defhook hook_process_pragma (:long lix) () :void
2725 :predef HOOK_PROCESS_PRAGMA
2726 :doc #{$HOOK_PROCESS_PRAGMA is an internal hook to process a pragma.}#
2727 (debug "hook_process_pragma lix=" lix "; pragma_handler_tuple=" pragma_handler_tuple)
2728 (let ( (ph (multiple_nth pragma_handler_tuple lix))
2729 )
2730 (shortbacktrace_dbg "hook_process_pragma" 12)
2731 (debug "hook_process_pragma lix=" lix " ph=" ph)
2732 (assert_msg "check ph" (is_a ph class_gcc_pragma))
2733 ((get_field :gccpragma_handler ph) ph)
2734 (debug "hook_process_pragma done ph=" ph)))
2737 ;; we define the hook_register_pragmas here so that it gets built by 'make upgrade-warmelt'
2738 (defhook hook_register_pragmas () () :void
2739 :predef HOOK_REGISTER_PRAGMAS
2740 (debug "hook_register_pragmas start pragma_processor=" pragma_processor
2741 "\n.. pragma_handler_tuple=" pragma_handler_tuple "\n")
2742 (shortbacktrace_dbg "hook_register_pragmas" 15)
2743 (cond
2744 ( (is_closure pragma_processor)
2745 (debug "hook_register_pragmas before calling pragma_processor=" pragma_processor)
2746 (pragma_processor pragma_handler_tuple)
2747 (debug "hook_register_pragmas done with pragma_processor=" pragma_processor))
2748 (:else
2749 (debug "hook_register_pragmas bad pragma_processor=" pragma_processor)
2750 (warning_at () "hook_register_pragmas has been wrongly called")
2751 (assert_msg "@$@invalid call of hook_register_pragmas" () pragma_processor))
2752 )
2753 )
2755 (defun add_pragma_handler (ph)
2756 :doc #{Internal utility to add a pragma handler $PH which should be
2757 a $CLASS_GCC_PRAGMA. See also $REGISTER_EXPANDED_PRAGMA and
2758 $REGISTER_PLAIN_PRAGMA from @file{libmelt-ana-tree.melt}.}#
2759 (debug "add_pragma_handler start ph=" ph
2760 " pragma_handler_tuple=" pragma_handler_tuple)
2761 (shortbacktrace_dbg "add_pragma_handler" 12)
2762 (assert_msg "check ph" (is_a ph class_gcc_pragma))
2763 (if (null pragma_handler_tuple)
2764 (setq pragma_handler_tuple (make_multiple discr_multiple 16)))
2765 (let ( (:long lix 0)
2766 (:long nbph (multiple_length pragma_handler_tuple))
2767 )
2768 (foreach_in_multiple
2769 (pragma_handler_tuple)
2770 (comp :long ix)
2771 (when ix
2772 (unless comp
2773 (setq lix ix)
2774 (setq ix (+i nbph 1))
2775 (void))))
2776 (unless lix
2777 (let ( (:long newnbph (+ nbph 16 (* 2 (/i nbph 8))))
2778 (newtup (make_multiple discr_multiple newnbph))
2779 )
2780 (foreach_in_multiple
2781 (pragma_handler_tuple)
2782 (comp :long ix)
2783 (if ix (multiple_put_nth newtup ix comp)))
2784 (setq pragma_handler_tuple newtup)
2785 (setq lix nbph)
2786 (setq nbph newnbph)
2787 (void)
2788 ))
2789 (put_int ph lix)
2790 (multiple_put_nth pragma_handler_tuple lix ph)
2791 (debug "add_pragma_handler ph=" ph " lix=" lix)
2792 (return ph)
2793 ))
2796 (defun remove_pragma_handler (ph)
2797 :doc #{Utility to remove a pragma handler $PH which should be a
2798 $CLASS_GCC_PRAGMA or a boxed integer.}#
2799 (debug "remove_pragma_handler ph=" ph)
2800 (shortbacktrace_dbg "remove_pragma_handler" 12)
2801 (if (is_integerbox ph)
2802 (setq ph (multiple_nth pragma_handler_tuple (get_int ph))))
2803 (if (is_a ph class_gcc_pragma)
2804 (let ( (:long phrk (get_int ph))
2805 )
2806 (if (== (multiple_nth pragma_handler_tuple phrk) ph)
2807 (multiple_put_nth pragma_handler_tuple phrk ()))))
2808 )
2810 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2812 (export_values
2813 add_pragma_handler
2814 at_end_of_this_melt_pass_first
2815 at_end_of_this_melt_pass_last
2816 at_exit_first
2817 at_exit_last
2818 at_finish_unit_first
2819 at_finish_unit_last
2820 at_melt_attribute_first
2821 at_melt_attribute_last
2822 at_start_unit_first
2823 at_start_unit_last
2824 hook_low_debug_value_at
2825 hook_override_gate
2826 hook_process_pragma
2827 hook_register_pragmas
2828 register_all_ipa_passes_end_first
2829 register_all_ipa_passes_end_last
2830 register_all_ipa_passes_start_first
2831 register_all_ipa_passes_start_last
2832 register_all_passes_end_first
2833 register_all_passes_end_last
2834 register_all_passes_start_first
2835 register_all_passes_start_last
2836 register_early_gimple_passes_end_first
2837 register_early_gimple_passes_end_last
2838 register_early_gimple_passes_start_first
2839 register_early_gimple_passes_start_last
2840 register_finish_decl_first
2841 register_finish_decl_last
2842 register_finish_type_first
2843 register_finish_type_last
2844 register_override_gate_first
2845 register_override_gate_last
2846 register_pass_execution_first
2847 register_pass_execution_last
2848 register_pragma_processor
2849 register_pre_genericize_first
2850 register_pre_genericize_last
2851 remove_pragma_handler
2852 unregister_override_gate_first
2853 unregister_override_gate_last
2854 )
2858 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2862 (cheader #{ /* header from warmelt-hooks.melt for poll etc... */
2863 #include <poll.h>
2865 #define MELT_BUFSIZE 8192
2866 #define MELT_POLL_DELAY_MILLISEC 500
2867 }#)
2871 (defvar melt_inpchanbuck) ;;contain bucket of longs for input handling
2873 (defclass class_paragraph_input_channel_handler
2874 :doc #{$CLASS_PARAGRAPH_INPUT_CHANNEL_HANDLER is for input channel
2875 handlers which are accepting paragraphs terminated by two
2876 newlines. See also $CLASS_RAW_INPUT_CHANNEL_HANDLER}#
2877 :super class_input_channel_handler
2878 :fields ())
2880 (defclass class_raw_input_channel_handler
2881 :doc #{$CLASS_RAW_INPUT_CHANNEL_HANDLER is for input channel
2882 handlers which are accepting raw input data, without paragraph
2883 separation. See also $CLASS_PARAGRAPH_INPUT_CHANNEL_HANDLER.}#
2884 :super class_input_channel_handler
2885 :fields ())
2887 (export_class class_raw_input_channel_handler class_paragraph_input_channel_handler)
2889 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2891 ;; internal utility to read input and invoke the callbacks
2892 (defun melt_invoke_input_callbacks (tupinch tupstate :long nbins)
2893 :doc #{$MELT_INVOKE_INPUT_CALLBACKS is an internal utility, useful
2894 for $REGISTER_RAW_INPUT_CHANNEL_HANDLER and
2895 $REGISTER_PARAGRAPH_INPUT_CHANNEL_HANDLER...}#
2896 (debug "melt_invoke_input_callbacks tupinch=" tupinch
2897 "\n.. tupstate=" tupstate
2898 "\n.. nbins=" nbins)
2899 (block_signals
2900 () ()
2901 (let ( (removelist (make_list discr_list))
2902 (buck melt_inpchanbuck)
2903 )
2904 (foreach_long_upto
2905 (0 (-i nbins 1))
2906 (:long ix)
2907 (let ( (curinch (multiple_nth tupinch ix))
2908 (curstate (multiple_nth tupstate ix))
2909 (curfd (get_int curinch))
2910 (:long readcnt -2)
2911 (sbuf (get_field :inch_sbuf curinch))
2912 (clos (get_field :inch_clos curinch))
2913 )
2914 (debug "melt_invoke_input_callbacks ix#" ix " curfd#" curfd
2915 " curinch=" curinch "\n.. curstate=" curstate)
2916 (assert_msg "check curinch" (is_a curinch class_input_channel_handler) curinch)
2917 (assert_msg "check curfd" (>=i curfd 0) curfd)
2918 (if curstate
2919 (progn ;; should read and callback if got entire message
2920 (code_chunk
2921 read_chk
2922 #{ /* melt_invoke_input_callbacks $READ_CHK */
2923 static char rdbuf[MELT_BUFSIZE] ;
2924 memset (&rdbuf, 0, sizeof (rdbuf)) ;
2925 $READCNT = read ($CURFD, rdbuf, sizeof(rdbuf)) ;
2926 if ($READCNT > 0)
2927 meltgc_add_out_raw_len ((melt_ptr_t) $SBUF, rdbuf, $READCNT) ;
2928 }#)
2929 (debug "melt_invoke_input_callbacks" "after read curfd=" curfd ", readcnt=" readcnt
2930 ", sbuf=" sbuf "\n")
2931 (when (==i readcnt 0)
2932 (list_append removelist curinch)
2933 (setq curstate ()))
2934 (void)
2935 )
2936 (progn ;; should callback for eof close and remove from bucks
2937 (debug "melt_invoke_input_callbacks" " no curstate curinch=" curinch)
2938 (list_append removelist curinch)
2939 ))
2940 (debug "melt_invoke_input_callbacks" " readcnt=" readcnt
2941 " sbuf=" sbuf ";\n curinch=" curinch)
2942 (cond ( (is_a curinch class_paragraph_input_channel_handler)
2943 ;; loop to handle every 2-newline ended paragraph in the sbuf
2944 (forever
2945 scanloop
2946 (let ( (:long stop 0)
2947 (seqv ())
2948 )
2949 (code_chunk
2950 eat_chk
2951 #{ /* melt_invoke_input_callbacks $EAT_CHK */
2952 const char* bufdata = melt_strbuf_str ((melt_ptr_t) $SBUF) ;
2953 char* buf2nl = bufdata
2954 ? CONST_CAST (char*, strstr(bufdata,"\n\n"))
2955 : NULL ;
2956 if (buf2nl) {
2957 int paralen = buf2nl - bufdata + 2 ;
2958 ((char*) buf2nl)[1] = '\0' ;
2959 $SEQV = meltgc_read_from_rawstring (bufdata, NULL,
2960 UNKNOWN_LOCATION) ;
2961 melt_strbuf_consume ((melt_ptr_t) $SBUF, paralen) ;
2962 }
2963 else {
2964 $STOP = 1;
2965 if (!$CURSTATE && bufdata) {
2966 int buflen = strlen (bufdata) ;
2967 $SEQV = meltgc_read_from_rawstring (bufdata, NULL,
2968 UNKNOWN_LOCATION) ;
2969 melt_strbuf_consume ((melt_ptr_t) $SBUF, buflen) ;
2970 }
2971 }
2972 }#)
2973 (when seqv
2974 (debug "melt_invoke_input_callbacks paragraph seqv=" seqv "\n curinch=" curinch)
2975 (clos curinch seqv))
2976 (if stop (exit scanloop))
2977 )
2978 ) ;end scanloop
2979 )
2980 ( (is_a curinch class_raw_input_channel_handler)
2981 (debug "melt_invoke_input_callbacks" " raw sbuf=" sbuf ";\n curinch=" curinch)
2982 ;; pass the sbuf to separate the EOF case
2983 (clos curinch sbuf)
2984 )
2985 (:else
2986 (assert_msg "melt_invoke_input_callbacks invalid curinch" () curinch))
2987 )
2988 (when (null curstate)
2989 (debug "melt_invoke_input_callbacks eof curinch=" curinch)
2990 (clos curinch ())
2991 )
2992 )
2993 ) ;end for ix
2994 (debug "melt_invoke_input_callbacks removelist=" removelist)
2995 (foreach_pair_component_in_list
2996 (removelist)
2997 (curpair curemove)
2998 (debug "melt_invoke_input_callbacks curemove=" curemove)
2999 (setq buck (bucketlong_remove buck (get_int curemove)))
3000 )
3001 (setq melt_inpchanbuck buck)
3002 )
3003 )
3004 ) ;end melt_invoke_input_callbacks
3008 (defhook hook_poll_inputs
3009 (:long delayms)
3010 ()
3011 :void
3012 :predef HOOK_POLL_INPUTS
3013 :doc #{The $HOOK_POLL_INPUTS is making a multiplexing @code{poll(2)}
3014 syscall -with the milliseconds delay given by $DELAYMS- and then
3015 reading appropriate input file descriptors and running the callback
3016 registered with $REGISTER_PARAGRAPH_INPUT_CHANNEL_HANDLER or
3017 $REGISTER_RAW_INPUT_CHANNEL_HANDLER. It is usually called to service
3018 the SIGIO signal, but could be called elsewhere. For experts
3019 mostly.}#
3020 (let ( (inchbuck melt_inpchanbuck)
3021 (:long nbinch (bucketlong_count inchbuck))
3022 (:long respoll 0)
3023 )
3024 (debug "hook_poll_inputs inchbuck=" inchbuck " delayms=" delayms)
3025 (when (==i nbinch 0)
3026 (debug "hook_poll_inputs empty inchbuck")
3027 (code_chunk
3028 pollsleep_chk
3029 #{/* hook_poll_inputs $POLLSLEEP_CHK do the poll */
3030 $RESPOLL = poll (NULL, 0, $DELAYMS);
3031 }#)
3032 (return))
3033 (let (
3034 (tupinch (make_multiple discr_multiple nbinch))
3035 (:long nbfd 0)
3036 )
3037 (code_chunk
3038 pollin_chk
3039 #{ /* hook_poll_inputs $POLLIN_CHK start */
3040 struct pollfd *fdtab
3041 = (struct pollfd *) xcalloc ($NBINCH+1, sizeof(struct pollfd));
3042 /* hook_poll_inputs $POLLIN_CHK iteration to fill fdtab */
3043 $(foreach_in_bucketlong
3044 (inchbuck)
3045 (:long curfd :value curinchd)
3046 (debug "hook_poll_inputs curfd#" curfd ", curinchd=" curinchd)
3047 (when (is_a curinchd class_input_channel_handler)
3048 (assert_msg "check curinchd" (==i (get_int curinchd) curfd) curinchd curfd)
3049 (code_chunk
3050 addfd_chk
3051 #{ /* hook_poll_inputs $POLLIN_CHK with $ADDFD_CHK */
3052 fdtab[$NBFD].fd = (int) $CURFD ;
3053 fdtab[$NBFD].events = POLLIN ;
3054 fdtab[$NBFD].revents = 0 ;
3055 }#)
3056 (multiple_put_nth tupinch nbfd curinchd)
3057 (setq nbfd (+i nbfd 1))
3058 )
3059 )
3060 $(progn (debug "hook_poll_inputs nbfd=" nbfd " tupinch=" tupinch) (void))
3061 /* hook_poll_inputs $POLLIN_CHK do the poll */
3062 $RESPOLL = poll (fdtab, $NBFD, $DELAYMS);
3063 debugeprintf ("hook_poll_inputs respoll=%ld", $RESPOLL);
3064 $(if (>i respoll 0)
3065 (let (
3066 (tupstate (make_multiple discr_multiple nbfd))
3067 (badinchlist (make_list discr_list))
3068 )
3069 (foreach_long_upto
3070 (0 (-i nbfd 1))
3071 (:long ix)
3072 (let ( (curinchd (multiple_nth tupinch ix))
3073 )
3074 (debug "hook_poll_inputs ix#" ix " curinchd=" curinchd)
3075 (cond
3076 ( (expr_chunk testpollin_chk :long
3077 ##{/* hook_poll_inputs $TESTPOLLIN_CHK */
3078 fdtab[$IX].revents & POLLIN}#)
3079 (debug "hook_poll_inputs POLLIN ix#" ix)
3080 (multiple_put_nth tupstate ix :true)
3081 )
3082 ;; POLLERR & POLLHUP cannot happen for input polling
3083 ( (expr_chunk testpollnval_chk :long
3084 ##{/* hook_poll_inputs $TESTPOLLNVAL_CHK */
3085 fdtab[$IX].revents & POLLNVAL}#)
3086 (debug "hook_poll_inputs POLLNVAL ix#" ix)
3087 (multiple_put_nth tupstate ix ())
3088 (list_append badinchlist curinchd)
3089 )
3090 )
3091 )) ;; end foreach_long_upto ix
3092 (debug "hook_poll_inputs nbfd#" nbfd
3093 "\n.. tupstate=" tupstate
3094 "\n.. badinchlist=" badinchlist)
3095 (foreach_pair_component_in_list
3096 (badinchlist)
3097 (curpair curinchb)
3098 (debug "hook_poll_inputs bad curinchb=" curinchb)
3099 (bucketlong_put inchbuck (get_int curinchb) :true)
3100 )
3101 (debug "hook_poll_inputs before melt_invoke_input_callbacks tupinch=" tupinch
3102 "\n.. tupstate=" tupstate "\n.. nbfd=" nbfd)
3103 (melt_invoke_input_callbacks tupinch tupstate nbfd)
3104 (debug "hook_poll_inputs after melt_invoke_input_callbacks nbfd=" nbfd)
3105 (void)
3106 ))
3107 /* hook_poll_inputs $POLLIN_CHK final */
3108 free (fdtab);
3109 /* hook_poll_inputs $POLLIN_CHK end */ }#))
3110 )
3111 )
3114 (defun is_polling_inputs ()
3115 :doc #{$IS_POLLING_INPUTS return :TRUE with secondarily the number of input channels
3116 if some channels are polling, or nil otherwise}#
3117 (let ( (inchbuck melt_inpchanbuck)
3118 (:long nbinch (bucketlong_count inchbuck))
3119 )
3120 (if nbinch (return :true nbinch)
3121 (return () 0))
3122 ))
3124 (defun every_polling_input (f)
3125 :doc #{$EVERY_POLLING_INPUTS applies the given closure $F to every
3126 input channel. Iteration is stopped if that application returns nil.}#
3127 (let ( (inchbuck melt_inpchanbuck)
3128 (:long nbinch (bucketlong_count inchbuck))
3129 (lischan (make_list discr_list))
3130 )
3131 (when nbinch
3132 (block_signals
3133 () ()
3134 (foreach_in_bucketlong
3135 (inchbuck)
3136 (:long fd :value chv)
3137 (if (is_a chv class_input_channel_handler)
3138 (list_append lischan chv))
3139 ))
3140 (when (is_closure f)
3141 (foreach_pair_component_in_list
3142 (lischan)
3143 (curpair curchan)
3144 (debug "every_polling_input curchan=" curchan)
3145 (if (null (f curchan))
3146 (setq curpair ())))))))
3148 (defun get_polling_input (bi)
3149 :doc #{The function $GET_POLLING_INPUT gets the polling input associated to integer in $BI.}#
3150 (let ( (inchbuck melt_inpchanbuck)
3151 (:long nbinch (bucketlong_count inchbuck))
3152 (:long i (get_int bi))
3153 )
3154 (when nbinch
3155 (block_signals
3156 () ()
3157 (let ( (curb (bucketlong_get inchbuck i))
3158 )
3159 (if (is_a curb class_input_channel_handler)
3160 (return curb)))))
3161 (return ())
3162 ))
3164 ;;;;;;;;;;;;;;;;
3165 (defun register_paragraph_input_channel_handler (clos data :long inchfd)
3166 :doc #{$REGISTER_PARAGRAPH_INPUT_CHANNEL_HANDLER registers an
3167 asynchronous paragraph input channel handler, such as for the
3168 graphical user interface probe. $CLOS is the registered closure,
3169 $DATA is some client data, $INCHFD is the input Unix file
3170 descriptor. When an entire message (double-newline ended sequence of
3171 MELT values in MELT syntax) is recieved from the $INCHFD, the $CLOS
3172 is applied to the input channel handler -containing the data as its
3173 $INCH_DATA field-, a read-only instance of
3174 $CLASS_INPUT_CHANNEL_HANDLER, and to the read list. When end-of-file
3175 is obtained on $INCHFD, the closure is similarily applied with a
3176 null value instead of the read list. Returns an opaque channel of
3177 $CLASS_PARAGRAPH_INPUT_CHANNEL_HANDLER that should not be mutated by
3178 application code. See also $UNREGISTER_INPUT_CHANNEL.}#
3179 (debug "register_paragraph_input_channel_handler clos=" clos " data=" data
3180 " inchfd=" inchfd)
3181 (let ( (:long goodinchfd 0) )
3182 (if (and (is_closure clos)
3183 (>=i inchfd 0))
3184 (code_chunk
3185 statinchfdchk
3186 #{ /*register_paragraph_input_channel_handler $STATINCHFDCHK */ {
3187 struct stat $STATINCHFDCHK#_stat;
3188 memset (& $STATINCHFDCHK#_stat, 0, sizeof(struct stat));
3189 if (fstat ($INCHFD, & $STATINCHFDCHK#_stat))
3190 warning(0, "MELT bad registered paragraph input channel fd#%d - %s",
3191 (int) $INCHFD, xstrerror (errno));
3192 else
3193 $GOODINCHFD = 1;
3194 } /* end $STATINCHFDCHK */ }#)
3195 )
3196 (if (not goodinchfd) (return)))
3197 (let ( (insbuf (make_strbuf discr_strbuf))
3198 (inchdlr (instance class_paragraph_input_channel_handler
3199 :inch_sbuf insbuf
3200 :inch_clos clos
3201 :inch_data data))
3202 (inbuck melt_inpchanbuck)
3203 )
3204 (put_int inchdlr inchfd)
3205 (if (not (is_bucketlong inbuck))
3206 (let ( (newinbuck (make_bucketlong discr_bucket_longs 50))
3207 )
3208 (setq inbuck newinbuck)))
3209 (let ( (updatedinbuck (bucketlong_put inbuck inchfd inchdlr))
3210 )
3211 (setq melt_inpchanbuck updatedinbuck)
3212 (code_chunk
3213 fcntlinchfdchk
3214 #{ /* register_paragraph_input_channel_handler $FCNTLINCHFDCHK start */
3215 if (fcntl ($INCHFD, F_SETOWN, getpid()))
3216 melt_fatal_error("MELT failed to set ownership (F_SETOWN) fd #%d - %s",
3217 (int) $INCHFD, xstrerror (errno));
3218 /* end $FCNTLINCHFDCHK register_paragraph_input_channel_handler */
3219 }#)
3220 (return inchdlr)
3221 )))
3223 ;;;;;;;;;;;;;;;;
3224 (defun register_raw_input_channel_handler (clos data :long inchfd)
3225 :doc #{$REGISTER_RAW_INPUT_CHANNEL_HANDLER registers an asynchronous
3226 raw input channel handler, such as for some JSONRPC server (e.g. by
3227 $DO_BLOCKING_JSONRPC2_CALL). $CLOS is the registered closure, $DATA
3228 is some client data, $INCHFD is the input Unix file descriptor. When
3229 some bytes are recieved from the $INCHFD, the $CLOS is applied - by
3230 $MELT_INVOKE_INPUT_CALLBACKS utility - to the input channel handler
3231 -containing the data as its $INCH_DATA field-, a read-only instance
3232 of $CLASS_INPUT_CHANNEL_HANDLER and to the contained string buffer.
3233 When end-of-file is obtained on $INCHFD, the closure is similarily
3234 applied to the channel and a null value. Returns an opaque channel
3235 of $CLASS_RAW_INPUT_CHANNEL_HANDLER that should not be mutated by
3236 application code. See also $UNREGISTER_INPUT_CHANNEL.}#
3237 (debug "register_raw_input_channel_handler clos=" clos " data=" data
3238 " inchfd=" inchfd)
3239 (let ( (:long goodinchfd 0) )
3240 (if (and (is_closure clos)
3241 (>=i inchfd 0))
3242 (code_chunk
3243 statinchfdchk
3244 #{ /*register_raw_input_channel_handler $STATINCHFDCHK */ {
3245 struct stat $STATINCHFDCHK#_stat;
3246 memset (& $STATINCHFDCHK#_stat, 0, sizeof(struct stat));
3247 if (fstat ($INCHFD, & $STATINCHFDCHK#_stat))
3248 warning(0, "MELT bad registered raw input channel fd#%d - %s",
3249 (int) $INCHFD, xstrerror (errno));
3250 else
3251 $GOODINCHFD = 1;
3252 } /* end $STATINCHFDCHK */ }#)
3253 )
3254 (if (not goodinchfd) (return)))
3255 (let ( (insbuf (make_strbuf discr_strbuf))
3256 (inchdlr (instance class_raw_input_channel_handler
3257 :inch_sbuf insbuf
3258 :inch_clos clos
3259 :inch_data data))
3260 (inbuck melt_inpchanbuck)
3261 )
3262 (put_int inchdlr inchfd)
3263 (if (not (is_bucketlong inbuck))
3264 (let ( (newinbuck (make_bucketlong discr_bucket_longs 50))
3265 )
3266 (setq inbuck newinbuck)))
3267 (let ( (updatedinbuck (bucketlong_put inbuck inchfd inchdlr))
3268 )
3269 (setq melt_inpchanbuck updatedinbuck)
3270 (code_chunk
3271 fcntlinchfdchk
3272 #{ /* register_raw_input_channel_handler $FCNTLINCHFDCHK start */
3273 if (fcntl ($INCHFD, F_SETOWN, getpid()))
3274 melt_fatal_error("MELT failed to set ownership (F_SETOWN) fd #%d - %s",
3275 (int) $INCHFD, xstrerror (errno));
3276 /* end $FCNTLINCHFDCHK register_raw_input_channel_handler */
3277 }#)
3278 (return inchdlr)
3279 )))
3281 ;;;
3282 (defun unregister_input_channel (chanv)
3283 :doc #{$UNREGISTER_INPUT_CHANNEL forcibly unregisters a channel
3284 obtained by $REGISTER_PARAGRAPH_INPUT_CHANNEL_HANDLER or
3285 $REGISTER_RAW_INPUT_CHANNEL_HANDLER. For gurus only.}#
3286 (debug "unregister_input_channel start chanv=" chanv)
3287 (let ( (:long inchfd -1)
3288 )
3289 (cond ( (is_a chanv class_input_channel_handler)
3290 (setq inchfd (get_int chanv))
3291 (void))
3292 ( (is_integerbox chanv)
3293 (setq inchfd (get_int chanv))
3294 (void))
3295 (:else
3296 (return)))
3297 (block_signals
3298 () ()
3299 (let ( (buck melt_inpchanbuck)
3300 (inchan (bucketlong_get buck inchfd))
3301 )
3302 (when (is_a inchan class_input_channel_handler)
3303 (setq buck (bucketlong_remove buck inchfd))
3304 (setq melt_inpchanbuck buck)
3305 (debug "unregister_input_channel removed inchan=" debug_less inchan)
3306 )
3307 )
3308 )
3309 )
3310 )
3312 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3313 ;;; connect to a server thru a socket
3314 (cheader
3315 #{ /* headers before connect_to_server */
3316 #include <sys/socket.h>
3317 #include <sys/types.h>
3318 #include <sys/socket.h>
3319 #include <sys/un.h>
3320 #include <netinet/in.h>
3321 #include <netinet/ip.h>
3322 #include <netinet/tcp.h>
3323 #include <netdb.h>
3324 #include <map>
3326 struct Melt_connect_info {
3327 std::string mci_service;
3328 int mci_family;
3329 int mci_socktype;
3330 int mci_protocol;
3331 socklen_t mci_addrlen;
3332 struct sockaddr_storage mci_sockaddr;
3333 };
3334 typedef std::map<std::string,Melt_connect_info> melt_connect_info_map_t;
3335 /* end of headers for connect_to_server */
3336 }#)
3338 (defun connect_to_server (service :long quiet)
3339 :doc #{the $CONNECT_TO_SERVER function connect thru a socket to a
3340 given $SERVICE. If $SERVICE is a boxed integer, it is an already
3341 connected socket file descriptor. If $SERVICE is a string containing
3342 a / it is understood as @code{AF_UNIX} socket name. Otherwise it
3343 should be a @var{hostname}@code{:}@var{portnumber} for TCP/IPv4 or
3344 IPv6, with @code{:1234} understood as @code{localhost:1234}. Returns
3345 a boxed integer to a connected socket file descriptor, or NIL on
3346 system error. Gives GCC warnings on system errors. If $QUIET is
3347 zero, gives GCC notice inform on success. Notice that for IP
3348 connections, the IP address is cached so would be requested once.}#
3349 (debug "connect_to_server start service=" service)
3350 (cond
3351 ;;; boxed integer, a connected socket
3352 ( (is_integerbox service)
3353 ;; already connected socket, use getpeername
3354 ;;
3355 (let ( (:long servicenumfd (get_int service))
3356 )
3357 (code_chunk
3358 getpeer_chk #{ /* connect_to_server $GETPEER_CHK */
3359 struct sockaddr_storage sa ;
3360 char sahname[80] ;
3361 memset ((void*)&sa, 0, sizeof(sa)) ;
3362 memset ((void*)sahname, 0, sizeof(sahname)) ;
3363 socklen_t salen = sizeof(sa) ;
3364 if (getpeername((int)$SERVICENUMFD, (struct sockaddr*)&sa, &salen)) {
3365 warning (0, "MELT connect_to_server: on file descriptor #%d failed getpeername: %s",
3366 (int)$SERVICENUMFD, xstrerror(errno)) ;
3367 $(ignore (return ())) ;
3368 } ;
3369 if (!$QUIET) {
3370 if (getnameinfo((const struct sockaddr *)(&sa), salen,
3371 sahname, sizeof(sahname),
3372 NULL, 0, 0)) {
3373 warning (0, "MELT connect_to_server: on file descriptor #%d failed getnameinfo: %s",
3374 (int)$SERVICENUMFD, xstrerror(errno)) ;
3375 $(ignore (return ())) ;
3376 } ;
3377 inform (UNKNOWN_LOCATION,
3378 "MELT connect_to_server with file descriptor #%d of peer %s",
3379 (int)$SERVICENUMFD, sahname) ;
3380 }
3381 }#)
3382 (debug "connect_to_server service=" service " good peered file descriptor#" servicenumfd)
3383 (return (constant_box servicenumfd))
3384 )
3385 )
3386 ;; should be a string
3387 ( (not (is_string service))
3388 (warning_at () "connect_to_server invalid service $1" service)
3389 (return))
3390 ( (>i (string_length service) 100)
3391 (warning_at () "connect_to_server too long service $1, more than 100 chars" service)
3392 (return))
3393 ;; unix-like socket with /
3394 ( (expr_chunk unixsockslash_chk :long
3395 #{/* connect_to_server $UNIXSOCKSLASH_CHK */ strchr (melt_string_str ($SERVICE), '/') != NULL}#)
3396 (let ( (:long unixsockfd -1)
3397 )
3398 (code_chunk connectunix_chk
3399 #{ /* connect_to_server $CONNECTUNIX_CHK */
3400 /* UNIX_PATH_MAX might be defined, but usually not, see unix(7) man page */
3401 #ifndef UNIX_PATH_MAX
3402 #define UNIX_PATH_MAX 100
3403 #endif /*UNIX_PATH_MAX */
3404 struct sockaddr_un saun;
3405 memset (&saun, 0, sizeof(saun));
3406 debugeprintf("connect_to_server unix service %s",
3407 melt_string_str($SERVICE));
3408 if (strlen(melt_string_str($SERVICE))>=UNIX_PATH_MAX) {
3409 warning (0, "MELT connect_to_server: AF_UNIX too long path %s", melt_string_str($SERVICE));
3410 $(ignore (return ()));
3411 };
3412 saun.sun_family = AF_UNIX;
3413 strncpy (saun.sun_path, melt_string_str($SERVICE), UNIX_PATH_MAX);
3414 $UNIXSOCKFD = socket (AF_UNIX, SOCK_STREAM, 0);
3415 if ((int)$UNIXSOCKFD<0) {
3416 warning (0, "MELT connect_to_server: AF_UNIX %s socket failure: %s",
3417 saun.sun_path, xstrerror(errno));
3418 $(ignore (return ()));
3419 };
3420 // read man page unix(7)
3421 socklen_t saulen = offsetof(struct sockaddr_un, sun_path) + strlen(saun.sun_path) + 1;
3422 debugeprintf ("connect_to_server: connect sun_path %s saulen=%d",
3423 saun.sun_path, (int)saulen);
3424 if (connect ((int)$UNIXSOCKFD, (const struct sockaddr*)&saun, saulen)) {
3425 warning (0, "MELT connect_to_server: AF_UNIX %s connect failure: %s",
3426 saun.sun_path, xstrerror(errno));
3427 (void) close((int)$UNIXSOCKFD);
3428 $(ignore (return ()));
3429 };
3430 if (!$QUIET)
3431 inform (UNKNOWN_LOCATION,
3432 "MELT connect_to_server: connected to Unix socket %s file descriptor #%d",
3433 saun.sun_path, (int)$UNIXSOCKFD) ;
3434 }#)
3435 (debug "connect_to_server service=" service " unixsockfd=" unixsockfd)
3436 (return (constant_box unixsockfd))
3437 ))
3438 ;; TCP-like socket with at least one colon <host>:<port>
3439 ( (expr_chunk unixsockslash_chk :long
3440 #{/* connect_to_server $UNIXSOCKSLASH_CHK */ strchr (melt_string_str ($SERVICE), ':') != NULL}#)
3441 (let ( (:long tcpsockfd -1)
3442 )
3443 (code_chunk
3444 connecttcp_chk
3445 #{ /* connect_to_server $CONNECTTCP_CHK */
3446 int locportnum = -1;
3447 int pos = -1;
3448 struct addrinfo hints = { 0 };
3449 char remservicename[24] = { 0 };
3450 char remhostname[80] = { 0 };
3451 struct addrinfo *adinf = NULL;
3452 int gstatus = -1;
3453 static melt_connect_info_map_t coninfmap;
3454 Melt_connect_info conninfo;
3455 bool gotconninfo = false;
3456 const char* servicestr = melt_string_str ($SERVICE);
3457 debugeprintf("connect_to_server TCPlike servicestr=%s", servicestr);
3458 if ((sscanf(servicestr, "localhost:%d", &locportnum)>0
3459 || sscanf(servicestr, ":%d", &locportnum)>0)
3460 && locportnum>0) {
3461 debugeprintf("connect_to_server locportnum=%d", locportnum);
3462 struct sockaddr_in sain;
3463 memset (&sain, 0, sizeof (sain));
3464 servicestr = NULL;
3465 sain.sin_family = AF_INET;
3466 sain.sin_port = htons ((int)locportnum);
3467 sain.sin_addr.s_addr = htonl (INADDR_LOOPBACK);
3468 $TCPSOCKFD = (long) socket (AF_INET, SOCK_STREAM, IPPROTO_TCP);
3469 if ((int)$TCPSOCKFD<0) {
3470 warning (0, "MELT connect_to_server: localhost:%d socket failure: %s",
3471 locportnum, xstrerror(errno));
3472 $(ignore (return ()));
3473 }
3474 if (connect ((int)$TCPSOCKFD, (const struct sockaddr*)&sain, (socklen_t)sizeof(sain))) {
3475 warning (0, "MELT connect_to_server: localhost:%d connect failure: %s",
3476 locportnum, xstrerror(errno));
3477 (void) close((int)$TCPSOCKFD);
3478 $(ignore (return ()));
3479 }
3480 }
3481 else { /* try IPv6 connection with getaddrinfo, <hostname>:<servicenameorport> */
3482 memset (&hints, 0, sizeof (hints));
3483 /// use the memoized connect info, if available
3484 {
3485 const char* servicestr = melt_string_str ($SERVICE);
3486 gcc_assert (servicestr != NULL);
3487 melt_connect_info_map_t::iterator iterconninfo = coninfmap.find(std::string(servicestr));
3488 if (iterconninfo != coninfmap.end()) {
3489 conninfo = iterconninfo->second;
3490 gotconninfo = true;
3491 }
3492 debugeprintf("connect_to_server gotconninfo=%d",
3493 (int) gotconninfo);
3494 if (strlen(servicestr) >= sizeof(remhostname)) {
3495 warning (0, "MELT connect_to_server: too long service name %s", servicestr);
3496 $(ignore (return ()));
3497 };
3498 const char* lastcolon = strrchr(servicestr, ':');
3499 gcc_assert (lastcolon != NULL && lastcolon > servicestr+1);
3500 strncpy (remhostname, servicestr,
3501 MIN((unsigned)(lastcolon-servicestr), (unsigned)sizeof(remhostname)));
3502 strncpy (remservicename, lastcolon+1,
3503 sizeof(remservicename)-1);
3504 debugeprintf("connect_to_server remhostname=%s remservicename=%s", remhostname, remservicename);
3505 if (gotconninfo) { // cached network info from previous call
3506 gcc_assert (!strcmp(conninfo.mci_service.c_str(), melt_string_str($SERVICE)));
3507 $TCPSOCKFD = (long) socket (conninfo.mci_family, conninfo.mci_socktype, conninfo.mci_protocol);
3508 if ((int)$TCPSOCKFD<0) {
3509 warning (0, "MELT connect_to_server: cached service %s socket failed: %s",
3510 melt_string_str($SERVICE), xstrerror(errno));
3511 $(ignore (return ()));
3512 }
3513 if (connect ((int)$TCPSOCKFD, (struct sockaddr *) &conninfo.mci_sockaddr,
3514 conninfo.mci_addrlen) < 0) {
3515 warning (0, "MELT connect_to_server: cached service %s connect failed: %s",
3516 melt_string_str($SERVICE), xstrerror(errno));
3517 $(ignore (return ()));
3518 };
3519 $(progn (debug "connect_to_server cached service=" service " tcpsockfd=" tcpsockfd)
3520 (return (constant_box tcpsockfd))
3521 (void))
3522 };// end if gotconninfo
3523 };
3524 hints.ai_family = AF_UNSPEC;
3525 hints.ai_socktype = SOCK_STREAM;
3526 hints.ai_flags = AI_PASSIVE | AI_CANONNAME;
3527 if ((gstatus = getaddrinfo (remhostname, remservicename, &hints, &adinf)) != 0) {
3528 warning (0, "MELT connect_to_server: getaddrinfo host %s service %s failed: %s",
3529 remhostname, remservicename, gai_strerror(gstatus));
3530 $(ignore (return ()));
3531 };
3532 for (struct addrinfo * curadinf = adinf;
3533 curadinf != NULL;
3534 curadinf = curadinf->ai_next)
3535 {
3536 errno = 0;
3537 $TCPSOCKFD = (long) socket (curadinf->ai_family, curadinf->ai_socktype,
3538 curadinf->ai_protocol);
3539 if ((int)$TCPSOCKFD<0 && curadinf->ai_next)
3540 continue;
3541 if ((int)$TCPSOCKFD<0) {
3542 int errnosocket = errno;
3543 struct protoent *protoent = getprotobynumber (curadinf->ai_protocol);
3544 char protonumbuf[8] = { 0 };
3545 char* protoname = NULL;
3546 if (protoent)
3547 protoname = protoent->p_name;
3548 else {
3549 snprintf (protonumbuf, sizeof (protonumbuf), "%d",
3550 curadinf->ai_protocol);
3551 protoname = protonumbuf;
3552 };
3553 warning (0, "MELT connect_to_server socket remote host %s service %s failed for protocol %s: %s",
3554 remhostname, remservicename, protoname,
3555 xstrerror(errnosocket));
3556 freeaddrinfo (adinf);
3557 $(ignore (return ()));
3558 }; // end if (int)$TCPSOCKFD<0
3559 if (connect ((int)$TCPSOCKFD, (struct sockaddr *) curadinf->ai_addr,
3560 curadinf->ai_addrlen) < 0) {
3561 int errnoconnect = errno;
3562 struct protoent *protoent = getprotobynumber (curadinf->ai_protocol);
3563 char protonumbuf[8] = { 0 };
3564 char* protoname = NULL;
3565 if (protoent)
3566 protoname = protoent->p_name;
3567 else {
3568 snprintf (protonumbuf, sizeof (protonumbuf), "%d",
3569 curadinf->ai_protocol);
3570 protoname = protonumbuf;
3571 };
3572 warning (0, "MELT connect_to_server connect remote host %s service %s failed for protocol %s: %s",
3573 remhostname, remservicename, protoname,
3574 xstrerror(errnoconnect));
3575 freeaddrinfo (adinf);
3576 $(ignore (return ()));
3577 } // end if connect failed
3578 else
3579 { // memoize and break the loop
3580 Melt_connect_info newconninfo;
3581 std::string strservice(melt_string_str($SERVICE));
3582 newconninfo.mci_service = strservice;
3583 newconninfo.mci_family = curadinf->ai_family;
3584 newconninfo.mci_socktype = curadinf->ai_socktype;
3585 newconninfo.mci_protocol = curadinf->ai_protocol;
3586 newconninfo.mci_addrlen = curadinf->ai_addrlen;
3587 memset (&newconninfo.mci_sockaddr, 0, sizeof(struct sockaddr_storage));
3588 memcpy (&newconninfo.mci_sockaddr, curadinf->ai_addr, curadinf->ai_addrlen);
3589 coninfmap[strservice] = newconninfo;
3590 break;
3591 };
3592 }; /* end for curadinf */
3593 freeaddrinfo(adinf), adinf = NULL;
3594 } /* end IP with getaddrinfo */
3595 /* end connect_to_server $CONNECTTCP_CHK */
3596 }#)
3597 (debug "connect_to_server service=" service " tcpsockfd=" tcpsockfd)
3598 (return (constant_box tcpsockfd))
3599 ))
3600 (:else
3601 (warning_at () "connect_to_server: invalid service $1" service)
3602 (return)))
3603 )
3605 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3606 ;;; asynchronous JSON parsing
3607 (defclass class_json_parser
3608 :super class_proped
3609 :doc #{The $CLASS_JSON_PARSER is the internal class for asynchronous JSON parsing}#
3610 :fields (jsonparse_jdata
3611 jsonparse_stack
3612 jsonparse_errorhandler
3613 jsonparse_counter
3614 )
3615 )
3616 (export_class class_json_parser)
3618 (defvar json_name_dict)
3619 (let ( (jsondict (make_mapstring discr_map_strings 71))
3620 )
3621 (mapstring_putstr jsondict '"null" :json_nil)
3622 (mapstring_putstr jsondict '"true" :true)
3623 (mapstring_putstr jsondict '"false" :json_false)
3624 (setq json_name_dict jsondict)
3625 (void))
3628 ;; internal function to lex a json sbuf it is expected that the sbuf
3629 ;; contains a JSON composite object or array. Passing an sbuf
3630 ;; containing exactly "null" would fail (because another letter could
3631 ;; be added after that....), you'll need to pass an sbuf like "null "
3632 ;; or "null," to get a successful :json_nil
3633 (defun json_lexer (sbuf)
3634 (unless (is_strbuf sbuf)
3635 (return))
3636 (forever
3637 lexloop
3638 (let ( (:long curch -1)
3639 (:long nextch -1)
3640 (:long bulen (strbuf_usedlength sbuf))
3641 )
3642 (when (<=i bulen 0)
3643 (debug "json_lexer eof")
3644 (return))
3645 (code_chunk getch2_chk
3646 #{/* json_lexer $GETCH2_CHK */
3647 const char* pc = melt_strbuf_unsafe_byte_address($SBUF, 0);
3648 if ($BULEN>0) $CURCH= pc[0];
3649 if ($BULEN>1) $NEXTCH= pc[1];
3650 }#)
3651 (debug "json_lexer loop sbuf=" sbuf " curch=" curch " nextch=" nextch
3652 " bulen=" bulen)
3653 (cond
3654 ;; skip spaces
3655 ((expr_chunk testspace_chk :long #{ISSPACE($CURCH)}#)
3656 (strbuf_consume sbuf 1)
3657 (again lexloop))
3658 ;; various single-char delimiters
3659 ((==i curch #\[)
3660 (strbuf_consume sbuf 1)
3661 (debug "json_lexer leftbacket")
3662 (return :delim :left_bracket))
3663 ((==i curch #\])
3664 (strbuf_consume sbuf 1)
3665 (debug "json_lexer rightbracket")
3666 (return :delim :right_bracket))
3667 ((==i curch #\,)
3668 (strbuf_consume sbuf 1)
3669 (debug "json_lexer comma")
3670 (return :delim :comma))
3671 ((==i curch #\:)
3672 (strbuf_consume sbuf 1)
3673 (debug "json_lexer colon")
3674 (return :delim :colon))
3675 ((==i curch #\{)
3676 (strbuf_consume sbuf 1)
3677 (debug "json_lexer leftbrace")
3678 (return :delim :left_brace))
3679 ((==i curch #\})
3680 (strbuf_consume sbuf 1)
3681 (debug "json_lexer rightbrace")
3682 (return :delim :right_brace))
3683 ;;
3684 ;; numbers
3685 ((expr_chunk testdigitminus_chk :long
3686 #{/* json_lexer $TESTDIGITMINUS_CHK */
3687 (ISDIGIT($CURCH)
3688 || ((char)$CURCH== '-'
3689 && ISDIGIT((char)$NEXTCH)))}#)
3690 (debug "json_lexer number start")
3691 (let (
3692 (:long eatlen 0)
3693 (val ())
3694 )
3695 (code_chunk
3696 parsejsonnum_chk
3697 #{ /* json_lexer begin $PARSEJSONNUM_CHK */
3698 long l = 0 ;
3699 double x = 0.0 ;
3700 int lnum = melt_strbuf_peek_long_number($SBUF,0,&l) ;
3701 int ldbl = melt_strbuf_peek_double_number($SBUF,0,&x) ;
3702 debugeprintf("json_lexer $PARSEJSONNUM_CHK lnum=%d ldbl=%d l=%ld x=%g bulen=%ld",
3703 lnum, ldbl, l, x, $BULEN);
3704 if (lnum>0 && lnum>=ldbl && (long)lnum<$BULEN) {
3705 $EATLEN = (long)lnum ;
3706 debugeprintf("json_lexer $PARSEJSONNUM_CHK long number l=%ld eatlen=%ld", l, $EATLEN);
3707 $VAL = meltgc_new_int((meltobject_ptr_t)
3708 MELT_PREDEF(DISCR_CONSTANT_INTEGER),
3709 l) ;
3710 }
3711 else if (ldbl>0 && (long)ldbl<$BULEN) {
3712 $EATLEN = (long)ldbl ;
3713 debugeprintf("json_lexer $PARSEJSONNUM_CHK double number x=%g eatlen=%ld", x, $EATLEN);
3714 $VAL = meltgc_new_double((meltobject_ptr_t)
3715 MELT_PREDEF(DISCR_CONSTANT_DOUBLE),
3716 x) ;
3717 }
3718 /* json_lexer end $PARSEJSONNUM_CHK */
3719 }#)
3720 (debug "json_lexer number eatlen=" eatlen " val=" val)
3721 (when eatlen
3722 (strbuf_consume sbuf eatlen)
3723 (debug "json_lexer number val=" val)
3724 (return :number val))
3725 ))
3726 ;;
3727 ;; strings
3728 ((==i curch #\")
3729 (debug "json_lexer string start")
3730 ;; notice that this favors rather short strings. For very long
3731 ;; strings (e.g. megabyte-sized) which takes several calls to be
3732 ;; read, the meltgc_strbuf_json_string_peek function would be
3733 ;; called several times. Hopefully not a big deal in practice!
3734 (let ( (nstr ())
3735 (:long endoff 0)
3736 )
3737 (code_chunk peekjsonstr_chk
3738 #{ /* json_lexer $PEEKJSONSTR_CHK */
3739 int iend = 0 ;
3740 $NSTR = meltgc_strbuf_json_string_peek ($SBUF, 0, &iend) ;
3741 if ($NSTR)
3742 $ENDOFF = (long) iend ;
3743 }#)
3744 (debug "json_lexer string nstr=" nstr " endoff=" endoff)
3745 (when nstr
3746 (strbuf_consume sbuf endoff)
3747 (return :string nstr))
3748 )
3749 )
3750 ;;
3751 ;; special case for "null"
3752 ((and (==i curch #\n)
3753 (==i nextch #\u)
3754 (>i bulen 4)
3755 (==i (strbuf_peek sbuf 2) #\l)
3756 (==i (strbuf_peek sbuf 3) #\l)
3757 (let ( (:long c4 (strbuf_peek sbuf 4)) )
3758 (expr_chunk testc4null_chk :long
3759 #{/* json_lexer $TESTC4NULL_CHK */
3760 (!ISALNUM($C4) && $C4 != '_')}#)))
3761 (strbuf_consume sbuf 4)
3762 (debug "json_lexer null")
3763 (return :keyword :json_nil))
3764 ;;
3765 ;; special case for "true"
3766 ((and (==i curch #\t)
3767 (==i nextch #\r)
3768 (>i bulen 4)
3769 (==i (strbuf_peek sbuf 2) #\u)
3770 (==i (strbuf_peek sbuf 3) #\e)
3771 (let ( (:long c4 (strbuf_peek sbuf 4)) )
3772 (expr_chunk testc4true_chk :long
3773 #{/* json_lexer $TESTC4TRUE_CHK */
3774 (!ISALNUM($C4) && $C4 != '_')}#)))
3775 (strbuf_consume sbuf 4)
3776 (debug "json_lexer true")
3777 (return :keyword :true))
3778 ;;
3779 ;; special case for "false"
3780 ((and (==i curch #\f)
3781 (==i nextch #\a)
3782 (>i bulen 5)
3783 (==i (strbuf_peek sbuf 2) #\l)
3784 (==i (strbuf_peek sbuf 3) #\s)
3785 (==i (strbuf_peek sbuf 4) #\e)
3786 (let ( (:long c5 (strbuf_peek sbuf 5)) )
3787 (expr_chunk testc5false_chk :long
3788 #{/* json_lexer $TESTC5FALSE_CHK */
3789 (!ISALNUM($C5) && $C5 != '_')}#)))
3790 (strbuf_consume sbuf 5)
3791 (debug "json_lexer false")
3792 (return :keyword :json_false))
3793 ;;
3794 ;; keywords case, which we accept as an extension
3795 ((expr_chunk testalpha_chk :long
3796 #{/* json_lexer $TESTALPHA_CHK */
3797 (ISALPHA((char)$CURCH) || ($CURCH== '_')) }#)
3798 (let ( (nambuf (make_strbuf discr_strbuf))
3799 (:long ix 0)
3800 )
3801 (debug "json_lexer start keyword")
3802 (forever getalnumloop
3803 (if (>i ix bulen) (return))
3804 (let ( (:long curc (strbuf_peek sbuf ix)) )
3805 (if
3806 (expr_chunk
3807 testnotalnumu_chk :long
3808 #{/* json_lexer $TESTNOTALNUMU_CHK */
3809 (!(ISALNUM((char)$CURCH) || ($CURCH== '_'))) }#)
3810 (exit getalnumloop))
3811 (code_chunk addtoname_chk #{ /* json_lexer $ADDTONAME_CHK */
3812 char buf_$ADDTONAME_CHK[4] = {0,0,0,0} ;
3813 buf_$ADDTONAME_CHK[0] = (char) $CURCH ;
3814 meltgc_add_strbuf_raw_len($NAMBUF, buf_$ADDTONAME_CHK, 1) ;
3815 }#)
3816 )
3817 (setq ix (+i ix 1))
3818 )
3819 (let ( (namstr (strbuf2string discr_string nambuf))
3820 (namjson (mapstring_getstr json_name_dict namstr))
3821 (namsymb (get_symbolstr namstr))
3822 (namkeyw (get_keywordstr namstr))
3823 (name (or namjson namsymb namkeyw namstr))
3824 )
3825 (debug "json_lexer keyword name=" name)
3826 (return :keyword name)
3827 )
3828 )
3829 )
3830 ;;
3831 ;; otherwise error
3832 (:else
3833 (debug "json_lexer error sbuf=" sbuf)
3834 (return :error sbuf))
3835 )
3836 (debug "json_lexer fail")
3837 (return)
3838 )
3839 )
3840 )
3843 ;;;; the JSON parser stack is a list of tuples whose first element is
3844 ;;;; a MELT keyword.
3845 ;;;;
3846 ;;;; (:json_result <closure>) ;; to return a result via <closure>
3847 ;;;;
3848 ;;;; (:json_array <list-comp>) ;; when parsing array elements
3849 ;;;; (:json_array_next <list-comp>) ;; when parsing array comma or closing bracket
3851 ;;;; (:json_object_attr <list-attr> <list-val>) ;; when parsing object attribute
3852 ;;;; (:json_object_colon <list-attr> <list-val>) ;; when parsing object colon after attribute
3853 ;;;; (:json_object_val <list-attr> <list-val>) ;; when parsing object value
3854 ;;;; (:json_object_next <list-attr> <list-val>) ;; when parsing object comma or closing brace
3857 (defun json_state_accepting_jvalue (jstate)
3858 (match jstate
3859 (?(tuple :json_result ?_) (return :true))
3860 (?(tuple :json_array ?_) (return :true))
3861 (?(tuple :json_object_val ?_ ?_) (return :true))
3862 (?_ (return ()))))
3866 (defun make_json_parser (resclos errclos data)
3867 :doc #{$MAKE_JSON_PARSER create an initialized instance of
3868 $CLASS_JSON_PARSER with the given $RESCLOS closure getting the parsed
3869 JSON, the given $ERRCLOS handling errors, and some additional $DATA.}#
3870 (let ( (jp (instance class_json_parser
3871 :jsonparse_jdata data
3872 :jsonparse_stack (list (tuple :json_result resclos))
3873 :jsonparse_errorhandler errclos
3874 :jsonparse_counter (box 0)
3875 ))
3876 )
3877 (debug "make_json_parser jp=" jp)
3878 (return jp)
3879 ))
3881 ;; this can be passed to register_raw_input_channel_handler
3882 (defun json_parser_input_processor (inch arg)
3883 (debug "json_parser_input_processor inch=" inch " arg=" arg)
3884 (unless arg ;eof
3885 (return))
3886 (let ( (jparser (get_field :inch_data inch))
3887 (sbuf (get_field :inch_sbuf inch))
3888 (jstack (get_field :jsonparse_stack jparser))
3889 (jerror (get_field :jsonparse_errorhandler jparser))
3890 (jcountbox (get_field :jsonparse_counter jparser))
3891 (:long count 0)
3892 )
3893 (assert_msg "check jparser" (is_a jparser class_json_parser) jparser inch)
3894 (assert_msg "check inch" (is_a inch class_raw_input_channel_handler))
3895 (assert_msg "check sbuf" (is_strbuf sbuf))
3896 (assert_msg "check jstack" (is_list jstack))
3897 (assert_msg "check jcountbox" (is_integerbox jcountbox))
3898 (forever
3899 jsonparseloop
3900 (setq count (+i count 1))
3901 (debug "json_parser_input_processor parseloop start count=" count " sbuf=" sbuf
3902 " jparser=" jparser)
3903 (let ( (jtopstate (list_first_element jstack))
3904 )
3905 (multicall
3906 (kind detail)
3907 (json_lexer sbuf)
3908 (debug "json_parser_input_processor lexed kind=" kind
3909 ", detail=" detail "; jtopstate=" jtopstate "\n")
3910 (put_int jcountbox count)
3911 (match
3912 (tuple kind detail)
3913 (?(tuple :delim :left_brace)
3914 (debug "json_parser_input_processor got leftbrace")
3915 (cond
3916 ((json_state_accepting_jvalue jtopstate)
3917 (let ( (jnewstate (tuple :json_object_attr (list) (list)))
3918 )
3919 (list_prepend jstack jnewstate)
3920 (debug "json_parser_input_processor after leftbrace jnewstate=" jnewstate)
3921 ))
3922 (:else
3923 (jerror '"unexpected left brace")
3924 (return)))
3925 )
3926 (?(tuple :delim :right_brace)
3927 (debug "json_parser_input_processor got rightbrace")
3928 (match jtopstate
3929 (?(tuple :json_object_next ?atlist ?valist)
3930 (assert_msg "check atlist samelength valist"
3931 (==i (list_length atlist) (list_length valist)) jtopstate)
3932 (list_pop_first jstack)
3933 (debug "json_parser_input_processor rightbrace atlist=" atlist "; valist=" valist)
3934 (let ( (jsob (make_jsonobject discr_jsonobject atlist valist))
3935 (jprevstate (list_first_element jstack))
3936 )
3937 (debug "json_parser_input_processor made jsob=" jsob
3938 ", popped " jprevstate)
3939 (match jprevstate
3940 (?(tuple :json_result ?clores)
3941 (debug "json_parser_input_processor after jsob result clores=" clores)
3942 (assert_msg "check clores" (is_closure clores))
3943 (list_pop_first jstack)
3944 (clores jsob inch)
3945 (return)
3946 )
3947 (?(tuple :json_object_val ?atlist ?valist)
3948 (list_append valist jsob)
3949 (multiple_put_nth jprevstate 0 :json_object_next)
3950 (debug "json_parser_input_processor after jsob now jprevstate=" jprevstate)
3951 )
3952 (?(tuple :json_array ?complist)
3953 (list_append complist jsob)
3954 (multiple_put_nth jprevstate 0 :json_array_next)
3955 (debug "json_parser_input_processor after jsob now jprevstate=" jprevstate)
3956 )
3957 (?_
3958 (debug "json_parser_input_processor after jsob bad jprevstate=" jprevstate)
3959 (jerror '"unexpected object at right brace")
3960 (return))
3961 )
3962 ))
3963 (?_
3964 (debug "json_parser_input_processor bad rightbrace jtopstate=" jtopstate)
3965 (jerror '"unexpected right brace")
3966 (return)))
3967 )
3968 (?(tuple :delim :left_bracket)
3969 (debug "json_parser_input_processor got leftbracket")
3970 (cond
3971 ((json_state_accepting_jvalue jtopstate)
3972 (let ( (jnewstate (tuple :json_array (list)))
3973 )
3974 (list_prepend jstack jnewstate)
3975 (debug "json_parser_input_processor leftbracket pushed jnewstate=" jnewstate)
3976 ))
3977 (:else
3978 (debug "json_parser_input_processor leftbracket unhappy with jtopstate=" jtopstate)
3979 (jerror '"unexpected left bracket")
3980 (return)))
3981 )
3982 (?(tuple :delim :right_bracket)
3983 (debug "json_parser_input_processor got rightbracket")
3984 (match jtopstate
3985 (?(tuple :json_array_next ?complist)
3986 (list_pop_first jstack)
3987 (let ( (jsarray (list_to_multiple complist discr_jsonarray))
3988 (jprevstate (list_first_element jstack))
3989 )
3990 (debug "json_parser_input_processor made jsarray=" jsarray
3991 ", popped " jprevstate)
3992 (match jprevstate
3993 (?(tuple :json_result ?clores)
3994 (debug "json_parser_input_processor after array result clores=" clores)
3995 (assert_msg "check clores" (is_closure clores))
3996 (list_pop_first jstack)
3997 (clores jsarray inch)
3998 (return)
3999 )
4000 (?(tuple :json_object_val ?atlist ?valist)
4001 (list_append valist jsarray)
4002 (multiple_put_nth jprevstate 0 :json_object_next)
4003 (debug "json_parser_input_processor after array now jprevstate=" jprevstate)
4004 )
4005 (?(tuple :json_array ?complist)
4006 (list_append complist jsarray)
4007 (multiple_put_nth jprevstate 0 :json_array_next)
4008 (debug "json_parser_input_processor after array now jprevstate=" jprevstate)
4009 )
4010 (?_
4011 (debug "json_parser_input_processor after array bad jprevstate=" jprevstate)
4012 (jerror '"unexpected array at right bracket")
4013 (return))
4014 )
4015 ))
4016 (?_
4017 (debug "json_parser_input_processor unexpected right bracket")
4018 (jerror '"unexpected right bracket")
4019 (return))
4020 )
4021 )
4022 (?(tuple :delim :comma)
4023 (debug "json_parser_input_processor got comma")
4024 (match jtopstate
4025 (?(tuple :json_array_next ?clist)
4026 (multiple_put_nth jtopstate 0 :json_array)
4027 (debug "json_parser_input_processor comma updated jtopstate=" jtopstate)
4028 )
4029 (?(tuple :json_object_next ?atlist ?valist)
4030 (multiple_put_nth jtopstate 0 :json_object_attr)
4031 (debug "json_parser_input_processor comma updated jtopstate=" jtopstate)
4032 )
4033 (?_
4034 (debug "json_parser_input_processor unexpected comma jtopstate=" jtopstate
4035 "\n.. jparser=" jparser)
4036 (jerror '"unexpected comma")
4037 (return))
4038 )
4039 )
4040 (?(tuple :delim :colon)
4041 (debug "json_parser_input_processor got colon")
4042 (match jtopstate
4043 (?(tuple :json_object_colon ?atlist ?valist)
4044 (multiple_put_nth jtopstate 0 :json_object_val)
4045 (debug "json_parser_input_processor colon updated jtopstate=" jtopstate)
4046 )
4047 (?_
4048 (debug "json_parser_input_processor unexpected colon jtopstate=" jtopstate
4049 "\n.. jparser=" jparser)
4050 (jerror '"unexpected colon")
4051 (return))
4052 )
4053 )
4054 (?(tuple :string ?vstr)
4055 (debug "json_parser_input_processor got string vstr=" vstr)
4056 (match jtopstate
4057 (?(tuple :json_object_attr ?atlist ?valist)
4058 (list_append atlist vstr)
4059 (multiple_put_nth jtopstate 0 :json_object_colon)
4060 (debug "json_parser_input_processor after string now jtopstate=" jtopstate)
4061 )
4062 (?(tuple :json_object_val ?atlist ?valist)
4063 (list_append valist vstr)
4064 (multiple_put_nth jtopstate 0 :json_object_next)
4065 (debug "json_parser_input_processor after string now jtopstate=" jtopstate)
4066 )
4067 (?(tuple :json_result ?clores)
4068 (debug "json_parser_input_processor after string result clores=" clores)
4069 (assert_msg "check clores" (is_closure clores))
4070 (list_pop_first jstack)
4071 (clores vstr inch)
4072 (return)
4073 )
4074 (?(tuple :json_array ?complist)
4075 (list_append complist vstr)
4076 (multiple_put_nth jtopstate 0 :json_array_next)
4077 (debug "json_parser_input_processor after string now jtopstate=" jtopstate))
4078 (?_
4079 (debug "json_parser_input_processor after string bad jtopstate=" jtopstate)
4080 (jerror '"unexpected string")
4081 (return))
4082 )
4083 )
4084 (?(tuple :number ?vnum)
4085 (debug "json_parser_input_processor got number vnum=" vnum)
4086 (match jtopstate
4087 (?(tuple :json_result ?clores)
4088 (debug "json_parser_input_processor after number result clores=" clores)
4089 (assert_msg "check clores" (is_closure clores))
4090 (list_pop_first jstack)
4091 (clores vnum inch)
4092 (return)
4093 )
4094 (?(tuple :json_object_val ?atlist ?valist)
4095 (list_append valist vnum)
4096 (multiple_put_nth jtopstate 0 :json_object_next)
4097 (debug "json_parser_input_processor after number now jtopstate=" jtopstate)
4098 )
4099 (?(tuple :json_array ?complist)
4100 (list_append complist vnum)
4101 (multiple_put_nth jtopstate 0 :json_array_next)
4102 (debug "json_parser_input_processor after number now jtopstate=" jtopstate)
4103 )
4104 (?_
4105 (debug "json_parser_input_processor after number bad jtopstate=" jtopstate)
4106 (jerror '"unexpected number")
4107 (return))
4108 )
4109 )
4110 (?(tuple :keyword :json_nil)
4111 (debug "json_parser_input_processor got keyword null")
4112 (match jtopstate
4113 (?(tuple :json_object_val ?atlist ?valist)
4114 (list_append valist ())
4115 (multiple_put_nth jtopstate 0 :json_object_next)
4116 (debug "json_parser_input_processor after null now jtopstate=" jtopstate)
4117 )
4118 (?(tuple :json_array ?complist)
4119 (list_append complist ())
4120 (multiple_put_nth jtopstate 0 :json_array_next)
4121 (debug "json_parser_input_processor after null now jtopstate=" jtopstate)
4122 )
4123 (?_
4124 (debug "json_parser_input_processor after null bad jtopstate=" jtopstate "; jstack=" jstack)
4125 (jerror '"unexpected null")
4126 (return))
4127 )
4128 )
4129 (?(tuple :keyword :json_false)
4130 (debug "json_parser_input_processor got keyword false")
4131 (match jtopstate
4132 (?(tuple :json_object_val ?atlist ?valist)
4133 (list_append valist :json_false)
4134 (multiple_put_nth jtopstate 0 :json_object_next)
4135 (debug "json_parser_input_processor after false now jtopstate=" jtopstate)
4136 )
4137 (?(tuple :json_array ?complist)
4138 (list_append complist :json_false)
4139 (multiple_put_nth jtopstate 0 :json_array_next)
4140 (debug "json_parser_input_processor after false now jtopstate=" jtopstate)
4141 )
4142 (?_
4143 (debug "json_parser_input_processor after false bad jtopstate=" jtopstate)
4144 (jerror '"unexpected false")
4145 (return))
4146 )
4147 )
4148 (?(tuple :keyword :true)
4149 (debug "json_parser_input_processor got keyword true")
4150 (match jtopstate
4151 (?(tuple :json_object_val ?atlist ?valist)
4152 (list_append valist :true)
4153 (multiple_put_nth jtopstate 0 :json_object_next)
4154 (debug "json_parser_input_processor after true now jtopstate=" jtopstate)
4155 )
4156 (?(tuple :json_array ?complist)
4157 (list_append complist :json_false)
4158 (multiple_put_nth jtopstate 0 :json_array_next)
4159 (debug "json_parser_input_processor after true now jtopstate=" jtopstate)
4160 )
4161 (?_
4162 (debug "json_parser_input_processor after true bad jtopstate=" jtopstate)
4163 (jerror '"unexpected true")
4164 (return))
4165 )
4166 )
4167 (?(tuple :keyword ?kword)
4168 (debug "json_parser_input_processor got keyword kword=" kword)
4169 )
4170 (?(tuple () ())
4171 (debug "json_parser_input_processor got nothing")
4172 (exit jsonparseloop))
4173 (?_
4174 (debug "json_parser_input_processor unexpected kind=" kind " detail=" detail)
4175 (assert_msg "json_parser_input_processor unexpected kind" () kind detail))
4176 )
4177 )
4178 )
4179 ) ;end forever parseloop
4180 (debug "json_parser_input_processor ended")
4181 ))
4184 ;;;; make one single blocking JSONRPC2 call on TCP/IP transport, then
4185 ;;;; close the connection
4186 (defun do_blocking_jsonrpc2_call (server methodname jparams :long timeoutms)
4187 :doc #{$DO_BLOCKING_JSONRPC2_CALL makes a single JSONRPC2 remote
4188 procedure call with TCP transport to given $SERVER with given
4189 $METHODNAME and given JSON parameters $JPARAMS with a timeout of
4190 $TIMEOUTMS milliseconds, at least 50 milliseconds, then close the
4191 connection. On success the JSON result is given, and secondarily the
4192 strictly positive time, in milliseconds, needed to make the JSONRPC
4193 request. On failure, a warning is given, and nil is returned without
4194 any secondary result.}#
4195 (debug "do_blocking_jsonrpc2_call server=" server
4196 " methodname=" methodname ", jparams=" jparams
4197 "\n.. timeoutms=" timeoutms)
4198 (when
4199 (<i timeoutms 50)
4200 (setq timeoutms 50)
4201 (debug "do_blocking_jsonrpc2_call forced timeoutms=" timeoutms)
4202 )
4203 (let (
4204 (randidstr
4205 ( let ( (idstr ())
4206 )
4207 (code_chunk
4208 makerandidstr_chk
4209 #{ /* do_blocking_jsonrpc2_call $MAKERANDIDSTR_CHK */
4210 static long cumcallcount;
4211 char buf[40];
4212 cumcallcount++;
4213 snprintf(buf, sizeof(buf), "C%lxP%dR%xT%ld",
4214 cumcallcount, (int)getpid(),
4215 (int)(melt_lrand() % 65536), melt_relative_time_millisec());
4216 $IDSTR = meltgc_new_string((meltobject_ptr_t)MELT_PREDEF(DISCR_STRING), buf);
4217 }#)
4218 (debug "do_blocking_jsonrpc2_call randidstr=" idstr)
4219 idstr))
4220 (service (connect_to_server server))
4221 (jreq (make_jsonobject discr_jsonobject
4222 'jsonrpc '"2.0"
4223 'method methodname
4224 'id randidstr
4225 'params jparams))
4226 )
4227 (debug "do_blocking_jsonrpc2_call service=" service " jreq=" jreq)
4228 (unless (is_integerbox service)
4229 (warning_at () "do_blocking_jsonrpc2_call failure server=$1 method=$2 connection failed"
4230 server methodname)
4231 (return))
4232 (let (
4233 (:long servfd (get_int service))
4234 (servout ())
4235 )
4236 (code_chunk
4237 makesockfile_chk
4238 #{ /* do_blocking_jsonrpc2_call $MAKESOCKFILE_CHK */
4239 FILE* sockfil = fdopen((int)$SERVFD, "w+");
4240 if (!sockfil) {
4241 warning(0, "MELT do_blocking_jsonrpc2_call failed to fdopen #%d",
4242 (int)$SERVFD);
4243 (void) close((int)$SERVFD);
4244 $(ignore (return));
4245 }
4246 $SERVOUT = meltgc_new_file($DISCR_RAWFILE, sockfil); ;
4247 }#)
4248 (debug "do_blocking_jsonrpc2_call servout=" servout " jreq=" jreq
4249 " outputtingjson="
4250 (let ( (sbuf (make_strbuf discr_strbuf)) )
4251 (output_json sbuf jreq)
4252 (strbuf2string discr_string sbuf)))
4253 (output_json servout jreq)
4254 (code_chunk
4255 flushsockfile_chk
4256 #{ /* do_blocking_jsonrpc2_call $FLUSHSOCKFILE_CHK */
4257 melt_newlineflush (melt_get_file($SERVOUT));
4258 $(debug "do_blocking_jsonrpc2_call flusshed servout=" servout)
4259 }#)
4260 (let (
4261 (:long begtime (relative_time_millisec))
4262 (:long loopcount 0)
4263 (gotreply (reference ()))
4264 (goterror (reference ()))
4265 (replyref (reference ()))
4266 (jreplyhandler
4267 (lambda (jrepl)
4268 (debug "blockjsonrpcreply jrepl=" jrepl)
4269 (set_ref replyref jrepl)
4270 (set_ref gotreply :true)
4271 ))
4272 (jerrorhandler
4273 (lambda (jerror)
4274 (debug "blockjsonrpcerror jerror=" jerror)
4275 (assert_msg "blockjsonrpcerror check jerror" jerror)
4276 (set_ref goterror jerror)
4277 ))
4278 (jparser (make_json_parser jreplyhandler jerrorhandler
4279 (tuple servout (constant_box servfd))))
4280 )
4281 (debug "do_blocking_jsonrpc2_call jparser=" jparser "; begtime=" begtime)
4282 (register_raw_input_channel_handler json_parser_input_processor
4283 jparser
4284 servfd)
4285 (forever pollingloop
4286 (setq loopcount (+i loopcount 1))
4287 (debug "do_blocking_jsonrpc2_call loopcount=" loopcount)
4288 (hook_poll_inputs (if (>i timeoutms 300) (+i 30 (/i timeoutms 3)) timeoutms))
4289 (debug "do_blocking_jsonrpc2_call after timeoutms=" timeoutms
4290 " elapsed " (-i (relative_time_millisec) begtime)
4291 " ms; gotreply=" gotreply " goterror=" goterror)
4292 (cond ( !gotreply
4293 (debug "do_blocking_jsonrpc2_call gotreply replyref=" replyref)
4294 (exit pollingloop)
4295 )
4296 ( !goterror
4297 (debug "do_blocking_jsonrpc2_call goterror=" goterror)
4298 (warning_at () "do_blocking_jsonrpc2_call error $1 on method $2 to server $3"
4299 !goterror methodname server)
4300 (exit pollingloop)
4301 )
4302 ( (>=i (-i (relative_time_millisec) begtime) timeoutms)
4303 (debug "do_blocking_jsonrpc2_call timedout " timeoutms)
4304 (warning_at () "do_blocking_jsonrpc2_call timedout $1 milliseconds on method $2 to server $3"
4305 timeoutms methodname server)
4306 (exit pollingloop)
4307 )
4308 (:else
4309 (debug "do_blocking_jsonrpc2_call again loopcount=" loopcount)
4310 (again pollingloop))))
4311 (debug "do_blocking_jsonrpc2_call after pollingloop loopcount=" loopcount " gotreply=" gotreply
4312 " goterror=" goterror " replyref=" replyref)
4313 (code_chunk afterpoll_chk
4314 #{ /* do_blocking_jsonrpc2_call $AFTERPOLL_CHK */
4315 if (shutdown ($SERVFD, SHUT_RDWR))
4316 warning(0, "MELT do_blocking_jsonrpc2_call shutdown failed: %s",
4317 xstrerror(errno));
4318 melt_close_file($SERVOUT);
4319 }#)
4320 (unregister_input_channel (constant_box servfd))
4321 (when !gotreply
4322 (let ( (jreply !replyref)
4323 (jid (jsonobject_get_named jreply 'id))
4324 (jres (jsonobject_get_named jreply 'result))
4325 (jerr (jsonobject_get_named jreply 'error))
4326 (:long endtime (relative_time_millisec))
4327 )
4328 (debug "do_blocking_jsonrpc2_call got jreply=" jreply "; jid=" jid
4329 " jres=" jres " jerr=" jerr)
4330 (assert_msg "check jreply" (is_jsonobject jreply))
4331 (cond
4332 ( (!=s jid randidstr)
4333 (warning_at ()
4334 "do_blocking_jsonrpc2_call sent id $1 but got reply with id $2 for method $3 to server $4"
4335 randidstr jid methodname server)
4336 (return ()))
4337 ( jerr
4338 (warning_at ()
4339 "do_blocking_jsonrpc2_call failed for method $1 to server $2 : got error $3"
4340 methodname server jerr)
4341 (return ()))
4342 (:else
4343 (let ( (:long reqtime (-i endtime begtime)) )
4344 (if (<=i reqtime 0) (setq reqtime 1))
4345 (debug "do_blocking_jsonrpc2_call gives jres=" jres
4346 "; reqtime=" reqtime)
4347 (return jres reqtime)))
4348 )
4349 ))))))
4351 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4352 ;; the sigio handler, called from safe places
4353 (defhook hook_handle_sigio
4354 () ()
4355 :void
4356 :predef HOOK_HANDLE_SIGIO
4357 (hook_poll_inputs 250)
4358 )
4360 (export_values
4361 connect_to_server
4362 do_blocking_jsonrpc2_call
4363 every_polling_input
4364 get_polling_input
4365 hook_handle_sigio
4366 hook_poll_inputs
4367 is_polling_inputs
4368 json_parser_input_processor
4369 make_json_parser
4370 melt_invoke_input_callbacks
4371 )
4377 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4378 (defvar melt_alarmbucket)
4380 ;; the sigalarm handler, called from safe places
4381 (defhook hook_handle_sigalrm
4382 () ()
4383 :void
4384 :predef HOOK_HANDLE_SIGALRM
4385 (let ( (alarmbuck melt_alarmbucket)
4386 (:long cureltim (relative_time_millisec))
4387 )
4388 (debug "hook_handle_sigalrm start alarmbuck=" alarmbuck " cureltim=" cureltim)
4389 (unless alarmbuck (return))
4390 ;;
4391 (forever
4392 handleloop
4393 (assert_msg "check alarmbuck" (is_bucketlong alarmbuck) alarmbuck)
4394 (unless (bucketlong_count alarmbuck) (exit handleloop))
4395 (let ( (:long nextim (bucketlong_nth_key alarmbuck 0))
4396 (nextalhd (bucketlong_nth_val alarmbuck 0))
4397 )
4398 (debug "hook_handle_sigalrm nextim=" nextim " nextalhd=" nextalhd)
4399 (unless nextim (exit handleloop))
4400 (unless (>i nextim cureltim) (exit handleloop))
4401 (assert_msg "check mextalhd" (is_a nextalhd class_alarm_handler) nextalhd)
4402 (setq alarmbuck (bucketlong_remove alarmbuck nextim))
4403 (block_signals
4404 () ()
4405 (let ( (clos (get_field :alarmh_clos nextalhd))
4406 )
4407 (if (is_closure clos)
4408 (let ( (res (clos nextalhd))
4409 )
4410 (if res
4411 (let ( (:long newperiod (get_int (get_field :alarmh_period nextalhd)))
4412 )
4413 (if (>i newperiod 10)
4414 (setq alarmbuck
4415 (bucketlong_put alarmbuck
4416 (+i newperiod cureltim) nextalhd)))))))))
4417 )) ;end handleloop
4418 ;;
4419 (setq melt_alarmbucket alarmbuck)
4420 (let ( (:long nowtim (relative_time_millisec))
4421 (:long nextalarm (bucketlong_nth_key alarmbuck 0))
4422 )
4423 (cond ( (>i nextalarm nowtim)
4424 ;; set alarm to next time
4425 (set_real_timer_millisec (-i nextalarm nowtim)))
4426 ( (>i nextalarm 0)
4427 ;; missed time, set a quick alarm
4428 (set_real_timer_millisec 30))
4429 ( :else
4430 ;; no more alarm
4431 (set_real_timer_millisec 0))
4432 )
4433 )))
4436 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4437 ;; alarm processing need a sorted bucket of timeouts -> alarm-handlers
4439 (defun register_alarm_timer (clos :long periodms :value data)
4440 :doc #{$REGISTER_ALARM_TIMER is the low level function to register
4441 the closure $CLOS to be called periodically with a period of $PERIODMS
4442 -at least 50- milliseconds and some client $DATA. The closure should
4443 return non-nil for the alarm to be repeated. $REGISTER_ALARM_TIMER
4444 returns a timer object, usable for $UNREGISTER_ALARM_TIMER.}#
4445 (debug "register_alarm_timer clos=" clos " periodms=" periodms)
4446 (if (is_closure clos)
4447 (if (>=i periodms 50)
4448 (let ( (res ())
4449 )
4450 (block_signals
4451 () ()
4452 (let ( (periodbox (make_integerbox discr_constant_integer periodms))
4453 (oldbuck (or melt_alarmbucket (make_bucketlong discr_bucket_longs 31)))
4454 (alhd (instance class_alarm_handler
4455 :alarmh_period periodbox
4456 :alarmh_clos clos
4457 :alarmh_data data))
4458 (:long cureltim (relative_time_millisec))
4459 (:long nextim (+i cureltim periodms))
4460 (newbuck (bucketlong_put oldbuck nextim alhd))
4461 (:long firstkey (bucketlong_nth_key newbuck 0))
4462 (:long firstdelay (if firstkey (-i firstkey cureltim)))
4463 )
4464 (setq melt_alarmbucket newbuck)
4465 (set_real_timer_millisec firstdelay)
4466 (setq res alhd)))
4467 (return res)
4468 ))))
4471 (defun unregister_alarm_timer (tim)
4472 :doc #{Unregister a timer obtained by $REGISTER_ALARM_TIMER.}#
4473 (debug "unregister_alarm_timer tim=" tim)
4474 (unless tim (return))
4475 (unless (is_not_a tim class_alarm_handler)
4476 (assert_msg "check tim" (is_a tim class_alarm_handler) tim)
4477 (return))
4478 (block_signals
4479 () ()
4480 (let ( (oldbuck melt_alarmbucket)
4481 (:long oldbucklen (bucketlong_count oldbuck))
4482 (newbuck (make_bucketlong discr_bucket_longs oldbucklen))
4483 )
4484 (unless oldbucklen
4485 ;; no more alarms
4486 (setq melt_alarmbucket ())
4487 (set_real_timer_millisec 0)
4488 (return))
4489 (foreach_in_bucketlong
4490 (oldbuck)
4491 (:long oldkey :value oldala)
4492 (assert_msg "check oldala" (is_a oldala class_alarm_handler) oldala)
4493 (unless (== oldala tim)
4494 (setq newbuck (bucketlong_put newbuck oldkey oldala))
4495 ))
4496 (setq melt_alarmbucket newbuck)
4497 )
4498 ))
4500 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4501 (defvar melt_childbuck) ;; contain the bucket from childpid to handlers
4502 ;; the sigchld handler, called from safe places
4503 (defhook hook_handle_sigchld
4504 () ()
4505 :void
4506 :predef HOOK_HANDLE_SIGCHLD
4507 (debug "hook_handle_sigchld melt_childbuck=" melt_childbuck)
4508 (let ( (lischph (make_list discr_list))
4509 (liswstat (make_list discr_list))
4510 (buck melt_childbuck)
4511 )
4512 (unless (is_bucketlong buck) (return))
4513 (block_signals
4514 () ()
4515 (let ( (:long waitfail 0)
4516 (:long pidstat 0)
4517 )
4518 (unless waitfail
4519 (debug "hook_handle_sigchld waited for probe")
4520 (return))
4521 (foreach_in_bucketlong
4522 (buck)
4523 (:long keypid :value chph)
4524 (assert_msg "check chph" (is_a chph class_child_process_handler) chph)
4525 (assert_msg "check pid"
4526 (==i keypid (get_int (get_field :chilproh_pid chph))) keypid chph)
4527 (code_chunk
4528 waitpidchk
4529 #{ /* hook_handle_sigchld $WAITPIDCHK */ {
4530 pid_t wpid = 0 ;
4531 int pstatus = 0 ;
4532 $WAITFAIL = 0L ;
4533 $PIDSTAT = 0L ;
4534 wpid = waitpid ((pid_t) $KEYPID, &pstatus, WNOHANG) ;
4535 $WAITFAIL = (wpid != (pid_t) $KEYPID) ;
4536 if (!$WAITFAIL)
4537 $PIDSTAT = pstatus ;
4538 } /* hook_handle_sigchld end $WAITPIDCHK */ }#)
4539 (unless waitfail
4540 (list_append lischph chph)
4541 (list_append liswstat (make_integerbox discr_constant_integer pidstat)))
4542 )
4543 )
4544 )
4545 (let ( (tupchph (list_to_multiple lischph discr_multiple))
4546 (tupwstat (list_to_multiple liswstat discr_multiple))
4547 )
4548 (foreach_in_multiple
4549 (tupchph)
4550 (curchph :long ix)
4551 (let ( (:long curwstat (get_int (multiple_nth tupwstat ix)))
4552 (:long curpid (get_int (get_field :chilproh_pid curchph)))
4553 (curclos (get_field :chilproh_clos curchph))
4554 (:long exited 0)
4555 (:long exitstat 0)
4556 (:long signaled 0)
4557 (:long termsig 0)
4558 (:value termsigname ())
4559 )
4560 (debug "hook_handle_sigchld curchph=" curchph
4561 " curwstat=" curwstat " ix=" ix)
4562 (block_signals
4563 () ()
4564 (let ( (cbuck melt_childbuck)
4565 )
4566 (setq cbuck (bucketlong_remove cbuck curpid))
4567 (setq melt_childbuck cbuck)
4568 ))
4569 (code_chunk
4570 lookwstatchk
4571 #{ /* hook_handle_sigchld $LOOKWSTATCHK */ {
4572 int wstat = (int) $CURWSTAT ;
4573 if (WIFEXITED(wstat)) {
4574 $EXITED = 1 ;
4575 $EXITSTAT = WEXITSTATUS (wstat) ;
4576 }
4577 else if (WIFSIGNALED(wstat)) {
4578 $SIGNALED = 1 ;
4579 $TERMSIG = WTERMSIG (wstat) ;
4580 $TERMSIGNAME = meltgc_new_string
4581 ((meltobject_ptr_t) MELT_PREDEF(DISCR_STRING),
4582 strsignal($TERMSIG)) ;
4583 }
4584 } /* end hook_handle_sigchld $LOOKWSTATCHK */ }#)
4585 ;;
4586 (block_signals
4587 () ()
4588 (cond
4589 (exited
4590 (cond
4591 ( (==i exitstat 0)
4592 ;; successful exit
4593 (debug "hook_handle_sigchld successful curchph="
4594 curchph)
4595 (curclos curchph ())
4596 )
4597 ( :else
4598 ;; failed exit
4599 (debug "hook_handle_sigchld failed curchph="
4600 curchph " exitstat=" exitstat)
4601 (curclos curchph
4602 (make_integerbox discr_constant_integer exitstat))
4603 )
4604 ))
4605 (signaled
4606 (debug "hook_handle_sigchld signaled curchph="
4607 curchph " termsigname=" termsigname)
4608 (curclos curchph termsigname))
4609 )))))))
4612 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4614 (defun register_child_process_handler (clos :long pid :value data)
4615 :doc #{$REGISTER_CHILD_PROCESS_HANDLER is the low level function to
4616 register a handler of closure $CLOS for termination of process $PID
4617 with extra $DATA. The $CLOS would be applied to the returned child}#
4618 (debug "register_child_process_handler clos=" clos " pid=" pid " data=" data)
4619 (if (is_closure clos)
4620 (if (>i pid 0)
4621 (let ( (:long pidisbad 0)
4622 )
4623 (code_chunk
4624 trykillchk
4625 #{/* register_child_process_handler $TRYKILLCHK */
4626 if (kill ((pid_t) $PID, 0))
4627 $PIDISBAD = -1L ;
4628 }#)
4629 (debug "register_child_process_handler pidisbad=" pidisbad)
4630 (if pidisbad (return))
4631 (let ( (chph (instance
4632 class_child_process_handler
4633 :chilproh_pid (make_integerbox discr_constant_integer pid)
4634 :chilproh_clos clos
4635 :chilproh_data data))
4636 )
4637 (debug "register_child_process_handler chph=" chph)
4638 (block_signals
4639 () ()
4640 (let ( (buck (or melt_childbuck
4641 (make_bucketlong discr_bucket_longs 13)))
4642 )
4643 (assert_msg "check buck" (is_bucketlong buck) buck)
4644 (setq buck (bucketlong_put buck pid chph))
4645 (setq melt_childbuck buck)
4646 )
4647 )
4648 (return chph)
4649 )))))
4653 (defun unregister_child_process_handler (chd)
4654 :doc #{Unregister a child process handler obtained by $REGISTER_CHILD_PROCESS_HANDLER @b{**unimplemented**}}#
4655 (debug "unregister_child_process_handler chd=" chd)
4656 (assert_msg "@$@unimplemented unregister_child_process_handler")
4657 )
4659 (export_values
4660 register_alarm_timer
4661 register_child_process_handler
4662 register_paragraph_input_channel_handler
4663 register_raw_input_channel_handler
4664 unregister_input_channel
4665 unregister_alarm_timer
4666 unregister_child_process_handler
4667 )
4669 (export_synonym register_input_channel_handler register_paragraph_input_channel_handler)
4671 ;; eof warmelt-hooks.melt