; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.

; Printing the node tree as Scheme code

; Sample output:

;  (LAMBDA (C_11 UNIT_0)
;    (SET-CONTENTS 1 C_11 UNIT_0 UNIT '0
;      (LAMBDA (C_13 N_1)
;        (LET ((LOOP_73 (CONS CELL '0)))
;          (SET-CONTENTS LOOP_73 CELL '0
;            (LAMBDA (C_33 I_9 R_7)
;              (LET* ((V_61 (CONTENTS UNIT_0 UNIT '3))
;                     (V_63 (V_61 I_9 '0)))
;                (IF (TRUE? V_63)
;                    (C_33 0 R_7)
;                    (LET* ((V_46 (CONTENTS UNIT_0 UNIT '2))
;                           (V_56 (V_46 I_9 R_7))
;                           (V_44 (CONTENTS UNIT_0 UNIT '1))
;                           (V_54 (V_44 I_9 '1))
;                           (V_52 (CONTENTS LOOP_73 CELL '0)))
;                      (V_52 1 C_33 V_54 V_56))))))
;          (LET ((V_77 (CONTENTS LOOP_73 CELL '0)))
;            (V_77 1 C_13 N_1 '1))))))

; (CPS->SCHEME node port)
;---------------------------------------------------------------------------
; Print CPS node tree in linear form.  This just dispatches on the type of NODE.

(define (cps->scheme node port)
  (set! *next-pp-id* 0)
  (let* ((port (if (current-column port)
		   port
		   (make-tracking-output-port port))))
    (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)))

(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 *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 "~&~%")
  (indent port indent-to)
  (display "(lambda " port)
  (write-lambda-vars node port)
  (pp-cps-body (lambda-body node) indent-to port)
  (writec port #\)))

(define (write-lambda-vars node port)
  (let ((vars (if (proc-lambda? node)
		  (cdr (lambda-variables node))  ; ignore cont var
		  (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)
  (indent indent-to port)
  (cond ((table-ref primop-print-table (primop-id (call-primop call)))
	 => (lambda (proc)
	      (proc call indent-to port)))
	((not (= 1 (call-exits call)))
	 (bug "no printer for primop in ~S" call))
	(else
	 (let* ((cont (call-arg call 0))
		(cont-vars (lambda-variables cont)))
	   (cond ((every? unused? cont-vars)
		  (print-call call 1 port)
		  (pp-cps-body (lambda-body (call-arg call 0))))
		 ((null? (cdr cont-vars))
		  (display "(let ((" port)
		  (print-variable-name (car cont-vars))
		  (display " " port)
		  (print-call call 1 port)
		  (display "))" port)
		  (pp-cps-body call (+ indent-to 2) port))
		 (else
		  (display "(receive " port)
		  (write-lambda-vars cont port)
		  (newline port)
		  (indent (+ indent-to 4) port)
		  (print-call call 1 port)
		  (pp-cps-body call (+ indent-to 2) port)))))))
		  
(define (print-call call start-arg port)
  (display "(" port)
  (display (primop-id (call-primop call)) port)
  (print-args call start-arg port)
  (display ")" port))
	 
(define (print-args call start-arg port)
  (do ((i start-arg (+ i 1)))
      ((= i (call-arg-count call)))
    (display " " port)
    (print-arg (call-arg call i) port)))

(define (print-arg arg port)
  (cond ((lambda-node? node)
	 
	((call-node? node)
	 (format port "(~S" (primop-id (call-primop node)))
	 (print-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))))



  (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)
  (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)
           (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 ((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 ((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)))