cgen/pprint.scm

   1 ;;;; pprint.scm --- pretty-printing objects for CGEN
   2 ;;;; Copyright (C) 2005, 2009 Red Hat, Inc.
   3 ;;;; This file is part of CGEN.
   4 ;;;; See file COPYING.CGEN for details.
   5
   6 ;;; This file defines a printing function PPRINT, and some hooks to
   7 ;;; let you print certain kind of objects in a summary way, and get at
   8 ;;; their full values later.
   9
  10 ;;; PPRINT is a printer for Scheme objects that prints lists or
  11 ;;; vectors that contain shared structure or cycles and prints them in
  12 ;;; a finite, legible way.
  13 ;;;
  14 ;;; Ordinary values print in the usual way:
  15 ;;;
  16 ;;;   guile> (pprint '(1 #(2 3) 4))
  17 ;;;   (1 #(2 3) 4)
  18 ;;;
  19 ;;; Values can share structure:
  20 ;;;
  21 ;;;   guile> (let* ((c (list 1 2))
  22 ;;;                 (d (list c c)))
  23 ;;;            (write d)
  24 ;;;            (newline))
  25 ;;;   ((1 2) (1 2))
  26 ;;;
  27 ;;; In that list, the two instances of (1 2) are actually the same object;
  28 ;;; the top-level list refers to the same object twice.
  29 ;;;
  30 ;;; Printing that structure with PPRINT shows the sharing:
  31 ;;;
  32 ;;;   guile> (let* ((c (list 1 2))
  33 ;;;                 (d (list c c)))
  34 ;;;            (pprint d))
  35 ;;;   (#0=(1 2) #0#)
  36 ;;;
  37 ;;; Here the "#0=" before the list (1 2) labels it with the number
  38 ;;; zero.  Then, the "#0#" as the second element of the top-level list
  39 ;;; indicates that the object appears here, too, referring to it by
  40 ;;; its label.
  41 ;;;
  42 ;;; If you have several objects that appear more than once, they each
  43 ;;; get a separate label:
  44 ;;;
  45 ;;;   guile> (let* ((a (list 1 2))
  46 ;;;                 (b (list 3 4))
  47 ;;;                 (c (list a b a b)))
  48 ;;;            (pprint c))
  49 ;;;   (#0=(1 2) #1=(3 4) #0# #1#)
  50 ;;;
  51 ;;; Cyclic values just share structure with themselves:
  52 ;;;
  53 ;;;   guile> (let* ((a (list 1 #f)))
  54 ;;;            (set-cdr! a a)
  55 ;;;            (pprint a))
  56 ;;;   #0=(1 . #0#)
  57 ;;;
  58 ;;;
  59 ;;; PPRINT also consults the function ELIDE? and ELIDED-NAME to see
  60 ;;; whether it should print a value in a summary form.  You can
  61 ;;; re-define those functions to customize PPRINT's behavior;
  62 ;;; cos-pprint.scm defines them to handle COS objects and classes
  63 ;;; nicely.
  64 ;;;
  65 ;;; (ELIDE? OBJ) should return true if OBJ should be elided.
  66 ;;; (ELIDED-NAME OBJ) should return a (non-cyclic!) object to be used
  67 ;;; as OBJ's abbreviated form.
  68 ;;;
  69 ;;; PPRINT prints an elided object as a list ($ N NAME), where NAME is
  70 ;;; the value returned by ELIDED-NAME to stand for the object, and N
  71 ;;; is a number; each elided object gets its own number.  You can refer
  72 ;;; to the elided object number N as ($ N).
  73 ;;;
  74 ;;; For example, if you've loaded CGEN, pprint.scm, and cos-pprint.scm
  75 ;;; (you must load cos-pprint.scm *after* loading pprint.scm), you can
  76 ;;; print a list containing the <insn> and <ident> classes:
  77 ;;;
  78 ;;;   guile> (pprint (list <insn> <ident>))
  79 ;;;   (($ 1 (class <insn>)) ($ 2 (class <ident>)))
  80 ;;;   guile> (class-name ($ 1))
  81 ;;;   <insn>
  82 ;;;   guile> (class-name ($ 2))
  83 ;;;   <ident>
  84 ;;;
  85 ;;; As a special case, PPRINT never elides the object that was passed
  86 ;;; to it directly.  So you can look inside an elided object by doing
  87 ;;; just that:
  88 ;;;
  89 ;;;   guile> (pprint ($ 2))
  90 ;;;   #0=#("class" <ident> () ((name #:unbound #f . 0) ...
  91 ;;;
  92
  93
  94 ;;; A list of elided objects, larger numbers first, and the number of
  95 ;;; the first element.
  96 (define elide-table '())
  97 (define elide-table-last -1)
  98
  99 ;;; Add OBJ to the elided object list, and return its number.
 100 (define (add-elided-object obj)
 101   (set! elide-table (cons obj elide-table))
 102   (set! elide-table-last (+ elide-table-last 1))
 103   elide-table-last)
 104
 105 ;;; Referencing elided objects.
 106 (define ($ n)
 107   (if (<= 0 n elide-table-last)
 108       (list-ref elide-table (- elide-table-last n))
 109       "no such object"))
 110
 111 ;;; A default predicate for elision.
 112 (define (elide? obj) #f)
 113
 114 ;;; If (elide? OBJ) is true, return some sort of abbreviated list
 115 ;;; structure that might be helpful to the user in identifying the
 116 ;;; elided object.
 117 ;;; A default definition.
 118 (define (elided-name obj) "")
 119
 120 ;;; This is a pretty-printer that handles cyclic and shared structure.
 121 (define (pprint original-obj)
 122
 123   ;; Return true if OBJ should be elided in this call to pprint.
 124   ;; (We never elide the object we were passed itself.)
 125   (define (elide-this-call? obj)
 126     (and (not (eq? obj original-obj))
 127          (elide? obj)))
 128
 129   ;; First, traverse OBJ and build a hash table mapping objects
 130   ;; referenced more than once to #t, and everything else to #f.
 131   ;; (Only include entries for objects that might be interior nodes:
 132   ;; pairs and vectors.)
 133   (let ((shared
 134          ;; Guile's stupid hash tables don't resize the table; the
 135          ;; chains just get longer and longer.  So we need a big value here.
 136          (let ((seen   (make-hash-table 65521))
 137                (shared (make-hash-table 4093)))
 138            (define (walk! obj)
 139              (if (or (pair? obj) (vector? obj))
 140                  (if (hashq-ref seen obj)
 141                      (hashq-set! shared obj #t)
 142                      (begin
 143                        (hashq-set! seen obj #t)
 144                        (cond ((elide-this-call? obj))
 145                              ((pair? obj) (begin (walk! (car obj))
 146                                                  (walk! (cdr obj))))
 147                              ((vector? obj) (do ((i 0 (+ i 1)))
 148                                                  ((>= i (vector-length obj)))
 149                                                (walk! (vector-ref obj i))))
 150                              (else (error "unhandled interior type")))))))
 151            (walk! original-obj)
 152            shared)))
 153
 154     ;; A counter for shared structure labels.
 155     (define fresh-shared-label
 156       (let ((n 0))
 157         (lambda ()
 158           (let ((l n))
 159             (set! n (+ n 1))
 160             l))))
 161
 162     (define (print obj)
 163       (print-with-label obj (hashq-ref shared obj)))
 164
 165     ;; Print an object OBJ, which SHARED maps to L.
 166     ;; L is always (hashq-ref shared obj), but we have that value handy
 167     ;; at times, so this entry point lets us avoid looking it up again.
 168     (define (print-with-label obj label)
 169       (if (number? label)
 170           ;; If we've already visited this object, just print a
 171           ;; reference to its label.
 172           (map display `("#" ,label "#"))
 173           (begin
 174             ;; If it needs a label, attach one now.
 175             (if (eqv? label #t) (let ((label (fresh-shared-label)))
 176                                   (hashq-set! shared obj label)
 177                                   (map display `("#" ,label "="))))
 178             ;; Print the object.
 179             (cond ((elide-this-call? obj)
 180                    (write (list '$ (add-elided-object obj) (elided-name obj))))
 181                   ((pair? obj) (begin (display "(")
 182                                       (print-tail obj)))
 183                   ((vector? obj) (begin (display "#(")
 184                                         (do ((i 0 (+ i 1)))
 185                                             ((>= i (vector-length obj)))
 186                                           (print (vector-ref obj i))
 187                                           (if (< (+ i 1) (vector-length obj))
 188                                               (display " ")))
 189                                         (display ")")))
 190                   (else (write obj))))))
 191
 192     ;; Print a pair P as if it were the tail of a list; assume the
 193     ;; opening paren and any previous elements have been printed.
 194     (define (print-tail obj)
 195       (print (car obj))
 196       (force-output)
 197       (let ((tail (cdr obj)))
 198         (if (null? tail)
 199             (display ")")
 200             ;; We use the dotted pair syntax if the cdr isn't a pair, but
 201             ;; also if it needs to be labeled.
 202             (let ((tail-label (hashq-ref shared tail)))
 203               (if (or (not (pair? tail)) tail-label)
 204                   (begin (display " . ")
 205                          (print-with-label tail tail-label)
 206                          (display ")"))
 207                   (begin (display " ")
 208                          (print-tail tail)))))))
 209
 210     (print original-obj)
 211     (newline)))
 212