source: trunk/source/lisp-kernel/x86_print.c @ 14599

Last change on this file since 14599 was 14599, checked in by gb, 9 years ago

In the kernel debugger's printer, don't assume that a method-function's
name is an instance (the method object itself.)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 12.2 KB
Line 
1/*
2   Copyright (C) 2005-2009, Clozure Associates
3   This file is part of Clozure CL. 
4
5   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
6   License , known as the LLGPL and distributed with Clozure CL as the
7   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
8   which is distributed with Clozure CL as the file "LGPL".  Where these
9   conflict, the preamble takes precedence. 
10
11   Clozure CL is referenced in the preamble as the "LIBRARY."
12
13   The LLGPL is also available online at
14   http://opensource.franz.com/preamble.html
15*/
16
17#include <stdio.h>
18#include <stdarg.h>
19#include <setjmp.h>
20
21#include "lisp.h"
22#include "area.h"
23#include "lisp-exceptions.h"
24#include "lisp_globals.h"
25
26void
27sprint_lisp_object(LispObj, int);
28
29#define PBUFLEN 252
30
31char printbuf[PBUFLEN + 4];
32int bufpos = 0;
33
34jmp_buf escape;
35
36void
37add_char(char c)
38{
39  if (bufpos >= PBUFLEN) {
40    longjmp(escape, 1);
41  } else {
42    printbuf[bufpos++] = c;
43  }
44}
45
46void
47add_string(char *s, int len) 
48{
49  while(len--) {
50    add_char(*s++);
51  }
52}
53
54void
55add_lisp_base_string(LispObj str)
56{
57  lisp_char_code *src = (lisp_char_code *)  (ptr_from_lispobj(str + misc_data_offset));
58  natural i, n = header_element_count(header_of(str));
59
60  for (i=0; i < n; i++) {
61    add_char((char)(*src++));
62  }
63}
64
65void
66add_c_string(char *s)
67{
68  add_string(s, strlen(s));
69}
70
71char numbuf[64], *digits = "0123456789ABCDEF";
72
73
74void
75sprint_unsigned_decimal_aux(natural n, Boolean first)
76{
77  if (n == 0) {
78    if (first) {
79      add_char('0');
80    }
81  } else {
82    sprint_unsigned_decimal_aux(n/10, false);
83    add_char(digits[n%10]);
84  }
85}
86
87void
88sprint_unsigned_decimal(natural n)
89{
90  sprint_unsigned_decimal_aux(n, true);
91}
92
93void
94sprint_signed_decimal(signed_natural n)
95{
96  if (n < 0) {
97    add_char('-');
98    n = -n;
99  }
100  sprint_unsigned_decimal(n);
101}
102
103
104void
105sprint_unsigned_hex(natural n)
106{
107  int i, 
108    ndigits =
109#if WORD_SIZE == 64
110    16
111#else
112    8
113#endif
114    ;
115
116  add_c_string("#x");
117  for (i = 0; i < ndigits; i++) {
118    add_char(digits[(n>>(4*(ndigits-(i+1))))&15]);
119  }
120}
121
122void
123sprint_list(LispObj o, int depth)
124{
125  LispObj the_cdr;
126 
127  add_char('(');
128  while(1) {
129    if (o != lisp_nil) {
130      sprint_lisp_object(ptr_to_lispobj(car(o)), depth);
131      the_cdr = ptr_to_lispobj(cdr(o));
132      if (the_cdr != lisp_nil) {
133        add_char(' ');
134        if (fulltag_of(the_cdr) == fulltag_cons) {
135          o = the_cdr;
136          continue;
137        }
138        add_c_string(". ");
139        sprint_lisp_object(the_cdr, depth);
140        break;
141      }
142    }
143    break;
144  }
145  add_char(')');
146}
147
148/*
149  Print a list of method specializers, using the class name instead of the class object.
150*/
151
152void
153sprint_specializers_list(LispObj o, int depth)
154{
155  LispObj the_cdr, the_car;
156 
157  add_char('(');
158  while(1) {
159    if (o != lisp_nil) {
160      the_car = car(o);
161      if (fulltag_of(the_car) == fulltag_misc) {
162        sprint_lisp_object(deref(deref(the_car,3), 4), depth);
163      } else {
164        sprint_lisp_object(the_car, depth);
165      }
166      the_cdr = cdr(o);
167      if (the_cdr != lisp_nil) {
168        add_char(' ');
169        if (fulltag_of(the_cdr) == fulltag_cons) {
170          o = the_cdr;
171          continue;
172        }
173        add_c_string(". ");
174        sprint_lisp_object(the_cdr, depth);
175        break;
176      }
177    }
178    break;
179  }
180  add_char(')');
181}
182
183char *
184vector_subtag_name(unsigned subtag)
185{
186  switch (subtag) {
187  case subtag_bit_vector:
188    return "BIT-VECTOR";
189    break;
190  case subtag_instance:
191    return "INSTANCE";
192    break;
193  case subtag_bignum:
194    return "BIGNUM";
195    break;
196  case subtag_u8_vector:
197    return "(UNSIGNED-BYTE 8)";
198    break;
199  case subtag_s8_vector:
200    return "(SIGNED-BYTE 8)";
201    break;
202  case subtag_u16_vector:
203    return "(UNSIGNED-BYTE 16)";
204    break;
205  case subtag_s16_vector:
206    return "(SIGNED-BYTE 16)";
207    break;
208  case subtag_u32_vector:
209    return "(UNSIGNED-BYTE 32)";
210    break;
211  case subtag_s32_vector:
212    return "(SIGNED-BYTE 32)";
213    break;
214#ifdef X8664
215  case subtag_u64_vector:
216    return "(UNSIGNED-BYTE 64)";
217    break;
218  case subtag_s64_vector:
219    return "(SIGNED-BYTE 64)";
220    break;
221#endif
222  case subtag_package:
223    return "PACKAGE";
224    break;
225  case subtag_slot_vector:
226    return "SLOT-VECTOR";
227    break;
228  default:
229    return "";
230    break;
231  }
232}
233
234
235void
236sprint_random_vector(LispObj o, unsigned subtag, natural elements)
237{
238  add_c_string("#<");
239  sprint_unsigned_decimal(elements);
240  add_c_string("-element vector subtag = #x");
241  add_char(digits[subtag>>4]);
242  add_char(digits[subtag&15]);
243  add_c_string(" @");
244  sprint_unsigned_hex(o);
245  add_c_string(" (");
246  add_c_string(vector_subtag_name(subtag));
247  add_c_string(")>");
248}
249
250void
251sprint_symbol(LispObj o)
252{
253  lispsymbol *rawsym = (lispsymbol *) ptr_from_lispobj(untag(o));
254  LispObj
255    pname = rawsym->pname,
256    package = rawsym->package_predicate;
257
258  if (fulltag_of(package) == fulltag_cons) {
259    package = car(package);
260  }
261
262  if (package == nrs_KEYWORD_PACKAGE.vcell) {
263    add_char(':');
264  }
265  add_lisp_base_string(pname);
266}
267
268#ifdef X8632
269LispObj
270nth_immediate(LispObj o, unsigned n)
271{
272  u16_t imm_word_count = *(u16_t *)(o + misc_data_offset);
273  natural *constants = (natural *)((char *)o + misc_data_offset + (imm_word_count << 2));
274  LispObj result = (LispObj)(constants[n-1]);
275
276  return result;
277}
278#endif
279
280void
281sprint_function(LispObj o, int depth)
282{
283  LispObj lfbits, header, name = lisp_nil;
284  natural elements;
285
286  header = header_of(o);
287  elements = header_element_count(header);
288  lfbits = deref(o, elements);
289
290  if ((lfbits & lfbits_noname_mask) == 0) {
291    name = deref(o, elements-1);
292  }
293 
294  add_c_string("#<");
295  if (name == lisp_nil) {
296    add_c_string("Anonymous Function ");
297  } else {
298    if (lfbits & lfbits_method_mask) {
299      if (header_subtag(header_of(name)) == subtag_instance) {
300        LispObj
301          slot_vector = deref(name,3),
302          method_name = deref(slot_vector, 6),
303          method_qualifiers = deref(slot_vector, 2),
304          method_specializers = deref(slot_vector, 3);
305        add_c_string("Method-Function ");
306        sprint_lisp_object(method_name, depth);
307        add_char(' ');
308        if (method_qualifiers != lisp_nil) {
309          if (cdr(method_qualifiers) == lisp_nil) {
310            sprint_lisp_object(car(method_qualifiers), depth);
311          } else {
312            sprint_lisp_object(method_qualifiers, depth);
313          }
314          add_char(' ');
315        }
316        sprint_specializers_list(method_specializers, depth);
317      }
318      else {
319        sprint_lisp_object(name,depth);
320      }
321      add_char(' ');
322    } else if (lfbits & lfbits_gfn_mask) {
323      add_c_string("Generic Function ");
324
325#ifdef X8632
326      {
327        LispObj gf_slots = nth_immediate(o, 2);
328        LispObj gf_name = deref(gf_slots, 2);
329
330        sprint_lisp_object(gf_name, depth);
331        add_char(' ');
332      }
333#endif
334    } else {
335      add_c_string("Function ");
336      sprint_lisp_object(name, depth);
337      add_char(' ');
338    }
339  }
340  sprint_unsigned_hex(o);
341  add_char('>');
342}
343
344void
345sprint_tra(LispObj o, int depth)
346{
347#ifdef X8664
348  signed sdisp;
349  unsigned disp = 0;
350  LispObj f = 0;
351
352  if ((*((unsigned short *)o) == RECOVER_FN_FROM_RIP_WORD0) &&
353      (*((unsigned char *)(o+2)) == RECOVER_FN_FROM_RIP_BYTE2)) {
354    sdisp = (*(int *) (o+3));
355    f = RECOVER_FN_FROM_RIP_LENGTH+o+sdisp;
356    disp = o-f;
357  }
358
359  if (fulltag_of(f) == fulltag_function) {
360    add_c_string("tagged return address: ");
361    sprint_function(f, depth);
362    add_c_string(" + ");
363    sprint_unsigned_decimal(disp);
364  } else {
365    add_c_string("(tra ?) : ");
366    sprint_unsigned_hex(o);
367  }
368#else
369  LispObj f = 0;
370  unsigned disp = 0;
371
372  if (*(unsigned char *)o == RECOVER_FN_OPCODE) {
373    f = (LispObj)(*((natural *)(o + 1)));
374    disp = o - f;
375  }
376
377  if (f && header_subtag(header_of(f)) == subtag_function) {
378    add_c_string("tagged return address: ");
379    sprint_function(f, depth);
380    add_c_string(" + ");
381    sprint_unsigned_decimal(disp);
382  } else {
383    add_c_string("(tra ?) : ");
384    sprint_unsigned_hex(o);
385  }
386#endif
387}
388               
389void
390sprint_gvector(LispObj o, int depth)
391{
392  LispObj header = header_of(o);
393  unsigned 
394    elements = header_element_count(header),
395    subtag = header_subtag(header);
396   
397  switch(subtag) {
398  case subtag_function:
399    sprint_function(o, depth);
400    break;
401   
402  case subtag_symbol:
403    sprint_symbol(o);
404    break;
405   
406  case subtag_struct:
407  case subtag_istruct:
408    add_c_string("#<");
409    sprint_lisp_object(deref(o,1), depth);
410    add_c_string(" @");
411    sprint_unsigned_hex(o);
412    add_c_string(">");
413    break;
414   
415  case subtag_simple_vector:
416    {
417      int i;
418      add_c_string("#(");
419      for(i = 1; i <= elements; i++) {
420        if (i > 1) {
421          add_char(' ');
422        }
423        sprint_lisp_object(deref(o, i), depth);
424      }
425      add_char(')');
426      break;
427    }
428
429  case subtag_instance:
430    {
431      LispObj class_or_hash = deref(o,1);
432     
433      if (tag_of(class_or_hash) == tag_fixnum) {
434        sprint_random_vector(o, subtag, elements);
435      } else {
436        add_c_string("#<CLASS ");
437        sprint_lisp_object(class_or_hash, depth);
438        add_c_string(" @");
439        sprint_unsigned_hex(o);
440        add_c_string(">");
441      }
442      break;
443    }
444
445       
446     
447  default:
448    sprint_random_vector(o, subtag, elements);
449    break;
450  }
451}
452
453void
454sprint_ivector(LispObj o)
455{
456  LispObj header = header_of(o);
457  unsigned 
458    elements = header_element_count(header),
459    subtag = header_subtag(header);
460   
461  switch(subtag) {
462  case subtag_simple_base_string:
463    add_char('"');
464    add_lisp_base_string(o);
465    add_char('"');
466    return;
467   
468  case subtag_bignum:
469    if (elements == 1) {
470      sprint_signed_decimal((signed_natural)(deref(o, 1)));
471      return;
472    }
473    if ((elements == 2) && (deref(o, 2) == 0)) {
474      sprint_unsigned_decimal(deref(o, 1));
475      return;
476    }
477    break;
478   
479  case subtag_double_float:
480    break;
481
482  case subtag_macptr:
483    add_c_string("#<MACPTR ");
484    sprint_unsigned_hex(deref(o,1));
485    add_c_string(">");
486    break;
487
488  default:
489    sprint_random_vector(o, subtag, elements);
490  }
491}
492
493void
494sprint_vector(LispObj o, int depth)
495{
496  LispObj header = header_of(o);
497 
498  if (immheader_tag_p(fulltag_of(header))) {
499    sprint_ivector(o);
500  } else {
501    sprint_gvector(o, depth);
502  }
503}
504
505void
506sprint_lisp_object(LispObj o, int depth) 
507{
508  if (--depth < 0) {
509    add_char('#');
510  } else {
511    switch (fulltag_of(o)) {
512    case fulltag_even_fixnum:
513    case fulltag_odd_fixnum:
514      sprint_signed_decimal(unbox_fixnum(o));
515      break;
516   
517#ifdef X8664
518    case fulltag_immheader_0:
519    case fulltag_immheader_1:
520    case fulltag_immheader_2:
521    case fulltag_nodeheader_0:
522    case fulltag_nodeheader_1:
523#else
524    case fulltag_immheader:
525    case fulltag_nodeheader:
526#endif     
527      add_c_string("#<header ? ");
528      sprint_unsigned_hex(o);
529      add_c_string(">");
530      break;
531
532#ifdef X8664
533    case fulltag_imm_0:
534    case fulltag_imm_1:
535#else
536    case fulltag_imm:
537#endif
538      if (o == unbound) {
539        add_c_string("#<Unbound>");
540      } else {
541        if (header_subtag(o) == subtag_character) {
542          unsigned c = (o >> charcode_shift);
543          add_c_string("#\\");
544          if ((c >= ' ') && (c < 0x7f)) {
545            add_char(c);
546          } else {
547            sprintf(numbuf, "%#o", c);
548            add_c_string(numbuf);
549          }
550#ifdef X8664
551        } else if (header_subtag(o) == subtag_single_float) {
552          LispObj xx = o;
553          float f = ((float *)&xx)[1];
554          sprintf(numbuf, "%f", f);
555          add_c_string(numbuf);
556#endif
557        } else {
558
559          add_c_string("#<imm ");
560          sprint_unsigned_hex(o);
561          add_c_string(">");
562        }
563      }
564      break;
565
566#ifdef X8664
567    case fulltag_nil:
568#endif
569    case fulltag_cons:
570      sprint_list(o, depth);
571      break;
572     
573    case fulltag_misc:
574      sprint_vector(o, depth);
575      break;
576
577#ifdef X8664
578    case fulltag_symbol:
579      sprint_symbol(o);
580      break;
581
582    case fulltag_function:
583      sprint_function(o, depth);
584      break;
585#endif
586
587#ifdef X8664
588    case fulltag_tra_0:
589    case fulltag_tra_1:
590#else
591    case fulltag_tra:
592#endif
593      sprint_tra(o,depth);
594      break;
595    }
596  }
597}
598
599char *
600print_lisp_object(LispObj o)
601{
602  bufpos = 0;
603  if (setjmp(escape) == 0) {
604    sprint_lisp_object(o, 5);
605    printbuf[bufpos] = 0;
606  } else {
607    printbuf[PBUFLEN+0] = '.';
608    printbuf[PBUFLEN+1] = '.';
609    printbuf[PBUFLEN+2] = '.';
610    printbuf[PBUFLEN+3] = 0;
611  }
612  return printbuf;
613}
Note: See TracBrowser for help on using the repository browser.