; Copyright (c) 1993-1999 by Richard Kelsey. See file COPYING.
; Pretty-printing the node tree
; Sample output:
; 34 (F_12 (C_11 UNIT_0)
; (SET-CONTENTS 1 C_11 UNIT_0 UNIT '0 ^F_14))
;
; 35 (F_14 (C_13 N_1)
; 36 (LET* (((LOOP_73) (CONS CELL '0))
; 37 (() (SET-CONTENTS LOOP_73 CELL '0 ^F_34))
; 38 ((V_77) (CONTENTS LOOP_73 CELL '0)))
; (V_77 1 C_13 N_1 '1)))
;
; 39 (F_34 (C_33 I_9 R_7)
; 40 (LET* (((V_61) (CONTENTS UNIT_0 UNIT '3))
; 41 ((V_63) (V_61 I_9 '0)))
; (TRUE? 2 ^C_58 ^C_41 V_63)))
;
; 42 (C_58 ()
; (C_33 0 R_7))
;
; 43 (C_41 ()
; 44 (LET* (((V_46) (CONTENTS UNIT_0 UNIT '2))
; 45 ((V_56) (V_46 I_9 R_7))
; 46 ((V_44) (CONTENTS UNIT_0 UNIT '1))
; 47 ((V_54) (V_44 I_9 '1))
; 48 ((V_52) (CONTENTS LOOP_73 CELL '0)))
; (V_52 1 C_33 V_54 V_56)))
; What it means:
; Variables `<name>_<id>' V_61
; Primops `<primop name>' CONTENTS
; Lambdas `^<self variable>' ^F_34
; Literals `'<value>' '0
; 35 (F_14 (C_13 N_1)
; This is the header for a lambda node. `35' is the object hash of the node.
; `F_14' is the LAMBDA-NAME and LAMBDA-ID, `(C_13 N_1)' is the variable list. The
; start of this line (not counting the object hash) is indented one column
; more than the start of the lexically superior lambda.
; 36 (LET* (((LOOP_73) (CONS CELL '0))
; 37 (() (SET-CONTENTS LOOP_73 CELL '0 ^F_34))
; 38 ((V_77) (CONTENTS LOOP_73 CELL '0)))
; (V_77 1 C_13 N_1 '1)))
; This is the body of the lambda. It is a block consisting of three simple
; calls and then a tail recursive call. The simple calls are in the form
; of a LET* that allows multiple value returns. The actual body of the
; lambda is the call `(CONS CELL '0)'. The continuation to this call is
; a lambda node `(LAMBDA (LOOP_73) (SET-CONTENTS ...))'. `36' is the
; object hash of this continuation lambda.
; After the block any lambdas in the block are printed. This lambda is
; followed by `F_34'.
; (PP-CPS node . port)
;---------------------------------------------------------------------------
; Print CPS node tree in linear form. Port defaults to the current output port.
; This just dispatches on the type of NODE.
(define (pp-cps node . port)
(let* ((port (if (null? port) (current-output-port) (car port)))
(port (if (current-column port)
port
(make-tracking-output-port port))))
(set! *rereadable?* #f)
(cond ((lambda-node? node)
(pp-cps-lambda node 4 port))
((call-node? node)
(write-non-simple-call node port))
(else
(write-node-value node port)))
(newline port)
((structure-ref i/o force-output) port)))
(define (rereadable-pp-cps node port)
(set! *rereadable?* #t)
(pp-cps-lambda node 4 port)
(values))
(define (indent port count)
(let ((count (cond ((<= (current-column port) count)
(- count (current-column port)))
(else
(newline port)
count))))
(do ((count count (- count 1)))
((>= 0 count))
(writec port #\space))))
(define *rereadable?* #f)
(define *next-pp-id* 0)
(define (reset-pp-cps)
(set! *next-pp-id* 0))
(define (next-pp-id)
(let ((id *next-pp-id*))
(set! *next-pp-id* (+ *next-pp-id* 1))
id))
; Print a lambda node by printing its identifiers, then its call, and finally
; any other lambdas that it includes.
(define (pp-cps-lambda node indent-to port)
(format port "~&~%")
(cond ((not *rereadable?*)
(node-hash node)
(format port "~D" (lambda-id node))))
(indent port indent-to)
(write-lambda-header node port)
(let ((internal (pp-cps-body (lambda-body node) indent-to port)))
(writec port #\))
(for-each (lambda (n)
(pp-cps-lambda n (+ indent-to 1) port))
internal)))
(define (write-lambda-header node port)
(writec port '#\()
(writec port (case (lambda-type node)
((proc known-proc) #\P)
((cont) #\C)
((jump) #\J)
((escape) #\E)))
(writec port #\space)
(print-lambda-name node port)
(writec port #\space)
(write-lambda-vars node port))
(define (write-lambda-vars node port)
(let ((vars (lambda-variables node)))
(cond ((not (null? vars))
(writec port '#\()
(print-variable-name (car vars) port)
(do ((v (cdr vars) (cdr v)))
((null? v))
(writec port '#\space)
(print-variable-name (car v) port))
(writec port '#\)))
(else
(format port "()")))))
; Print the body of a lambda node. A simple call is one that has exactly
; one exit. They and calls to lambda nodes are printed as a LET*.
(define (pp-cps-body call indent-to port)
(newline port)
(cond ((or (simple-call? call)
(let-call? call))
(write-let* call indent-to port))
(else
(indent port (+ '2 indent-to))
(write-non-simple-call call port))))
; Write out a series of calls as a LET*. The LET* ends when a call is reached
; that is neither a simple call or a call to a lambda.
(define (write-let* call indent-to port)
(cond ((not *rereadable?*)
(node-hash (call-arg call 0))
(format port "~D" (lambda-id (call-arg call '0)))))
(indent port (+ '2 indent-to))
(writec port '#\()
(format port "LET* ")
(writec port '#\()
(let loop ((call (next-call call))
(ns (write-simple-call call indent-to port)))
(cond ((or (simple-call? call)
(let-call? call))
(newline port)
(cond ((not *rereadable?*)
(format port "~D" (lambda-id (call-arg call '0)))
(node-hash (call-arg call 0))))
(indent port (+ '9 indent-to))
(loop (next-call call)
(append (write-simple-call call indent-to port) ns)))
(else
(writec port '#\))
(newline port)
(indent port (+ '4 indent-to))
(let ((ns (append (write-non-simple-call call port) ns)))
(writec port '#\))
ns)))))
(define (simple-call? call)
(and (= '1 (call-exits call))
(not (lambda-block (call-arg call 0)))))
(define (let-call? call)
(calls-this-primop? call 'let))
; Get the call that follows CALL in a LET*.
(define (next-call call)
(lambda-body (call-arg call '0)))
; Write out one line of a LET*.
(define (write-simple-call call indent-to port)
(if (let-call? call)
(write-let-call call indent-to port)
(really-write-simple-call call indent-to port)))
; Write the variables bound by the continuation and then the primop and
; non-continuation arguments of the call.
(define (really-write-simple-call call indent-to port)
(writec port '#\()
(write-lambda-vars (call-arg call '0) port)
(indent port (+ indent-to '21))
(writec port '#\()
(format port "~S" (primop-id (call-primop call)))
(write-call-args call '1 port)
(writec port '#\))
(find-lambda-nodes call 1))
; Write the variables of the lambda and then the values of the arguments.
(define (write-let-call call indent-to port)
(writec port '#\()
(write-lambda-vars (call-arg call '0) port)
(cond ((= '1 (vector-length (call-args call)))
(writec port '#\))
'())
(else
(writec port #\*)
(indent port (+ indent-to '21))
(write-node-value (call-arg call '1) port)
(write-call-args call '2 port)
(find-lambda-nodes call 1))))
(define (find-lambda-nodes call start)
(reverse (let label ((call call) (start start) (ls '()))
(do ((i start (+ i 1))
(ls ls (let ((arg (call-arg call i)))
(cond ((call-node? arg)
(label arg 0 ls))
((lambda-node? arg)
(cons arg ls))
(else ls)))))
((>= i (call-arg-count call))
ls)))))
; Write out a call that ends a LET* block.
(define (write-non-simple-call call port)
(writec port '#\()
(format port "~A ~D" (primop-id (call-primop call)) (call-exits call))
(write-call-args call '0 port)
(find-lambda-nodes call 0))
; Write out the arguments of CALL starting with START.
(define (write-call-args call start port)
(let* ((vec (call-args call))
(len (vector-length vec)))
(do ((i start (+ i '1)))
((>= i len))
(writec port '#\space)
(write-node-value (vector-ref vec i) port))
(writec port '#\))))
; Print out a literal value.
(define (cps-print-literal value port)
(format port "'~S" value))
; Dispatch on the type of NODE to get the appropriate printing method.
(define (write-node-value node port)
(cond ((not (node? node))
(format port "{not a node}"))
((lambda-node? node)
(writec port '#\^)
(print-lambda-name node port))
((call-node? node)
(format port "(~S" (primop-id (call-primop node)))
(write-call-args node '0 port))
((literal-node? node)
(cps-print-literal (literal-value node) port))
((reference-node? node)
(print-variable-name (reference-variable node) port))
(else
(bug "WRITE-NODE-VALUE got funny node ~S" node))))
; Printing variables and lambda nodes
; #T if variables are supposed to print as the name of the register containing
; them instead of their name.
(define *pp-register-names?* '#f)
; A whole bunch of different entry points for printing variables in slightly
; different ways.
(define (print-variable-name var port)
(cond ((not var)
(format port "#f"))
; ((and *pp-register-names?*
; (reg? (variable-register var)))
; (format port "~S" (reg-name (variable-register var))))
(else
(let ((id (cond ((not *rereadable?*)
(variable-id var))
((variable-flag var)
=> identity)
(else
(let ((id (next-pp-id)))
(set-variable-flag! var id)
id)))))
(format port "~S_~S" (variable-name var) id)))))
; Same as the above without the check for a register.
(define (print-variable-plain-name var port)
(cond ((not var)
(format port "#f"))
(else
(format port "~S_~D" (variable-name var) (variable-id var)))))
; Return the name as a string.
(define (variable-print-name var)
(print-variable-name var '#f))
; Return the name as a symbol.
(define (variable-unique-name var)
(string->symbol (variable-print-name var)))
; Printing lambda-nodes as variables
(define (print-lambda-name lnode port)
(let ((id (cond ((not *rereadable?*)
(lambda-id lnode))
((node-flag lnode)
=> identity)
(else
(let ((id (next-pp-id)))
(set-node-flag! lnode id)
id)))))
(format port "~S_~D" (lambda-name lnode) id)))
(define (lambda-print-name lnode)
(print-lambda-name lnode '#f))
(define (lambda-unique-name lnode)
(string->symbol (lambda-print-name lnode)))