| blob | 564e170791bfa9c639df37aee85211aab42e8238 |
1 ;; -*- Lisp -*-
2 ;; file warmelt-debug.melt
3 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4 (comment "***
5 Copyright 2009 - 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-debug.melt and to
26 ;; the generated file warmelt-debug*.c; while the file was created in
27 ;; 2010, most of its content (coming from warmelt-first.melt) has been
28 ;; written before.
29 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
32 ;; This MELT module is GPL compatible since it is GPLv3+ licensed.
33 (module_is_gpl_compatible "GPLv3+")
36 ;; This file is part of a bootstrapping compiler for the
37 ;; MELT lisp dialect, compiler which should be able to
38 ;; compile itself (into generated C file[s])
39 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
41 ;; class for debug information (used for debug_msg & dbgout* stuff)
42 (defclass class_debug_information
43 :super class_root
44 :fields (dbgi_out ;the produced outbuf
45 dbgi_occmap ;the occurrence map (to avoid outputing twice the same object)
46 dbgi_maxdepth ;the boxed integer maximal depth
47 )
48 :doc #{The $CLASS_DEBUG_INFORMATION is for debug information output,
49 e.g. $DEBUG_MSG macro. The produced output or buffer is $DBGI_OUT,
50 the occurrence map is $DBGI_OCCMAP, used to avoid outputting twice the
51 same object. The boxed maximal depth is $DBGI_MAXDEPTH.}# )
53 (defclass class_debug_output_information
54 :doc #{The $CLASS_DEBUG_OUTPUT_INFORMATION is for debug output,
55 which happens even when debug printing is not enabled by a program
56 argument like @code{-f[plugin-arg-]melt-debugging}.}#
57 :super class_debug_information
58 :fields (
59 ))
61 (export_class class_debug_information class_debug_output_information)
63 ;;;;;;
64 (defprimitive debug_depth () :long
65 :doc #{The default MELT debug depth, as passed by -fmelt-debug-depth
66 or -fplugin-arg-melt-debug-depth program argument.}#
67 #{(long) (melt_debug_depth ())}#)
69 ;;; primitives to test for debug needs. We cannot use
70 ;;; melt_need_debug because it would be optimized out as 0 when this
71 ;;; warmelt-debug module is compiled in optimized flavor
72 (defprimitive melt_really_need_debug (:long depth) :long
73 :doc #{Test if debug is needed, even in optimized flavor. See
74 $MELT_NEED_DBG}#
75 #{/*MELT_REALLY_NEED_DEBUG*/ (melt_need_debug ((int) $DEPTH))}#)
77 (defprimitive melt_has_flag_debug_set () :long
78 #{/*MELT_HAS_FLAG_DEBUG_SET*/ melt_flag_debug}#)
80 (defprimitive melt_really_need_dbglim (:long depth limit) :long
81 :doc #{Test if debug is needed with limits, even in optimized flavor.
82 See $MELT_NEED_DBGLIM.}#
83 #{( /*MELT_REALLY_NEED_DBGLIM*/ melt_need_debug_limit ((int) $DEPTH, (int) $LIMIT))}#)
85 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
87 ;;; selector to output for debugging
88 ;;; receiver: any object or value
89 ;;; arguments: the debuginfo (instance of class_debug_information), the depth (long)
90 (defselector dbg_output class_selector
91 :formals (recv dbginfo :long depth)
92 :doc #{Selector for debug output. Output for debugging the $RECV into $DBGINFO (of $CLASS_DEBUG_INFORMATION) at given $DEPTH.}#
93 )
96 ;;; selector to output again for debugging
97 ;;; receiver: any object (already output)
98 ;;; arguments: the debuginfo (instance of class_debug_information), the depth (long)
99 (defselector dbg_outputagain class_selector
100 :formals (recv dbginfo :long depth)
101 :doc #{Selector for debug output again, used to output a value
102 already encountered. Output again for debugging the $RECV into
103 $DBGINFO (of $CLASS_DEBUG_INFORMATION) at given $DEPTH.}# )
106 ;;;;
109 ;; hook to support debug of :tree-s
110 (definstance tree_debug_funcont class_reference)
111 (defun register_tree_debug_fun (f)
112 :doc #{Register a function for $DEBUG output of :tree-s. The first
113 argument to the registered function is an instance of
114 $CLASS_DEBUG_INFORMATION. The second argument is the raw :tree
115 stuff. Returns the previously registered function.}#
116 (let ( (oldcont !tree_debug_funcont)
117 )
118 (if (or (null f) (is_closure f))
119 (set_ref tree_debug_funcont f))
120 oldcont))
122 ;; hook to support debug of :gimple-s
123 (definstance gimple_debug_funcont class_reference)
124 (defun register_gimple_debug_fun (f)
125 :doc #{Register a function for $DEBUG output of :gimple-s. The first
126 argument to the registered function is an instance of
127 $CLASS_DEBUG_INFORMATION. The second argument is the raw :gimple
128 stuff. Returns the previously registered function.}#
129 (let ( (oldcont !gimple_debug_funcont)
130 )
131 (if (or (null f) (is_closure f))
132 (set_ref gimple_debug_funcont f))
133 oldcont))
135 ;; hook to support debug of :gimple_seq-s
136 (definstance gimpleseq_debug_funcont class_reference)
137 (defun register_gimpleseq_debug_fun (f)
138 :doc #{Register a function for $DEBUG output of :gimple_seq-s. The first
139 argument to the registered function is an instance of
140 $CLASS_DEBUG_INFORMATION. The second argument is the raw :gimple_seq
141 stuff. Returns the previously registered function.}#
142 (let ( (oldcont !gimpleseq_debug_funcont)
143 )
144 (if (or (null f) (is_closure f))
145 (set_ref gimpleseq_debug_funcont f))
146 oldcont))
148 ;; hook to support debug of :edge-s
149 (definstance edge_debug_funcont class_reference)
150 (defun register_edge_debug_fun (f)
151 :doc #{Register a function for $DEBUG output of :edge-s. The first
152 argument to the registered function is an instance of
153 $CLASS_DEBUG_INFORMATION. The second argument is the raw :edge
154 stuff. Returns the previously registered function.}#
155 (let ( (oldcont !edge_debug_funcont)
156 )
157 (if (or (null f) (is_closure f))
158 (set_ref edge_debug_funcont f))
159 oldcont))
161 ;; hook to support debug of :basic_block-s
162 (definstance basicblock_debug_funcont class_reference)
163 (defun register_basicblock_debug_fun (f)
164 :doc #{Register a function for $DEBUG output of :basic_block-s. The first
165 argument to the registered function is an instance of
166 $CLASS_DEBUG_INFORMATION. The second argument is the raw :basic_block
167 stuff. Returns the previously registered function.}#
168 (let ( (oldcont !basicblock_debug_funcont)
169 )
170 (if (or (null f) (is_closure f))
171 (set_ref basicblock_debug_funcont f))
172 oldcont))
174 ;; hook to support debug of :loop-s
175 (definstance loop_debug_funcont class_reference)
176 (defun register_loop_debug_fun (f)
177 :doc #{Register a function for $DEBUG output of :loop-s. The first
178 argument to the registered function is an instance of
179 $CLASS_DEBUG_INFORMATION. The second argument is the raw :loop
180 stuff. Returns the previously registered function.}#
181 (let ( (oldcont !loop_debug_funcont)
182 )
183 (if (or (null f) (is_closure f))
184 (set_ref loop_debug_funcont f))
185 oldcont))
187 ;;; the discriminant for debug closures
188 (definstance discr_debug_closure class_discriminant
189 :doc #{The $DISCR_DEBUG_CLOSURE is the discriminant of MELT debug
190 functions. Use $CLONE_WITH_DISCRIMINANT on a closure, e.g. with
191 $LAMBDA, to make it a debug function.}#
192 :obj_num MELTOBMAG_CLOSURE
193 :disc_super discr_closure
194 :named_name '"DISCR_DEBUG_CLOSURE")
197 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
198 ;;; the melt_debug_fun is usually called thru the debug macro, or via hook_low_level_debug_at
199 (defun melt_debug_fun (nothing :long count :cstring filename :long lineno :rest)
200 (if (melt_has_flag_debug_set)
201 (let ( (:long dbgcounter 0)
202 (dumpf (get_field :sysdata_dumpfile initial_system_data))
203 (stderrf (get_field :sysdata_stderr initial_system_data))
204 (out dumpf)
205 (occmap (make_mapobject discr_map_objects 50))
206 (boxedmaxdepth (make_integerbox discr_integer (debug_depth))) ;;;; @@@ DEBUGDEPTH
207 )
208 (code_chunk
209 getdbgcounter
210 #{/* melt_debug_fun $GETDBGCOUNTER*/ $DBGCOUNTER = melt_dbgcounter ;
211 }#)
212 ;; if we don't have a dumpfile, use stderr; this may also
213 ;; happens when the dumpf exists, but its dump_file is null.
214 (code_chunk
215 ensuregoodout_chk #{/* melt_debug_fun $ENSUREGOODOUT_CHK*/ {
216 static int nbwarn ;
217 if (melt_get_file ((melt_ptr_t) $OUT) == NULL) {
218 gcc_assert (melt_get_file ((melt_ptr_t) $STDERRF) == stderr) ;
219 $OUT = $STDERRF ;
220 if (nbwarn++ <= 0) {
221 inform (UNKNOWN_LOCATION,
222 "MELT debug output goes to stderr because we have no dump_file.") ;
223 }
224 }
225 } /* end melt_debug_fun $ENSUREGOODOUT_CHK*/ }#)
226 (if (null out)
227 (setq out stderrf))
228 ;; it may happen that OUT is null, e.g. because the dumpfile &
229 ;; the stderr are not yet initialized in
230 ;; initial_system_data...
231 (if (null out)
232 (setq out (make_strbuf discr_strbuf)))
233 (assert_msg "check good out" (is_out out) out)
234 (assert_msg "check boxedmaxdepth" (>i (get_int boxedmaxdepth) 1) boxedmaxdepth)
235 ;; we don't want signals to happen during debugging output
236 (block_signals
237 ()
238 ()
239 (let (
240 (dbgi (instance class_debug_information
241 :dbgi_out out
242 :dbgi_occmap occmap
243 :dbgi_maxdepth boxedmaxdepth))
244 (:long framdepth (the_framedepth))
245 (:long outlen (output_length out))
246 (:long laststroutlen outlen)
247 (:long initoutlen outlen)
248 )
249 (when (not (%iraw dbgcounter 512))
250 (code_chunk
251 gettime_chk
252 #{ /* melt_debug_fun $GETTIME_CHK start */
253 char $GETTIME_CHK#timbuf[32];
254 static char $GETTIME_CHK#buf[64];
255 time_t $GETTIME_CHK#now = 0;
256 time (& $GETTIME_CHK#now);
257 strftime ($GETTIME_CHK#timbuf, sizeof($GETTIME_CHK#timbuf),
258 "%T", localtime(& $GETTIME_CHK#now));
259 snprintf ($GETTIME_CHK#buf, sizeof($GETTIME_CHK#buf),
260 "%s, %.3f cpu, %.3f real sec.",
261 $GETTIME_CHK#timbuf, clock() * 1.0e-6,
262 (double) melt_relative_time_millisec() * 1.0e-3);
263 $(progn
264 (add2out out "\n!!!!++++++++@~.@~.@~.@~.@~.@~.@~.@~. " (expr_chunk
265 timestr_chk :cstring
266 #{ /*melt_debug_fun $TIMESTR_CHK*/
267 $GETTIME_CHK#buf }#)
268 "\n")
269 (void))
270 /* melt_debug_fun $GETTIME_CHK end */
271 }#))
272 (add2out out "!!!!****####" dbgcounter "#^" (-i framdepth 1) ":")
273 (if filename
274 (add2out out filename ":" lineno ":"))
275 (when (>i count 0)
276 (add2out out " !" count ": "))
277 ;; loop on variadic arguments
278 (forever
279 argloop
280 (variadic
281 ( ()
282 (exit argloop))
283 ( (:long l)
284 (add2out_longdec out l))
285 ( (:cstring s)
286 (let ( (:long curoutlen (output_length out))
287 )
288 (match s
289 ( ?(cstring_prefixed " ")
290 (if (>i curoutlen (+i laststroutlen 70))
291 (add2out_indentnl out 0)))
292 ( ?_ (void)))
293 )
294 (setq laststroutlen (output_length out))
295 (add2out_strconst out s)
296 )
297 ( (:value val)
298 (add2out_strconst out " ")
299 (cond
300 ( (null val)
301 (add2out_strconst out "(**nil**)"))
302 ( (== (discrim val) discr_debug_closure)
303 (variadic
304 ( ()
305 ;; if a debug closure is the last variadic, we
306 ;; output it as an ordinary value
307 (dbg_out val dbgi 0)
308 )
309 ( (:value vv)
310 (val dbgi vv))
311 ( (:long ll)
312 (val dbgi ll))
313 ( (:tree tt)
314 (val dbgi tt))
315 ( (:gimple g)
316 (val dbgi g))
317 ( (:gimple_seq xgs)
318 (val dbgi xgs))
319 ( (:edge xed)
320 (val dbgi xed))
321 ( (:loop xlo)
322 (val dbgi xlo))
323 )
324 (void)
325 )
326 (:else ;; plain case of some value
327 (dbg_out val dbgi 0)
328 (void)
329 )))
330 ( (:tree tr)
331 (let ( (tdf !tree_debug_funcont)
332 )
333 (if (is_closure tdf)
334 (tdf dbgi tr)
335 (if tr
336 (add2out_strconst out " ?*tree*?")
337 (add2out_strconst out " ?*nulltree*?")))))
338 ( (:gimple gi)
339 (let ( (gdf !gimple_debug_funcont)
340 )
341 (if (is_closure gdf)
342 (gdf dbgi gi)
343 (if gi
344 (add2out_strconst out " ?*gimple*?")
345 (add2out_strconst out " ?*nullgimple*?")))))
346 ( (:gimple_seq gs)
347 (let ( (gsdf !gimpleseq_debug_funcont)
348 )
349 (if (is_closure gsdf)
350 (gsdf dbgi gs)
351 (if gs
352 (add2out_strconst out " ?*gimpleseq*?")
353 (add2out_strconst out " ?*nullgimpleseq*?")))))
354 ( (:edge ed)
355 (let ( (edf !edge_debug_funcont)
356 )
357 (if (is_closure edf)
358 (edf dbgi ed)
359 (if ed
360 (add2out_strconst out " ?*edge*?")
361 (add2out_strconst out " ?*nulledge*?")))))
362 ( (:basic_block bb)
363 (let ( (bdf !basicblock_debug_funcont)
364 )
365 (if (is_closure bdf)
366 (bdf dbgi bb)
367 (if bb
368 (add2out_strconst out " ?*basicblock*?")
369 (add2out_strconst out " ?*nullbasicblock*?")))))
370 ( (:loop lo)
371 (let ( (ldf !loop_debug_funcont)
372 )
373 (if (is_closure ldf)
374 (ldf dbgi lo)
375 (if lo
376 (add2out_strconst out " ?*loop*?")
377 (add2out_strconst out " ?*loop*?")))))
378 (:else
379 (let ( (vctyp (variadic_ctype 0))
380 (vctypname (get_field :named_name vctyp))
381 )
382 (code_chunk warnbadctype #{/* $WARNBADCTYPE */
383 warning (0,
384 "MELT invalid ctype %s in (DEBUG ...) file %s line %d",
385 melt_string_str ((melt_ptr_t) $VCTYPNAME),
386 $FILENAME, (int) $LINENO) ;
387 }#)
388 (add2out out "??:" (get_field :ctype_keyword vctyp) "?? ")
389 )))
390 (setq outlen (output_length out))
391 ) ;end forever argloop
392 ;;
393 ;; if the debug message is long enough, add an extra newline.
394 (when (>i outlen (+i initoutlen 200))
395 (add2out_strconst out " .##.")
396 (add2out_indentnl out 0))
397 (add2out_indentnl out 0)
398 ;;we need to flush the output
399 (code_chunk
400 finalflush_chk
401 #{ /* melt_debug_fun $FINALFLUSH_CHK */
402 melt_flush (melt_get_file ($OUT));
403 }#)
404 ))
405 )))
407 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
409 (defun dbg_outobject (obj dbgi :long depth)
410 :doc #{Output for debugging object $OBJ using debug information
411 $DBGI at given $DEPTH}#
412 (assert_msg "check dbgi" (is_a dbgi class_debug_information) dbgi)
413 (let ( (occmap (unsafe_get_field :dbgi_occmap dbgi)) )
414 (if (is_mapobject occmap)
415 (let ( (occ (mapobject_get occmap obj)) )
416 ;(checkcallstack_msg "in dbg_outobject")
417 (if (is_integerbox occ)
418 (progn
419 (dbg_outputagain obj dbgi depth)
420 (put_int occ (+i (get_int occ) 1))
421 )
422 ;; else new object
423 (let ( (newocc (make_integerbox discr_integer 1)) )
424 (mapobject_put occmap obj newocc)
425 (dbg_output obj dbgi depth)
426 )))))
427 )
429 (defun dbg_out (obj dbgi :long depth)
430 :doc #{Output for debugging value $OBJ using debug information
431 $DBGI at given $DEPTH}#
432 (assert_msg "check dbgi" (is_a dbgi class_debug_information) dbgi)
433 (checkcallstack_msg "start dbg_out")
434 (let ( (out (unsafe_get_field :dbgi_out dbgi))
435 (discr (discrim obj))
436 (:long maxdepth (get_int (unsafe_get_field :dbgi_maxdepth dbgi)))
437 )
438 (if (null out)
439 (return))
440 (if (<i depth maxdepth)
441 (progn
442 (cond
443 ( (is_object obj)
444 (dbg_outobject obj dbgi depth))
445 ( obj
446 (dbg_output obj dbgi depth))
447 (:else
448 (add2out_strconst out "()"))
449 )
450 )
451 (progn
452 (add2out_strconst out ".?.")
453 ))))
456 ;; utility to dump fields in an object from a given rank to a given rank
457 (defun dbgout_fields (obj dbgi :long depth fromrank torank)
458 :doc #{Utility to output for debugging value in $OBJ using debug information
459 $DBGI at given $DEPTH the fields from $FROMRANK to $TORANK}#
460 (assert_msg "check dbgi" (is_a dbgi class_debug_information) dbgi)
461 (assert_msg "check obj" (is_object obj) obj)
462 (let ( (:long nbf (object_length obj))
463 (cla (discrim obj))
464 (:long ix fromrank)
465 (:long fldcnt 0)
466 (clafieldseq (unsafe_get_field :class_fields cla))
467 (out (unsafe_get_field :dbgi_out dbgi))
468 (:long outoff (output_length out))
469 (:long maxdepth (get_int (get_field :dbgi_maxdepth dbgi)))
470 )
471 (assert_msg "check out" (is_out out) out)
472 ;; outoff may be -1 when out is a non-seekable file like stdout
473 (when (<i depth maxdepth)
474 (forever
475 fldloop
476 (if (>=i ix nbf)
477 (exit fldloop))
478 (and (>i torank 0)
479 (>i ix torank)
480 (exit fldloop))
481 (let ( (curfld (multiple_nth clafieldseq ix))
482 (curval (object_nth_field obj ix))
483 )
484 (if (or (<=i depth 1) (notnull curval))
485 (let
486 ( (:long outcuroff (output_length out))
487 )
488 (setq fldcnt (+i fldcnt 1))
489 (if (or
490 (>i outcuroff (+i outoff 80))
491 (==i (%iraw fldcnt 2) 0)
492 (<=i depth 1)
493 )
494 (progn
495 (add2out_indentnl out depth)
496 (setq outoff (strbuf_usedlength out))
497 )
498 (add2out_strconst out " ")
499 )
500 (add2out_string out (unsafe_get_field :named_name curfld))
501 (add2out_strconst out "=")
502 (dbg_out curval dbgi (+i depth 1))
503 (add2out_indent out depth))
504 ))
505 (setq ix (+i ix 1))
506 )
507 )))
509 ;; utility to dump again fields in an object from a given rank to a given rank
510 (defun dbgoutagain_fields (obj dbgi :long depth fromrank torank)
511 :doc #{Utility to output again for debugging value in $OBJ using
512 debug information $DBGI at given $DEPTH the fields from $FROMRANK to
513 $TORANK}#
514 (assert_msg "check dbgi" (is_a dbgi class_debug_information) dbgi)
515 (assert_msg "check obj" (is_object obj) obj)
516 (let ( (:long nbf (object_length obj))
517 (cla (discrim obj))
518 (:long ix fromrank)
519 (clafieldseq (unsafe_get_field :class_fields cla))
520 (out (unsafe_get_field :dbgi_out dbgi))
521 (:long maxdepth (get_int (get_field :dbgi_maxdepth dbgi)))
522 )
523 (assert_msg "check out" (is_out out) out)
524 (if (<i ix 0) (setq ix 0))
525 (if (and (<i depth maxdepth)
526 (is_a dbgi class_debug_output_information))
527 (forever fldloop
528 (if (>=i ix nbf)
529 (exit fldloop))
530 (and (>i torank 0)
531 (>i ix torank)
532 (exit fldloop))
533 (let ( (curfld (multiple_nth clafieldseq ix))
534 (curval (object_nth_field obj ix))
535 )
536 (if curval
537 (progn
538 (add2out_indent out depth)
539 (add2out_string out
540 (unsafe_get_field :named_name curfld))
541 (add2out_strconst out "=")
542 (dbg_outputagain curval dbgi (+i depth 1))
543 (add2out_indent out depth))
544 )
545 (setq ix (+i ix 1))
546 )
547 ))))
549 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
552 ;; null debug output
553 (defun dbgout_null_method (self dbgi :long depth)
554 (let ( (out (unsafe_get_field :dbgi_out dbgi))
555 )
556 (assert_msg "check dbgi" (is_a dbgi class_debug_information) dbgi)
557 (add2out_strconst out "()")))
558 (install_method discr_null_receiver dbg_output dbgout_null_method)
559 (install_method discr_null_receiver dbg_outputagain dbgout_null_method)
561 ;; string debug output
562 (defun dbgout_string_method (self dbgi :long depth)
563 (assert_msg "check dbgi" (is_a dbgi class_debug_information) dbgi)
564 (let ( (dis (discrim self))
565 (sbuf (unsafe_get_field :dbgi_out dbgi))
566 )
567 (if (or (>i depth 0) (== dis discr_string))
568 (progn
569 (match dis
570 (discr_string
571 (add2sbuf_strconst sbuf " \""))
572 (discr_verbatim_string
573 (add2sbuf_strconst sbuf " !\""))
574 (?_
575 (add2sbuf_strconst sbuf " ?\""))
576 )
577 (add2sbuf_cencstring sbuf self)
578 (add2sbuf_strconst sbuf "\" ")
579 )
580 (progn
581 (add2sbuf_strconst sbuf " |")
582 (add2sbuf_string sbuf (unsafe_get_field :named_name dis))
583 (add2sbuf_strconst sbuf "\"")
584 (add2sbuf_cencstring sbuf self)
585 (add2sbuf_strconst sbuf "\"")
586 ))))
588 (install_method discr_string dbg_output dbgout_string_method)
590 ;;; string buffer debug output
591 (defun dbgout_strbuf_method (self dbgi :long depth)
592 (assert_msg "check dbgi" (is_a dbgi class_debug_information) dbgi)
593 (assert_msg "check self" (is_strbuf self) self)
594 (let ( (dis (discrim self))
595 (disname (get_field :named_name dis))
596 (sbuf (unsafe_get_field :dbgi_out dbgi))
597 (:long ulen (strbuf_usedlength self))
598 )
599 (if (>i ulen 20) (add2out_indent sbuf depth))
600 (add2out sbuf "strbuf." DISNAME "[ulen=" ulen "]<\"")
601 (if (<=i depth 1)
602 (cond
603 ( (<i ulen 4000)
604 (code_chunk
605 outallstrbufchk
606 #{/*dbgout_strbuf_method $OUTALLSTRBUFCHK*/ meltgc_add_out_cstr_len
607 ((melt_ptr_t)$SBUF,
608 melt_strbuf_str ((melt_ptr_t)$SELF),
609 (int) $ULEN) ;
610 }#)
611 )
612 (:else
613 (code_chunk
614 outbigslicstrbufchk
615 #{/* dbgout_strbuf_method $OUTBIGSLICSTRBUFCHK*/ {
616 const int startslice = 1000 ;
617 const int endslice = 2500 ;
618 gcc_assert (startslice + endslice < (int)$ULEN - 5) ;
619 meltgc_add_out_cstr_len
620 ((melt_ptr_t)$SBUF,
621 melt_strbuf_str ((melt_ptr_t)$SELF),
622 startslice) ;
623 meltgc_out_printf
624 ((melt_ptr_t)$SBUF,
625 "\"\n ... %d bytes skipped\n ...\"",
626 (int)$ULEN - (startslice+endslice)) ;
627 meltgc_add_out_cstr_len
628 ((melt_ptr_t)$SBUF,
629 (melt_strbuf_str ((melt_ptr_t)$SELF)) + $ULEN - endslice,
630 endslice); ;
631 } /* end dbgout_strbuf_method $OUTBIGSLICSTRBUFCHK*/
632 }#
633 ))
634 )
635 (cond
636 ( (<i ulen 1000)
637 (code_chunk
638 outalltinystrbufchk
639 #{ /* dbgout_strbuf_method $OUTALLTINYSTRBUFCHK*/ meltgc_add_out_cstr_len
640 ((melt_ptr_t)$SBUF,
641 melt_strbuf_str ((melt_ptr_t)$SELF),
642 (int) $ULEN) ;
643 }#
644 )
645 )
646 (:else
647 (code_chunk
648 outtinyslicstrbufchk
649 #{ /*+ dbgout_strbuf_method $OUTTINYSLICSTRBUFCHK*/ {
650 const int startslice = 100 ;
651 const int endslice = 550 ;
652 gcc_assert (startslice + endslice < (int)$ULEN - 5) ;
653 meltgc_add_out_cstr_len
654 ((melt_ptr_t)$SBUF,
655 melt_strbuf_str ((melt_ptr_t)$SELF),
656 startslice) ;
657 meltgc_out_printf
658 ((melt_ptr_t)$SBUF,
659 "\"\n ... %d bytes skipped\n ...\"",
660 (int)$ULEN - (startslice+endslice)) ;
661 meltgc_add_out_cstr_len
662 ((melt_ptr_t)$SBUF,
663 (melt_strbuf_str ((melt_ptr_t)$SELF)) + $ULEN - endslice,
664 endslice); ;
665 } /*-end dbgout_strbuf_method $OUTTINYSLICSTRBUFCHK*/
666 }#
667 ))))
668 (add2out sbuf "\">")
669 (if (>i ulen 60) (add2out_indent sbuf depth))
670 ))
671 (install_method discr_strbuf dbg_output dbgout_strbuf_method)
673 ;;;;;;;;;;;;;;;;
676 ;; integer debug output
677 (defun dbgout_integer_method (self dbgi :long depth)
678 (assert_msg "check dbgi" (is_a dbgi class_debug_information) dbgi)
679 (let ( (dis (discrim self))
680 (sbuf (unsafe_get_field :dbgi_out dbgi))
681 )
682 (cond
683 ( (and (== dis discr_integer) (>i depth 0))
684 (add2sbuf_strconst sbuf " #")
685 (add2sbuf_longdec sbuf (get_int self)))
686 ( (and (== dis discr_constant_integer) (>i depth 0))
687 (add2out sbuf " #'" (get_int self)))
688 (:else
689 (add2sbuf_strconst sbuf " |")
690 (add2sbuf_string sbuf (unsafe_get_field :named_name dis))
691 (add2sbuf_strconst sbuf "#")
692 (add2sbuf_longdec sbuf (get_int self)))
693 )))
695 (install_method discr_integer dbg_output dbgout_integer_method)
697 ;; double debug output
698 (defun dbgout_double_method (self dbgi :long depth)
699 (assert_msg "check dbgi" (is_a dbgi class_debug_information) dbgi)
700 (let ( (dis (discrim self))
701 (sbuf (unsafe_get_field :dbgi_out dbgi))
702 )
703 (cond
704 ( (and (== dis discr_double) (>i depth 0))
705 (add2out_double sbuf (unbox :double self)))
706 ( (and (== dis discr_constant_double) (>i depth 0))
707 (add2out sbuf " #'" (unbox :double self)))
708 (:else
709 (add2sbuf_strconst sbuf " |")
710 (add2sbuf_string sbuf (unsafe_get_field :named_name dis))
711 (add2sbuf_strconst sbuf "#")
712 (add2out_double sbuf (unbox :double self)))
713 )))
714 (install_method discr_double dbg_output dbgout_double_method)
716 ;; mixint debug value
717 (defun dbgout_mixint_method (self dbgi :long depth)
718 (assert_msg "check dbgi" (is_a dbgi class_debug_information) dbgi)
719 (let ( (dis (discrim self))
720 (sbuf (unsafe_get_field :dbgi_out dbgi))
721 (:long maxdepth (get_int (get_field :dbgi_maxdepth dbgi)))
722 )
723 (if (and (>i depth 0) (== dis discr_mixed_integer))
724 (progn
725 (add2sbuf_strconst sbuf " #[")
726 (add2sbuf_longdec sbuf (get_int self)))
727 (progn
728 (add2sbuf_strconst sbuf " |")
729 (add2sbuf_string sbuf (unsafe_get_field :named_name dis))
730 (add2sbuf_strconst sbuf "#[")
731 (add2sbuf_longdec sbuf (get_int self)))
732 )
733 (if (and (<i depth maxdepth)
734 (is_a dbgi class_debug_output_information))
735 (progn
736 (add2sbuf_strconst sbuf ",")
737 (dbg_out (mixint_val self) dbgi (+i depth 1))
738 )
739 (add2sbuf_strconst sbuf ",..")
740 )
741 (add2sbuf_strconst sbuf "]")
742 ))
743 (install_method discr_mixed_integer dbg_output dbgout_mixint_method)
745 ;; mixloc debug value
746 (defun dbgout_mixloc_method (self dbgi :long depth)
747 (assert_msg "check dbgi" (is_a dbgi class_debug_information) dbgi)
748 (assert_msg "check self mixloc" (is_mixloc self) self)
749 (let ( (dis (discrim self))
750 (sbuf (unsafe_get_field :dbgi_out dbgi))
751 (:long maxdepth (get_int (get_field :dbgi_maxdepth dbgi)))
752 )
753 (if (and (>i depth 0) (== dis DISCR_MIXED_LOCATION))
754 (progn
755 (add2sbuf_strconst sbuf " #![")
756 (add2sbuf_longdec sbuf (get_int self)))
757 (progn
758 (add2sbuf_strconst sbuf " |")
759 (add2sbuf_string sbuf (unsafe_get_field :named_name dis))
760 (add2sbuf_strconst sbuf "#![")
761 (add2sbuf_longdec sbuf (get_int self)))
762 )
763 (if (<i (+i depth 2) maxdepth)
764 (progn
765 (add2sbuf_strconst sbuf ",")
766 (add2sbuf_mixloc sbuf self)
767 )
768 (add2sbuf_strconst sbuf ",..")
769 )
770 (add2sbuf_strconst sbuf "]")
771 ))
772 (install_method discr_mixed_location dbg_output dbgout_mixloc_method)
775 ;; mixbigint debug value
776 (defun dbgout_mixbigint_method (self dbgi :long depth)
777 (assert_msg "check dbgi" (is_a dbgi class_debug_information) dbgi)
778 (assert_msg "check self mixbigint" (is_mixbigint self) self)
779 (let ( (dis (discrim self))
780 (sbuf (get_field :dbgi_out dbgi))
781 (:long maxdepth (get_int (get_field :dbgi_maxdepth dbgi)))
782 )
783 (add2sbuf_strconst sbuf " |")
784 (add2sbuf_string sbuf (unsafe_get_field :named_name dis))
785 (add2sbuf_strconst sbuf "#![")
786 (if (<i (+i depth 2) maxdepth)
787 (progn
788 (dbg_out (mixbigint_val self) dbgi (+i depth 1))
789 (add2sbuf_strconst sbuf ",")
790 (ppstrbuf_mixbigint sbuf (+i depth 1) self)
791 )
792 (add2sbuf_strconst sbuf ",..")
793 )
794 (add2sbuf_strconst sbuf "]")
795 ))
796 (install_method discr_mixed_bigint dbg_output dbgout_mixbigint_method)
798 ;; multiple debug out
799 (defun dbgout_multiple_method (self dbgi :long depth)
800 (assert_msg "check dbgi" (is_a dbgi class_debug_information) dbgi)
801 (let ( (dis (discrim self))
802 (sbuf (unsafe_get_field :dbgi_out dbgi))
803 )
804 (if (and (>i depth 0) (== dis DISCR_MULTIPLE))
805 (add2sbuf_strconst sbuf " *")
806 (progn
807 (add2sbuf_strconst sbuf " |")
808 (add2sbuf_string sbuf (unsafe_get_field :named_name dis))
809 (add2sbuf_strconst sbuf "*")))
810 (let ( (:long ln (multiple_length self)) )
811 (add2sbuf_longdec sbuf ln)
812 (add2sbuf_strconst sbuf "[")
813 (if (or (<=i depth 0) (melt_really_need_debug depth))
814 (foreach_in_multiple
815 (self)
816 (curcomp :long ix)
817 (if (and (==i 0 (%iraw ix 5)) (>i ix 0))
818 (add2sbuf_indentnl sbuf depth)
819 (add2sbuf_indent sbuf depth))
820 (let ( (:long curulen (strbuf_usedlength sbuf)) )
821 (dbg_out curcomp dbgi (+i 1 depth))
822 (and (>i (-i (strbuf_usedlength sbuf) curulen) 64)
823 (<i ix (-i ln 1))
824 (add2sbuf_indentnl sbuf (+i 1 depth))))
825 )
826 (add2sbuf_strconst sbuf "..")
827 )
828 (add2sbuf_strconst sbuf "]")
829 )))
831 (install_method discr_multiple dbg_output dbgout_multiple_method)
833 ;; routine debug out - don't print the routine components if depth is >0
834 (defun dbgout_routine_method (self dbgi :long depth)
835 (assert_msg "check dbgi" (is_a dbgi class_debug_information) dbgi)
836 (assert_msg "check self" (is_routine self) self)
837 (let ( (dis (discrim self))
838 (sbuf (unsafe_get_field :dbgi_out dbgi))
839 (boxdepthp1 (make_integerbox discr_integer (+i depth 1)))
840 )
841 (if (and (>i depth 0) (== dis DISCR_ROUTINE))
842 (add2sbuf_strconst sbuf " *rou[%")
843 (progn
844 (add2sbuf_strconst sbuf " |")
845 (add2sbuf_string sbuf (unsafe_get_field :named_name dis))
846 (add2sbuf_strconst sbuf "[%")))
847 (add2sbuf_routinedescr sbuf self)
848 (if (<i depth 2)
849 (routine_every self
850 (lambda (comp :long ix)
851 (add2sbuf_indent sbuf (get_int boxdepthp1))
852 (dbg_out comp dbgi (get_int boxdepthp1))
853 ))
854 )
855 (add2sbuf_strconst sbuf "%]")
856 )
857 )
859 (install_method discr_routine dbg_output dbgout_routine_method)
861 ;; hook debug out - don't print the hook components if depth is >0
862 (defun dbgout_hook_method (self dbgi :long depth)
863 (assert_msg "check dbgi" (is_a dbgi class_debug_information) dbgi)
864 (assert_msg "check self" (is_hook self) self)
865 (let ( (dis (discrim self))
866 (sbuf (unsafe_get_field :dbgi_out dbgi))
867 (boxdepthp1 (make_integerbox discr_integer (+i depth 1)))
868 )
869 (add2sbuf_strconst sbuf " *hook[%")
870 (add2sbuf_string sbuf (unsafe_get_field :named_name dis))
871 (add2out sbuf "|" (hook_name self) "!" (hook_size self))
872 (when (<i depth 3)
873 (add2sbuf_indentnl sbuf (get_int boxdepthp1))
874 (add2out sbuf "hookdata: ")
875 (dbg_out (hook_data self) dbgi (get_int boxdepthp1))
876 (hook_every self
877 (lambda (comp :long ix)
878 (add2sbuf_indentnl sbuf (get_int boxdepthp1))
879 (add2out sbuf "hookval#" ix ": ")
880 (dbg_out comp dbgi (get_int boxdepthp1))
881 ))
882 )
883 (add2sbuf_strconst sbuf " %]")
884 (if (<i depth 3)
885 (add2sbuf_indentnl sbuf depth)
886 (add2sbuf_strconst sbuf " "))
887 )
888 )
890 (install_method discr_hook dbg_output dbgout_hook_method)
894 ;; closure debug out
895 (defun dbgout_closure_method (self dbgi :long depth)
896 (assert_msg "check dbgi" (is_a dbgi class_debug_information) dbgi)
897 (assert_msg "check self" (is_closure self) self)
898 (let ( (dis (discrim self))
899 (:long oldmaxdepth (get_int (unsafe_get_field :dbgi_maxdepth dbgi)))
900 (sbuf (unsafe_get_field :dbgi_out dbgi))
901 (:long maxdepth (get_int (get_field :dbgi_maxdepth dbgi)))
902 )
903 (if (and (>i depth 0) (== dis DISCR_CLOSURE))
904 (add2sbuf_strconst sbuf " *clo(<")
905 (progn
906 (add2sbuf_strconst sbuf " |")
907 (add2sbuf_string sbuf (unsafe_get_field :named_name dis))
908 (add2sbuf_strconst sbuf "*clo(<")))
909 (if (and (<i depth 2)
910 (<i depth maxdepth)
911 (is_a dbgi class_debug_output_information))
912 (let ((:long ix 0))
913 (put_int (unsafe_get_field :dbgi_maxdepth dbgi) 3)
914 (dbg_out (closure_routine self) dbgi depth)
915 (put_int (unsafe_get_field :dbgi_maxdepth dbgi) oldmaxdepth)
916 (add2sbuf_strconst sbuf "/")
917 (add2sbuf_longdec sbuf (closure_size self))
918 (forever outloop
919 (if (>=i ix (closure_size self))
920 (exit outloop))
921 (add2sbuf_indent sbuf depth)
922 (let ( (:long curulen (strbuf_usedlength sbuf)) )
923 (dbg_out (closure_nth self ix) dbgi (+i depth 2))
924 (if (>i (-i (strbuf_usedlength sbuf) curulen) 100)
925 (add2sbuf_indentnl sbuf (+i 1 depth))))
926 (setq ix (+i ix 1))
927 ))
928 (let ( (crout (closure_routine self))
929 )
930 (add2sbuf_routinedescr sbuf crout)
931 (add2sbuf_strconst sbuf "...")
932 ))
933 (add2sbuf_strconst sbuf " >)")
934 (add2sbuf_indent sbuf depth)
935 ))
937 (install_method discr_closure dbg_output dbgout_closure_method)
941 ;; list debug out
942 (defun dbgout_list_method (self dbgi :long depth)
943 (assert_msg "check dbgi" (is_a dbgi class_debug_information) dbgi)
944 (assert_msg "check self" (is_list self) self)
945 (let ( (dis (discrim self))
946 (:long maxdepth (get_int (get_field :dbgi_maxdepth dbgi)))
947 (sbuf (get_field :dbgi_out dbgi)) )
948 (if (and (>i depth 0) (== dis DISCR_LIST))
949 (add2sbuf_strconst sbuf " *li")
950 (progn
951 (add2sbuf_strconst sbuf " *li|")
952 (add2sbuf_string sbuf (unsafe_get_field :named_name dis))))
953 (let (
954 (:long ix 0)
955 (:long lislen (list_length self))
956 )
957 (if depth (add2sbuf_strconst sbuf "(")
958 (add2out sbuf "~" lislen "("))
959 (cond
960 ( (<i depth maxdepth)
961 (foreach_pair_component_in_list
962 (self)
963 (curpair curcomp)
964 (when (>i ix 300)
965 (add2out sbuf " ...." (-i lislen ix) "...")
966 (setq curpair ()))
967 (when (is_pair curpair)
968 (if (and (==i (%iraw ix 5) 0) (>i ix 0))
969 (add2sbuf_indentnl sbuf (+i depth 1))
970 (add2sbuf_indent sbuf depth))
971 (let ( (:long curulen (strbuf_usedlength sbuf))
972 )
973 (dbg_out curcomp dbgi (+i depth 1))
974 (setq ix (+i ix 1))
975 (if (>i (-i (strbuf_usedlength sbuf) curulen) 100)
976 (add2sbuf_indentnl sbuf (+i 1 depth))))
977 ))
978 (void))
979 ( (>i lislen 0)
980 (add2out sbuf "..." lislen "...")
981 )
982 (:else
983 (void)))
984 (add2sbuf_strconst sbuf ")"))))
985 (install_method discr_list dbg_output dbgout_list_method)
988 ;; pair debug output
989 (defun dbgout_pair_method (self dbgi :long depth)
990 (assert_msg "check dbgi" (is_a dbgi class_debug_information) dbgi)
991 (assert_msg "check self" (is_pair self) self)
992 (let ( (dis (discrim self))
993 (:long maxdepth (get_int (get_field :dbgi_maxdepth dbgi)))
994 (sbuf (get_field :dbgi_out dbgi)) )
995 (if (and (>i depth 0) (== dis DISCR_PAIR))
996 (add2sbuf_strconst sbuf " *pa(.")
997 (progn
998 (add2sbuf_strconst sbuf " |")
999 (add2sbuf_string sbuf (unsafe_get_field :named_name dis))
1000 (add2sbuf_strconst sbuf "(.")))
1001 (if
1002 (and (<i depth maxdepth) (is_a dbgi class_debug_output_information))
1003 (progn
1004 (dbg_out (pair_head self) dbgi (+i depth 1))
1005 (add2sbuf_indent sbuf depth)
1006 (dbg_out (pair_tail self) dbgi (+i depth 1))))
1007 (add2sbuf_strconst sbuf ".)")))
1009 (install_method discr_pair dbg_output dbgout_pair_method)
1013 ;; mapobject debug output
1014 (defun dbgout_mapobject_method (self dbgi :long depth)
1015 (assert_msg "check dbgi" (is_a dbgi class_debug_information) dbgi)
1016 (assert_msg "check self" (is_mapobject self) self)
1017 (let ( (dis (discrim self))
1018 (out (get_field :dbgi_out dbgi))
1019 (:long mapcount (mapobject_count self))
1020 (:long maxdepth (get_int (get_field :dbgi_maxdepth dbgi)))
1021 )
1022 (assert_msg "check out at start" (is_out out) out)
1023 (if (and (>i depth 0) (== dis DISCR_MAP_OBJECTS))
1024 (add2out_strconst out " {")
1025 (progn
1026 (add2out_strconst out " |")
1027 (add2out_string out (unsafe_get_field :named_name dis))
1028 (add2out_strconst out "{h")))
1029 (add2out_longhex out (mapobject_hash self))
1030 (add2out_strconst out "/")
1031 (add2out_longdec out (mapobject_count self))
1032 (if (and
1033 (melt_really_need_dbglim (+i depth 2) maxdepth)
1034 ; (<i (+i depth 2) maxdepth)
1035 (or (<i depth 3)
1036 (<i mapcount (*i 3 (+i depth 1)))))
1037 (let (
1038 (nextdepthbox (make_integerbox discr_integer (+i 2 depth)))
1039 (countbox (make_integerbox discr_integer 0))
1040 (tupl (make_multiple discr_multiple mapcount))
1041 (aux (mapobject_aux self))
1042 )
1043 (if (and
1044 (notnull aux)
1045 (<=i depth 1))
1046 (progn
1047 (add2out out " aux:")
1048 (dbg_out aux dbgi (+i depth 3))
1049 (add2out_indent out (+i depth 1)))
1050 )
1051 ;; fill the tupl with (attribute value rank) entries
1052 (mapobject_every
1053 self
1054 (lambda (at va)
1055 (let ( (:long curcount (get_int countbox))
1056 (ent (tuple at va
1057 (make_integerbox discr_integer curcount)))
1058 )
1059 (multiple_put_nth tupl curcount ent)
1060 (put_int countbox (+i curcount 1))
1061 )))
1062 (assert_msg "check tupl" (is_multiple tupl) tupl)
1063 ;;; sort the tuple and output in sorted order
1064 (let ( (sortupl
1065 (multiple_sort
1066 tupl
1067 (lambda (e1 e2)
1068 (let ( (e1at (multiple_nth e1 0))
1069 (e1va (multiple_nth e1 1))
1070 (e1rk (multiple_nth e1 2))
1071 (e2at (multiple_nth e2 0))
1072 (e2va (multiple_nth e2 1))
1073 (e2rk (multiple_nth e2 2))
1074 )
1075 (compare_obj_ranked e1at e1rk e2at e2rk '-1 '0 '1)
1076 ))
1077 discr_multiple
1078 ))
1079 )
1080 (assert_msg "check sortupl" (is_multiple sortupl) sortupl)
1081 (multiple_every
1082 sortupl
1083 (lambda (el :long ix)
1084 (let ( (elat (multiple_nth el 0))
1085 (elva (multiple_nth el 1)) )
1086 (let ( (:long nextdepth (get_int nextdepthbox))
1087 (:long oldmaxdepth (get_int (unsafe_get_field :dbgi_maxdepth dbgi)))
1088 )
1090 (assert_msg "check out" (is_out out) out)
1091 (add2out_indentnl out nextdepth)
1092 (add2out_strconst out "**")
1093 (put_int (unsafe_get_field :dbgi_maxdepth dbgi) 0)
1094 (dbg_outobject elat dbgi nextdepth)
1095 (put_int (unsafe_get_field :dbgi_maxdepth dbgi) oldmaxdepth)
1096 (add2out_strconst out " ==")
1097 (add2out_indent out (+i nextdepth 1))
1098 (dbg_out elva dbgi (+i nextdepth 2))
1099 (add2out_strconst out "; ")
1100 ))))))
1101 (add2out_strconst out " ..:..")
1102 )
1103 (add2out_strconst out "}")))
1104 (install_method discr_map_objects dbg_output dbgout_mapobject_method)
1107 ;;; string map (ie dictionnary) debug output
1108 (defun dbgout_mapstring_method (self dbgi :long depth)
1109 (assert_msg "check dbgi" (is_a dbgi class_debug_information) dbgi)
1110 (assert_msg "check self" (is_mapstring self) self)
1111 (let ( (dis (discrim self))
1112 (sbuf (unsafe_get_field :dbgi_out dbgi))
1113 (:long ix 0)
1114 (:long mapcount (mapstring_count self))
1115 (nextdepthbox (make_integerbox discr_integer (+i 2 depth)))
1116 (countbox (make_integerbox discr_integer 0))
1117 (tupl (make_multiple discr_multiple mapcount))
1118 (:long maxdepth (get_int (get_field :dbgi_maxdepth dbgi)))
1119 )
1120 (add2out sbuf " *mapstr|" (get_field :named_name dis) "<(")
1121 (add2sbuf_longhex sbuf (mapstring_hash self))
1122 (add2sbuf_strconst sbuf "/")
1123 (add2sbuf_longdec sbuf mapcount)
1124 (if (and
1125 (melt_really_need_dbglim (+i depth 1) maxdepth)
1126 ;; (<i (+i depth 2) maxdepth)
1127 (or (<i depth 3) (<i mapcount 10))
1128 (is_a dbgi class_debug_output_information))
1129 (let (
1130 (aux (mapstring_aux self))
1131 )
1132 (if (and
1133 (notnull aux)
1134 (<=i depth 1))
1135 (progn
1136 (add2out sbuf " aux:")
1137 (dbg_out aux dbgi (+i depth 3))
1138 (add2out_indentnl sbuf (+i depth 1)))
1139 )
1140 ;; fill the tuple with string, value, rank triples
1141 (mapstring_every
1142 self
1143 (lambda (str val)
1144 (let ( (:long curcount (get_int countbox))
1145 (ent (tuple str val
1146 (make_integerbox discr_integer curcount)))
1147 )
1148 (multiple_put_nth tupl curcount ent)
1149 (put_int countbox (+i curcount 1))
1150 )))
1151 ;; sort the tuple and display it
1152 (let ( (sortupl
1153 (multiple_sort
1154 tupl
1155 (lambda (e1 e2)
1156 (let ( (e1at (multiple_nth e1 0))
1157 (e1va (multiple_nth e1 1))
1158 (e1rk (multiple_nth e1 2))
1159 (e2at (multiple_nth e2 0))
1160 (e2va (multiple_nth e2 1))
1161 (e2rk (multiple_nth e2 2))
1162 )
1163 (compare_obj_ranked e1at e1rk e2at e2rk '-1 '0 '1)
1164 ))
1165 discr_multiple
1166 ))
1167 )
1168 (assert_msg "check sortupl" (is_multiple sortupl) sortupl)
1169 (foreach_in_multiple
1170 (sortupl)
1171 (el :long ix)
1172 (let ( (curstr (multiple_nth el 0))
1173 (curval (multiple_nth el 1))
1174 (:long nextdepth (get_int nextdepthbox))
1175 )
1176 (when (and (is_string curstr) (notnull curval))
1177 (add2sbuf_indentnl sbuf nextdepth)
1178 (add2sbuf_strconst sbuf "!*")
1179 (dbg_out curstr dbgi nextdepth)
1180 (add2sbuf_strconst sbuf " => ")
1181 (add2sbuf_indent sbuf nextdepth)
1182 (dbg_out curval dbgi (+i nextdepth 2))
1183 )))
1184 )))
1185 (add2sbuf_strconst sbuf " )>")))
1186 (install_method discr_map_strings dbg_output dbgout_mapstring_method)
1190 ;;;;;;;;;;;;;;;; bucket_longs debug output
1191 (defun dbgout_bucketlong_method (self dbgi :long depth)
1192 (assert_msg "check dbgi" (is_a dbgi class_debug_information) dbgi)
1193 (assert_msg "check self" (is_bucketlong self) self)
1194 (let ( (dis (discrim self))
1195 (sbuf (unsafe_get_field :dbgi_out dbgi))
1196 (:long ix 0)
1197 (:long nextdepth (+i 2 depth))
1198 (nextdepthbox (make_integerbox discr_integer nextdepth))
1199 (aux (bucketlong_aux self))
1200 (:long maxdepth (get_int (get_field :dbgi_maxdepth dbgi)))
1201 (:long xnum (bucketlong_xnum self))
1202 )
1203 (add2out sbuf ".bucklong/" (get_field :named_name dis) "!{")
1204 (when (or (<=i depth 0) (notnull aux))
1205 (add2sbuf_indentnl sbuf nextdepth)
1206 (add2out sbuf "*aux= ")
1207 (dbg_out aux dbgi (+i nextdepth 2))
1208 )
1209 (when (or (<=i depth 0) xnum)
1210 (add2sbuf_indentnl sbuf nextdepth)
1211 (add2out sbuf "*xnum= " xnum)
1212 )
1213 (foreach_in_bucketlong
1214 (self)
1215 (:long key :value val)
1216 (add2sbuf_indentnl sbuf nextdepth)
1217 (add2out sbuf "* " key "= ")
1218 (dbg_out val dbgi nextdepth)
1219 )
1220 (if (bucketlong_count self)
1221 (add2sbuf_indentnl sbuf (+i 1 depth)))
1222 (add2out sbuf "}!")
1223 ))
1224 (install_method discr_bucket_longs dbg_output dbgout_bucketlong_method)
1227 ;;; jsonobject debug output
1228 (defun dbgout_jsonobject_method (self dbgi :long depth)
1229 (assert_msg "check dbgi" (is_a dbgi class_debug_information) dbgi)
1230 (assert_msg "check self" (is_jsonobject self) self)
1231 (let ( (dis (discrim self))
1232 (:long nextdepth (+i 2 depth))
1233 (sbuf (unsafe_get_field :dbgi_out dbgi))
1234 (aux (jsonobject_aux self))
1235 (:long size (jsonobject_size self))
1236 )
1237 (add2out sbuf ".jsonobj/" (get_field :named_name dis) "<{")
1238 (when (or (<=i depth 0) (notnull aux))
1239 (add2sbuf_indentnl sbuf nextdepth)
1240 (add2out sbuf "/" size "**aux= ")
1241 (dbg_out aux dbgi (+i nextdepth 2))
1242 )
1243 (foreach_entry_in_jsonobject
1244 (self)
1245 (jname jval :long jix)
1246 (add2sbuf_indentnl sbuf nextdepth)
1247 (cond ( (is_string jname)
1248 (add2out sbuf "*\"" jname "= "))
1249 ( (is_a jname class_named)
1250 (add2out sbuf "*'" jname "= "))
1251 (:else
1252 (add2out sbuf "*?" jname "= ")))
1253 (dbg_out jval dbgi nextdepth)
1254 )
1255 (if size
1256 (add2sbuf_indentnl sbuf (+i 1 depth)))
1257 (add2out sbuf "}>")
1258 ))
1259 (install_method discr_jsonobject dbg_output dbgout_jsonobject_method)
1261 ;;;; generic object debug
1262 (defun dbgout_anyobject_method (self dbgi :long depth)
1263 (assert_msg "check dbgi" (is_a dbgi class_debug_information) dbgi)
1264 (assert_msg "check self" (is_object self) self)
1265 (let ( (dis (discrim self))
1266 (:long maxdepth (get_int (get_field :dbgi_maxdepth dbgi)))
1267 (sbuf (unsafe_get_field :dbgi_out dbgi)) )
1268 (add2sbuf_strconst sbuf "|")
1269 (add2sbuf_string sbuf (unsafe_get_field :named_name dis))
1270 (add2sbuf_strconst sbuf "/")
1271 (add2sbuf_longhex sbuf (obj_hash self))
1272 (let ( (:long onum (get_int self))
1273 )
1274 (when onum
1275 (add2sbuf_strconst sbuf "#")
1276 (add2sbuf_longdec sbuf onum))
1277 )
1278 (when (<i (+i depth 1) maxdepth)
1279 (add2sbuf_strconst sbuf "{")
1280 (dbgout_fields self dbgi (+i depth 1) 0 0)
1281 (add2sbuf_strconst sbuf "}")
1282 )
1283 ))
1284 (install_method class_root dbg_output dbgout_anyobject_method)
1286 ;;;; generic value debug
1287 (defun dbgout_anyrecv_method (self dbgi :long depth)
1288 (assert_msg "check dbgi" (is_a dbgi class_debug_information) dbgi)
1289 (let ( (dis (discrim self))
1290 (sbuf (unsafe_get_field :dbgi_out dbgi)) )
1291 (add2sbuf_strconst sbuf " ?.")
1292 (if (is_a dis class_named) (add2sbuf_string sbuf (unsafe_get_field :named_name dis)))
1293 (add2sbuf_strconst sbuf ".? ")
1294 ))
1295 (install_method discr_any_receiver dbg_output dbgout_anyrecv_method)
1297 ;;; generic object debug outputagain
1298 (defun dbgoutagain_anyobject_method (self dbgi :long depth)
1299 (assert_msg "check dbgi" (is_a dbgi class_debug_information) dbgi)
1300 (assert_msg "check self" (is_object self) self)
1301 (let ( (dis (discrim self))
1302 (sbuf (unsafe_get_field :dbgi_out dbgi))
1303 (:long onum (obj_num self))
1304 )
1305 (add2sbuf_strconst sbuf "^^|")
1306 (add2sbuf_string sbuf (unsafe_get_field :named_name dis))
1307 (add2sbuf_strconst sbuf "/")
1308 (add2sbuf_longhex sbuf (obj_hash self))
1309 (when onum
1310 (add2sbuf_strconst sbuf "#")
1311 (add2sbuf_longdec sbuf onum))
1312 ))
1313 (install_method class_root dbg_outputagain dbgoutagain_anyobject_method)
1315 ;;;; named object debug
1316 (defun dbgout_namedobject_method (self dbgi :long depth)
1317 (assert_msg "check dbgi" (is_a dbgi class_debug_information) dbgi)
1318 (assert_msg "check self" (is_a self class_named) self)
1319 (let ( (dis (discrim self))
1320 (out (unsafe_get_field :dbgi_out dbgi))
1321 (onam (unsafe_get_field :named_name self))
1322 (oprop (unsafe_get_field :prop_table self))
1323 (:long maxdepth (get_int (get_field :dbgi_maxdepth dbgi)))
1324 )
1325 (assert_msg "check out" (is_out out) out)
1326 (add2out_strconst out "`")
1327 (add2out_string out onam)
1328 (add2out_strconst out "|")
1329 (add2out_string out (unsafe_get_field :named_name dis))
1330 (add2out_strconst out "/")
1331 (add2out_longhex out (obj_hash self))
1332 (if (<i depth maxdepth)
1333 (let ( (:long onum (obj_num self))
1334 )
1335 (if onum
1336 (progn
1337 (add2out_strconst out "#")
1338 (add2out_longdec out onum)))
1339 (add2out_strconst out "{")
1340 (if oprop
1341 (progn
1342 (add2out_strconst out "prop=")
1343 (dbg_out oprop dbgi (+i depth 3))
1344 ))
1345 (dbgout_fields self dbgi (+i depth 3) 2 0)
1346 (add2out_strconst out "}")
1347 ))))
1348 (install_method class_named dbg_output dbgout_namedobject_method)
1349 ;;; we explicitly export dbgout_namedobject_method needed afterwards
1350 (export_values dbgout_namedobject_method)
1352 ;;;; named object debug outputagain
1353 (defun dbgoutagain_namedobject_method (self dbgi :long depth)
1354 (assert_msg "check dbgi" (is_a dbgi class_debug_information) dbgi)
1355 (assert_msg "check self" (is_a self class_named) self)
1356 (let ( (dis (discrim self))
1357 (out (unsafe_get_field :dbgi_out dbgi))
1358 (onam (unsafe_get_field :named_name self))
1359 )
1360 (add2out_strconst out "^^`")
1361 (add2out_string out onam)
1362 (add2out_strconst out "|")
1363 (add2out_string out (unsafe_get_field :named_name dis))
1364 (add2out_strconst out "/")
1365 (add2out_longhex out (obj_hash self))
1366 ))
1367 (install_method class_named dbg_outputagain dbgoutagain_namedobject_method)
1369 ;;;; symbol output debug & again
1371 (defun dbgoutagain_symbol_method (self dbgi :long depth)
1372 (assert_msg "check dbgi" (is_a dbgi class_debug_information) dbgi)
1373 (assert_msg "check self" (is_a self class_symbol) self)
1374 (let ( (out (unsafe_get_field :dbgi_out dbgi))
1375 (onam (unsafe_get_field :named_name self))
1376 (:long snum (get_int self))
1377 )
1378 (add2out_strconst out "$")
1379 (add2out_string out onam)
1380 (add2out_strconst out "/")
1381 (add2out_longhex out (obj_hash self))
1382 (if snum
1383 (progn
1384 (add2out_strconst out "#")
1385 (add2out_longdec out snum)))
1386 ))
1387 (install_method class_symbol dbg_outputagain dbgoutagain_symbol_method)
1389 (defun dbgout_symbol_method (self dbgi :long depth)
1390 (assert_msg "check dbgi" (is_a dbgi class_debug_information) dbgi)
1391 (assert_msg "check self" (is_a self class_symbol) self)
1392 (if (<=i depth 0)
1393 (dbgout_namedobject_method self dbgi 0)
1394 (dbgoutagain_symbol_method self dbgi depth)))
1395 (install_method class_symbol dbg_output dbgout_symbol_method)
1398 ;;;; class output debug & again
1399 (defun dbgout_class_method (self dbgi :long depth)
1400 (assert_msg "check dbgi" (is_a dbgi class_debug_information) dbgi)
1401 (assert_msg "check self" (is_a self class_class) self)
1402 (if (<=i depth 1)
1403 (dbgout_namedobject_method self dbgi 0)
1404 (dbgoutagain_namedobject_method self dbgi depth)))
1405 (install_method class_class dbg_output dbgout_class_method)
1408 ;;;; keyword output debug & again
1409 (defun dbgoutagain_keyword_method (self dbgi :long depth)
1410 (assert_msg "check dbgi" (is_a dbgi class_debug_information) dbgi)
1411 (assert_msg "check self" (is_a self class_keyword) self)
1412 (let ( (out (unsafe_get_field :dbgi_out dbgi))
1413 (onam (unsafe_get_field :named_name self))
1414 )
1415 (add2out_strconst out "$:")
1416 (add2out_string out onam)
1417 (add2out_strconst out "/")
1418 (add2out_longhex out (obj_hash self))
1419 ))
1420 (install_method class_keyword dbg_outputagain dbgoutagain_keyword_method)
1422 (defun dbgout_keyword_method (self dbgi :long depth)
1423 (assert_msg "check dbgi" (is_a dbgi class_debug_information) dbgi)
1424 (assert_msg "check self" (is_a self class_keyword) self)
1425 (if (<=i depth 0)
1426 (dbgout_namedobject_method self dbgi 0)
1427 (dbgoutagain_keyword_method self dbgi depth)))
1428 (install_method class_keyword dbg_output dbgout_keyword_method)
1431 ;;;; cloned_symbol output debug & again
1432 (defun dbgoutagain_cloned_symbol_method (self dbgi :long depth)
1433 (let ( (dis (discrim self))
1434 (out (unsafe_get_field :dbgi_out dbgi))
1435 (ourank (unsafe_get_field :csym_urank self))
1436 (:long lrk (get_int ourank))
1437 (onam (unsafe_get_field :named_name self)) )
1438 (add2out_strconst out "$$")
1439 (add2out_string out onam)
1440 (add2out_strconst out ":")
1441 (add2out_longdec out lrk)
1442 (add2out_strconst out "/")
1443 (add2out_longhex out (obj_hash self))
1444 ))
1445 (install_method class_cloned_symbol dbg_outputagain dbgoutagain_cloned_symbol_method)
1447 (defun dbgout_cloned_symbol_method (self dbgi :long depth)
1448 (assert_msg "check dbgi" (is_a dbgi class_debug_information) dbgi)
1449 (assert_msg "check self" (is_a self class_cloned_symbol) self)
1450 (if (<=i depth 0)
1451 (dbgout_namedobject_method self dbgi 0)
1452 (dbgoutagain_cloned_symbol_method self dbgi depth)
1453 ))
1454 (install_method class_cloned_symbol dbg_output dbgout_cloned_symbol_method)
1457 ;;;; environment output debug
1458 (defun dbgout_environment_method (self dbgi :long depth)
1459 (assert_msg "check dbgi" (is_a dbgi class_debug_information) dbgi)
1460 (assert_msg "check self" (is_a self class_environment) self)
1461 (let ( (dis (discrim self))
1462 (out (unsafe_get_field :dbgi_out dbgi))
1463 (:long onum (obj_num self))
1464 )
1465 (if (== dis class_environment)
1466 (add2out_strconst out "env")
1467 (progn
1468 (add2out_strconst out "|")
1469 (add2out_string out (unsafe_get_field :named_name dis))
1470 ))
1471 (add2out_strconst out "/")
1472 (add2out_longhex out (obj_hash self))
1473 (when onum
1474 (add2out_strconst out "#")
1475 (add2out_longdec out onum))
1476 (let (
1477 ;; we should not use depth, it is a formal!
1478 (:long envdepth 0)
1479 (toodeep 0)
1480 (nbbind (mapobject_count (get_field :env_bind self)))
1481 (curenv self)
1482 )
1483 (forever
1484 depthloop
1485 (when (>i envdepth 100)
1486 (setq toodeep 1)
1487 (exit depthloop))
1488 (if (is_not_a curenv class_environment)
1489 (exit depthloop))
1490 (setq envdepth (+i envdepth 1))
1491 (setq curenv (get_field :env_prev curenv))
1492 )
1493 (if toodeep (add2out out "~~")
1494 (add2out out "~" envdepth))
1495 (add2out out "_" nbbind)
1496 )
1497 (add2out_strconst out "{")
1498 (let ( (:long offprev (get_int env_prev))
1499 (:long oldmaxdepth (get_int (unsafe_get_field :dbgi_maxdepth dbgi)))
1500 (:long newmaxdepth (-i (/i oldmaxdepth 2) 1))
1501 (:long didshowfields 0)
1502 )
1503 (if (<i newmaxdepth 0)
1504 (setq newmaxdepth 0))
1505 (when (and (<i depth oldmaxdepth)
1506 (is_a dbgi class_debug_output_information))
1507 (and (>i depth 0) (>i oldmaxdepth 3)
1508 (put_int (unsafe_get_field :dbgi_maxdepth dbgi) newmaxdepth))
1509 (dbgout_fields self dbgi (+i depth 1) 0 offprev)
1510 (setq didshowfields 1)
1511 (if (and (<i depth newmaxdepth)
1512 (is_a dbgi class_debug_output_information))
1513 (dbgoutagain_fields self dbgi (+i depth 2) offprev 0)
1514 (add2out_strconst out ".._.."))
1515 (put_int (unsafe_get_field :dbgi_maxdepth dbgi) oldmaxdepth)
1516 )
1517 (when (and (not didshowfields)
1518 (<i (+i depth 3) oldmaxdepth)
1519 (is_a self class_described_environment))
1520 (add2out_strconst out " %")
1521 (dbg_out (get_field :denv_descr self) dbgi (+i depth 2))
1522 )
1523 )
1524 (add2out_strconst out "}")
1525 ))
1526 (install_method class_environment dbg_output dbgout_environment_method)
1529 ;;;; ctype output debug & again
1530 (defun dbgoutagain_ctype_method (self dbgi :long depth)
1531 (let ( (dis (discrim self))
1532 (out (unsafe_get_field :dbgi_out dbgi))
1533 (onam (unsafe_get_field :named_name self)) )
1534 (add2out_strconst out " $!")
1535 (add2out_string out onam)
1536 (add2out_strconst out "!/")
1537 (add2out_longhex out (obj_hash self))
1538 ))
1539 (install_method class_ctype dbg_outputagain dbgoutagain_ctype_method)
1542 (defun dbgout_ctype_method (self dbgi :long depth)
1543 (assert_msg "check dbgi" (is_a dbgi class_debug_information) dbgi)
1544 (assert_msg "check self" (is_a self class_ctype) self)
1545 (if (<=i depth 0)
1546 (dbgout_namedobject_method self dbgi 0)
1547 (dbgoutagain_ctype_method self dbgi depth)
1548 ))
1549 (install_method class_ctype dbg_output dbgout_ctype_method)
1551 ;;;; any binding debug output
1552 (defun dbgout_anybinding_method (self dbgi :long depth)
1553 (assert_msg "check dbgi" (is_a dbgi class_debug_information) dbgi)
1554 (assert_msg "check self" (is_a self class_any_binding) self)
1555 (let ( (dis (discrim self))
1556 (out (unsafe_get_field :dbgi_out dbgi))
1557 (binderv (unsafe_get_field :binder self))
1558 (:long bindnum (get_int self))
1559 (:long maxdepth (get_int (get_field :dbgi_maxdepth dbgi)))
1560 )
1561 (add2out_indent out depth)
1562 (add2out_strconst out "[~")
1563 (add2out_string out (unsafe_get_field :named_name dis))
1564 (add2out_strconst out "/")
1565 (add2out_longhex out (obj_hash self))
1566 (when bindnum
1567 (add2out_strconst out "#")
1568 (add2out_longdec out bindnum))
1569 (add2out_strconst out ":")
1570 (dbg_outputagain binderv dbgi (+i depth 2))
1571 (when (<i depth maxdepth)
1572 (add2out_strconst out "; ")
1573 (dbgout_fields self dbgi (+i depth 1) 1 0)
1574 )
1575 (add2out_strconst out "~]")
1576 ))
1577 (install_method class_any_binding dbg_output dbgout_anybinding_method)
1578 (install_method class_any_binding dbg_outputagain dbgout_anybinding_method)
1580 ;;;;;;;;;;;;;;;;;;;;;;;; less deep debug
1581 (defun debug_less_fun (dbgi v)
1582 (assert_msg "check dbgi" (is_a dbgi class_debug_information))
1583 (let ( (oldmaxdepth (get_field :dbgi_maxdepth dbgi))
1584 (newmaxdepth (box (-i (get_int oldmaxdepth) 1)))
1585 (out (get_field :dbgi_out dbgi))
1586 )
1587 (put_fields dbgi :dbgi_maxdepth newmaxdepth)
1588 (dbg_out v dbgi 1)
1589 (put_fields dbgi :dbgi_maxdepth oldmaxdepth)))
1591 (define debug_less :doc #{$DEBUG_LESS is a $DEBUG manipulator to show the following argument value a bit more briefly.}#
1592 (clone_with_discriminant debug_less_fun discr_debug_closure))
1594 ;;;;;;;;;;;;;;;;;;;;;;;; more deep debug
1595 (defun debug_more_fun (dbgi v)
1596 (assert_msg "check dbgi" (is_a dbgi class_debug_information))
1597 (let ( (oldmaxdepth (get_field :dbgi_maxdepth dbgi))
1598 (newmoredepth (box (+i (get_int oldmaxdepth) 1)))
1599 (newlessdepth (box (-i (get_int oldmaxdepth) 1)))
1600 (out (get_field :dbgi_out dbgi))
1601 )
1602 (put_fields dbgi :dbgi_maxdepth newmoredepth)
1603 (if (is_object v)
1604 (progn
1605 (add2out out (get_field :named_name (discrim v)) "/")
1606 (add2sbuf_longhex out (obj_hash v))
1607 (let ( (:long onum (get_int v))
1608 )
1609 (when onum
1610 (add2sbuf_strconst out "#")
1611 (add2sbuf_longdec out onum))
1612 )
1613 (add2out out "<{")
1614 (dbgout_fields v dbgi 0 0 -1)
1615 (add2out_indentnl out 0)
1616 (add2out out "}>")
1617 (add2out_indentnl out 0))
1618 (dbg_out v dbgi 0))
1619 (put_fields dbgi :dbgi_maxdepth oldmaxdepth)))
1621 (define debug_more :doc #{$DEBUG_MORE is a $DEBUG manipulator to show the following argument value a bit more extensively.}#
1622 (clone_with_discriminant debug_more_fun discr_debug_closure))
1624 ;;;;;;;;;;;;;;;;;;;;;;;; debug message function
1626 ;; this is a rarely used function
1627 (defun display_debug_message (val :cstring msgstr :long count)
1628 :doc #{Display in a debug-style the value $VAL with message raw string $MSGSTR and counter $COUNT. Rarely useful.}#
1629 (let ( (:long dbgcounter 0)
1630 (sbuf (make_strbuf discr_strbuf))
1631 (occmap (make_mapobject discr_map_objects 50))
1632 (boxedmaxdepth (make_integerbox discr_integer 14))
1633 (dbgi (instance class_debug_output_information
1634 :dbgi_out sbuf
1635 :dbgi_occmap occmap
1636 :dbgi_maxdepth boxedmaxdepth))
1637 )
1638 (code_chunk setdbgcounter #{$dbgcounter= ++melt_dbgcounter}#)
1639 (outnum_err "!*!#" dbgcounter "/")
1640 (outnum_err "" (-i (the_framedepth) 1) ":")
1641 (outcstring_err msgstr)
1642 (if (>i count 0) (outnum_err " !" count ": "))
1643 (dbg_output val dbgi 0)
1644 (outstrbuf_err sbuf)
1645 (outnewline_err)
1646 ))
1650 (export_values
1651 dbg_out
1652 dbg_outobject
1653 dbg_output
1654 dbg_outputagain
1655 dbgout_fields
1656 dbgoutagain_fields
1657 debug_depth
1658 debug_less
1659 debug_more
1660 discr_debug_closure
1661 display_debug_message
1662 melt_debug_fun
1663 melt_has_flag_debug_set
1664 melt_really_need_dbglim
1665 melt_really_need_debug
1666 register_basicblock_debug_fun
1667 register_edge_debug_fun
1668 register_gimple_debug_fun
1669 register_gimpleseq_debug_fun
1670 register_loop_debug_fun
1671 register_tree_debug_fun
1672 )
1675 ;; eof warmelt-debug.melt