scheme48/ps-compiler/prescheme/top.scm

; Copyright (c) 1993-2008 by Richard Kelsey.  See file COPYING.

; Entry point

(define (prescheme-compiler package-id spec-files init-name c-file . commands)
  (reset-node-id)
  (initialize-lambdas)
  (reset-record-data!)
  (reset-type-vars!)
  (receive (copy no-copy shadow integrate header)
      (parse-prescheme-commands commands)
    (let ((forms (prescheme-front-end (if (list? package-id)
					  package-id
					  (list package-id))
				      spec-files copy no-copy shadow)))
      (for-each simplify-form forms)
      (let ((forms (remove-unreferenced-forms forms)))
	(for-each integrate-stob-form forms) 
	; prevent further automatic integration
	(for-each (lambda (form)
		    (remove-variable-known-value! (form-var form)))
		  forms)
	(integrate-by-command integrate forms)
	(for-each resimplify-form forms)
	(let* ((forms (remove-unreferenced-forms forms))
	       (forms (integrate-single-uses forms))
	       (forms (remove-unreferenced-forms forms)))
	  (for-each resimplify-form forms)
	  (for-each determine-form-protocol forms)
	  (let ((forms (form-tail-calls->jumps forms)))
	    (for-each maybe-add-self-label forms)
	    (let ((forms (hoist-nested-procedures forms)))
	      (for-each remove-polymorphism forms)
	      ; (if cps-file (write-cps-file cps-file forms))
	      (if c-file (write-c-file init-name c-file header forms)))))))))

;(define (expand-and-eval-program package-id spec-files output-file . commands)
;  (reset-node-id)
;  (reset-record-data!)
;  (receive (copy no-copy shadow integrate header)
;      (parse-prescheme-commands commands)
;    (let ((forms (prescheme-front-end package-id spec-files copy no-copy shadow)))
;      (call-with-output-file output-file
;        (lambda (out)
;          (display-forms-as-scheme forms out))))))

;(define (simplify-and-print-program package-id spec-files output-file c-file . commands)
;  (reset-node-id)
;  (reset-record-data!)
;  (receive (copy no-copy shadow integrate header)
;      (parse-prescheme-commands commands)
;    (let ((forms (prescheme-front-end package-id spec-files copy no-copy shadow)))
;      (for-each simplify-form forms)
;      (let ((forms (remove-unreferenced-forms forms)))
;        (call-with-output-file output-file
;          (lambda (out)
;            (display-cps-forms-as-scheme forms out)))))))

(define command-names '(copy no-copy shadow integrate header))

(define (parse-prescheme-commands commands)
  (let ((res (map list command-names)))
    (for-each (lambda (command)
		(cond ((assq (car command) res)
		       => (lambda (l)
			    (set-cdr! l (append (reverse (cdr command))
						(cdr l)))))
		      (else
		       (error "unknown directive ~S" command))))
	      commands)
    (apply values (map (lambda (l) (reverse (cdr l))) res))))

;--------------------------------------------------

(define (simplify-form form)
  (format #t " ~A " (form-name form))
  (let ((status (expand-and-simplify-form form)))
    (if status
	(format #t "(~A): " status)
	(format #t ": "))
    (display-type (variable-type (form-var form))
		  (current-output-port))
    (newline (current-output-port))))

;--------------------------------------------------

(define (integrate-single-uses forms)
  (format #t "In-lining single-use procedures~%")
  (let loop ((forms forms) (done '()) (hit? #f))
    (cond ((null? forms)
	   (if hit?
	       (loop (reverse done) '() #f)
	       (reverse done)))
	  ((single-called-use? (car forms))
	   (let ((form (car forms)))
;	     (format #t " ~S~%" (variable-name (form-var form)))
	     (integrate-single-use form
				   (car (variable-refs (form-var form)))
				   #f)
	     (set-form-value! form #f)
	     (make-form-unused! form)
	     (loop (cdr forms) done #t)))
	  (else
	   (loop (cdr forms) (cons (car forms) done) hit?)))))

(define (single-called-use? form)
  (let ((var (form-var form)))
    (and (not (form-exported? form))
	 (eq? (form-type form) 'lambda)
	 (not (null? (variable-refs var)))
	 (null? (cdr (variable-refs var)))
	 (called-node? (car (variable-refs var))))))

(define (integrate-single-use form ref copy?)
  (let* ((in-node (node-base ref))
	 (in-form (node-form in-node))
	 (type (variable-type (form-var form))))
    (use-this-form! in-form)
    (let ((node (cond (copy?
		       (copy-node-tree (form-node form)))
		      (else
		       (also-use-this-form! form)
		       (form-node form)))))
      (if (type-scheme? type)
	  (if (not (called-node? ref))
	      (error "integrating polymorphic value into non-call position")
	      (instantiate-type&value type node ref)))
      (determine-lambda-protocol node (list ref))
      (replace ref node)
      (simplify-all in-node (form-name form))
      (suspend-form-use! in-form))))

; Commands are (<proc> <caller>)

(define (integrate-by-command commands forms)
  (for-each (lambda (command)
	      (receive (proc refs)
		  (process-integrate-command command forms)
		(if proc
		    (for-each (lambda (r)
				(integrate-single-use proc r #t))
			      refs))))
	    commands))

; Horrendous error checking and notification.

(define (process-integrate-command command forms)
  (let* ((proc (any (lambda (f)
		      (eq? (form-name f) (car command)))
		    forms))
	 (var (if proc (form-var proc) #f))
	 (node (if proc (form-value proc) #f))
	 (caller (any (lambda (f)
			(eq? (form-name f) (cadr command)))
		      forms))
	 (refs (if (and var caller)
		   (filter (lambda (ref)
			     (eq? caller (node-form ref)))
			   (variable-refs var))
		   #f)))
    (cond ((or (not proc) (not var) (not caller))
	   (cond ((or (not proc) (not var))
		  (format #t "Bad command: no value for ~S~%"
			  (car command)))
		 ((or (not node)
		      (not (lambda-node? node)))
		  (format #t "Bad command: ~S is not a procedure~%"
			  (car command))))
	   (if (not caller)
	       (format #t "Bad command: no definition for ~S~%"
		       (cadr command)))
	   (values #f #f))
	  ((or (null? refs) (not node) (not (lambda-node? node)))
	   (if (null? refs)
	       (format #t "Bad command: ~S is not referenced by ~S~%"
		       (car command) (cadr command)))
	   (if (or (not node)
		   (not (lambda-node? node)))
	       (format #t "Bad command: ~S is not a procedure~%"
		       (car command)))
	   (values #f #f))
	  (else
	   (values proc refs)))))

;--------------------------------------------------

(define (determine-form-protocol form)
  (let ((var (form-var form)))
    (cond ((and (not (form-exported? form))
		(eq? 'lambda (form-type form))
		(every? called-node? (variable-refs var)))
	   (determine-lambda-protocol (form-node form) (variable-refs var))
	   (note-known-global-lambda! var (form-node form))))))

;--------------------------------------------------

(define (form-tail-calls->jumps forms)
  (receive (hits useless)
      (find-jump-procs (filter-map (lambda (form)
				     (if (eq? 'lambda (form-type form))
					 (form-node form)
					 #f))
				   forms)
		       find-form-proc-calls)
    (for-each (lambda (p)
		(let* ((procs (cdr p))
		       (proc-forms (map node-form procs))
		       (owner (node-flag (node-base (car p))))
		       (vars (map form-var proc-forms)))
		  (use-this-form! owner)
		  (for-each also-use-this-form! proc-forms)
		  (procs->jumps (cdr p) vars (car p))
		  (simplify-node (form-value owner)) ; worth it?
		  (suspend-form-use! owner)
		  (for-each (lambda (f)
			      (set-form-value! f #f)
			      (make-form-unused! f))
			    proc-forms)))
	      hits)
    (for-each (lambda (p)
		(make-form-unused! (node-form p)))
	      useless)
    (filter (lambda (f)
	      (not (eq? (form-type f) 'unused)))
	    forms)))

(define (find-form-proc-calls l)
  (let ((refs (variable-refs (form-var (node-form l)))))
    (cond ((and refs (every? called-node? refs))
	   refs)
	  ((calls-known? l)
	   (bug "cannot find calls for known lambda ~S" l))
	  (else #f))))

;--------------------------------------------------
; Determine an actual type for a polymorphic procedure.

(define (remove-polymorphism form)
  (if (and (null? (variable-refs (form-var form)))
	   (eq? 'lambda (form-type form)))
      (for-each (lambda (var)
		  (if (and (null? (variable-refs var))
			   (uvar? (maybe-follow-uvar (variable-type var))))
		      (unused-variable-warning var form)))
		(cdr (lambda-variables (form-node form)))))
  (if (type-scheme? (variable-type (form-var form)))
      (make-monomorphic! (form-var form))))

(define (unused-variable-warning var form)		
  (format #t "Warning: argument `~S' of `~S' is not used, and `~S' is not called;~%"
	  (variable-name var) (form-name form) (form-name form))
  (format #t "  assuming the type of argument `~S' of procedure `~S' is `long'.~%"
	  (variable-name var) (form-name form))
  (set-variable-type! var type/integer))

;--------------------------------------------------

; Various methods for getting values from thunks.  These are no longer used
; here.

(define (thunk-value thunk)
  (let ((refs (variable-refs (car (lambda-variables thunk)))))
    (if (= 1 (length refs))
        (call-arg (node-parent (car refs)) 2)
        #f)))

(define (simple-thunk? thunk value)
  (eq? (node-parent (node-parent value)) thunk))

;----------------------------------------------------------------
; Turning internal tail-recursive calls to jumps.

; f = (proc (c . vars)
;       ... ([unknown-]tail-call c f . args) ...)
;  =>
; f = (proc (c . vars)
;       (letrec ((f' (jump . vars) ... (jump f' . args) ...))
;         (jump f' . vars)))

(define (maybe-add-self-label form)
  (if (eq? 'lambda (form-type form))
      (let* ((node (form-node form))
	     (self-calls (filter (lambda (ref)
				   (and (eq? (node-index ref) 1)
					(calls-this-primop? (node-parent ref)
							    (if (calls-known? node)
								'tail-call
								'unknown-tail-call))
					(eq? node (node-base ref))))
				 (variable-refs (form-var form)))))
	(if (not (null? self-calls))
	    (begin
	      (use-this-form! form)
	      (replace-self-calls-with-jumps node self-calls)
	      (suspend-form-use! form))))))

(define (replace-self-calls-with-jumps proc refs)
  (let* ((outside-var (reference-variable (car refs)))
	 (var (make-variable (variable-name outside-var)
			     (variable-type outside-var)))
	 (old-vars (cdr (lambda-variables proc)))
	 (new-vars (map copy-variable old-vars))
	 (args (map make-reference-node new-vars))
	 (body (lambda-body proc))
	 (jump-proc (make-lambda-node (lambda-name proc) 'jump old-vars)))
    (for-each (lambda (var)
		(set-variable-binder! var proc))
	      new-vars)
    (set-cdr! (lambda-variables proc) new-vars)
    (for-each (lambda (ref)
		(let ((call (node-parent ref)))
		  (if (not (calls-known? proc))
		      (remove-call-arg call 2))  ; remove TAIL? argument
		  (remove-call-arg call 0)       ; remove continuation argument
		  (replace (call-arg call 0) (make-reference-node var))
		  (set-call-primop! call (get-primop (enum primop jump)))))
	      refs)
    (let-nodes ((call (jump 0 (* var) . args)))
      (move-body body (lambda (body)
			(attach-body jump-proc body)
			call))
      (put-in-letrec (list var) (list jump-proc) call))))