source: release/1.9/source/lisp-kernel/x86_print.c @ 16083

Last change on this file since 16083 was 15373, checked in by gb, 7 years ago

Suppress some warnings from llvm.

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