; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-

;;;; Block compiler

; This is only intended to work when applied to the S48 virtual machine,
; which is a very special piece of code.

; Requires:
;  the ALPHA module, for alpha conversion and code generation.
;  the PACKAGE module, for some interface definitions
;  PFEATURES or equivalent, for definitions of the foldable procedures.

; Restrictions:
;  SET! on non-global variables not implemented.
;  Global variables can be SET! only if name begins and ends with *'s.
;  (OR X Y) returns #T, not X, when X is true.
;  Avoid variable names that end in ~ followed by a number.
;  @ is a keyword, don't use it as a variable name.
;  If (DEFINE FOO #F) then FOO won't get integrated.
;  N-ary procedures aren't supported.

(define entry-points
  '(initialize-heap
    perform-application
    interpret
    resume
    handle-exception))

(define do-not-integrate-these
  '(extract-string
    string-hash
    read-descriptor
    write-descriptor
    intern
    lookup
    string=?
    opcode-dispatch
    b-vector-ref
    b-vector-set!
    unspecified
    ))

(define @output-port (make-fluid (current-output-port)))

(define *definitions* (make-table))
(define *opcodes* '())
(define *file-list* '())

(define (progify)
  (flushit)
  (read-everything)
  (write-everything))

(define (read-everything)
  (set! *definitions* (make-table))
  (set! *opcodes* '())
  (let ((frob (lambda (z a)
		(let ((c (choose-file z)))
		  (if c
		      (let ((i-name (string-append (symbol->string c)
						   ".SCM")))
			(newline)
			(display "Reading file ")
			(display i-name)
			(for-each process-form (alpha-file i-name))
			(cons i-name a))
		      a)))))
    (do ((l *vm-files* (cdr l))		;See load.scm
	 (a (frob '(enum + s48) '())
	    (frob (car l) a)))
	((null? l)
	 (set! *file-list* (reverse a))
	 (set! *opcodes* (reverse *opcodes*))
	 'done))))

(define (write-everything)
  (let ((o-name "s48.fast"))
    (call-with-output-file o-name
       (lambda (o-port)
	 (let-fluid @output-port o-port
	   (lambda ()
	     (newline)
	     (display "Writing file ")
	     (display o-name)
	     (display "; -*- Mode: Scheme; Syntax: Scheme; Package: S48; -*-" o-port)
	     (newline o-port)
	     (newline o-port)
	     (display
	      "; This file was generated automatically from:"
	      o-port)
	     (newline o-port)
	     (display ";  " o-port)
	     (write *file-list* o-port)
	     (newline o-port)
	     (write-form `(lisp:proclaim '(lisp:optimize (lisp:speed 3)
							 (lisp:safety 0))))
	     (do-it)
	     'done))))))))

(define (process-form form)
  (cond ((car-is? form 'define)
	 (let ((var (cadr form))
	       (rhs (caddr form)))
	 (let ((probe (get-definition var)))
	   (if probe (note "Multiply defined" var))
	   (table-set! *definitions* var rhs))))
	((car-is? form 'define-opcode)
	 (set! *opcodes*
	       (cons (cdr form)
		     *opcodes*)))
	;; Macro definitions will already have been dealt with by process-top-level-form.
	;; Fix later.
	;; ((eq? (car form) 'define-macro) ...)
	(else
	 (set! *random-forms*
	       (cons form *random-forms*)))
	     (note "Random form" form))))
    (lambda (var form)
      )))

(define (get-definition var)
  (table-ref *definitions* var))

(define *marks* (make-table))
(define *processed-definitions* (make-table))

(define (flushit)
  (reset-new-variable-counter)
  (set! *marks* (make-table))
  (set! *processed-definitions* (make-table))
  'done)

(define (do-it)

  (newline)
  (display "Entry points... ")
  (write-remark "Definitions reachable from entry points:")
  (for-each (lambda (e)
	      (process-label e))
	    entry-points)

  (newline)
  (display "Opcodes... ")
  (write-remark "Definitions reachable from opcodes:")
  (let ((d (construct-dispatcher)))

    (newline)
    (display "Dispatch... ")
    (write-remark "The opcodes themselves:")
    (write-form d)

    ;; (list-unused)
    (write-remark "End")))

(define (list-unused)
  (lisp:maphash (lambda (var val)
		  val ;ignored
		  (cond ((not (table-ref *marks* var))
			 (newline)
			 (display "Unreferenced: ")
			 (write var))))
		*definitions*))

(define (construct-dispatcher)
  `(define (dispatch v opcode)
     v					;ignored
     (case (lisp:the lisp:fixnum opcode)
       ,@(lisp:sort (map (lambda (z)
			   (let ((n (get-definition (car z))))
			     (if (not n) (note "Undefined opcode" (car z)))
			     (table-set! *marks* (car z) #t)
			     (let ((form (schemify-top (meval-top `(,(cadr z))
								  (car z)))))
			       `((,n) ,@(unbeginify form)))))
			 *opcodes*)
		    (lambda (c1 c2)
		      (< (caar c1) (caar c2))))
       (else ,(meval-top `(goto uuo) 'dispatch)))))

(define (process-label var)
  (let ((def (process-define var)))
    (cond ((not (or (eq? def var)  ;circular or undefined
		    (eq? (table-ref *marks* var) 'written)))
	   (write-form `(define ,var ,(schemify-top def)))
	   (table-set! *marks* var 'written)))
    var))

(define (process-define var)
  (let ((mark (table-ref *marks* var)))
    (if mark
	(if (eq? mark 'cycle)
	    var
	    (table-ref *processed-definitions* var))
	(let ((rhs (get-definition var)))
	  (cond (rhs
		 ;; (write var) (display " ")
		 (table-set! *marks* var 'cycle)
		 ;; Preorder traversal.
		 (let ((rhs (meval-top rhs var)))
		   (write-char #\-)
		   (table-set! *processed-definitions* var rhs)
		   (table-set! *marks* var #t)
		   rhs))
		((memq var vm-subprimitives) var)
		((memq var '(unspecified memv)) var)
		(else
		 (note "Unbound" var)
		 (lisp:break "undefined");... remove this later
		 var))))))

; Meta-evaluator
;  This should be an idempotent transformation.

(define (meval-top form where)
  (let-fluid @where where
    (lambda ()
      (meval form))))

(define mevaluators (make-table))

(define (substitute-globally? form)
  (and (get-definition form)
       (not (or (mutable-variable? form)
		(memq form do-not-integrate-these)))))

(define (meval form)
  (cond ((global-variable? form)
	 (let ((probe (process-define form)))
	   (cond ((substitute-globally? form)
		  (alpha-top probe '<substituting-global>))
		 (else
		  (process-label form)))))
	((constant? form)
	 form)
	((symbol? (car form))
	 (let ((probe (table-ref mevaluators (car form))))
	   (if probe
	       (probe form)
	       (meval-combination form))))
	(else
	 (meval-combination form))))

(define (define-meval name proc)
  (table-set! mevaluators name proc))

(define-meval '@
  (lambda (form)
    (let ((sub (variable-substitution form)))
      (if sub
	  ; Rename all bound vars in substitution.
	  ; The subtituted value will already be in reduced form.
	  (alpha-top sub '<substituting-local>)
	  form))))

(define-meval 'system-ref
  (lambda (form)
    (case (cadr form)
      ((unspecified) 'unspecified)	;From COND
      ((memv) 'memv)			;From CASE
      (else (note "Weird system-ref" form) 0))))

(define-meval 'lambda
  (lambda (form)
    `(lambda ,(cadr form)
       ,(meval (caddr form)))))

(define-meval 'letrec
  (lambda (form)
    `(letrec ,(map (lambda (spec)
		     `(,(car spec) ,(meval (cadr spec))))
		   (cadr form))
	     ,(meval (caddr form)))))

(define-meval 'if
  (lambda (form)
    (let ((test (meval (cadr form)))
	  (con  (meval (caddr form)))
	  (alt  (meval (cadddr form))))
      (cond ((equal? test `#t) con)
	    ((equal? test `#f) alt)
	    ((and (effectless? con)
		  (equal? con alt))
	     (if (effectless? test)
		 con
		 `(begin ,test ,con)))
	    ((and (equal? con `#t)
		  (equal? alt `#f))
	     test)
	    ((and (equal? con `#f)
		  (equal? alt `#t))
	     `(not ,test))
	    (else `(if ,test ,con ,alt))))))

(define-meval 'begin
  (lambda (form)
    (do ((b (cdr form) (cdr b))
	 (z '() (let ((new (meval (car b))))
		  (if (or (not (effectless? new))
			  (null? (cdr b)))
		      (if (car-is? new 'begin)
			  (append (reverse (cdr new)) z)
			  (cons new z))
		      z))))
	((null? b)
	 (beginify (reverse z))))))

(define-meval 'set!
  (lambda (form)
    (if (not (mutable-variable? (cadr form)))
	(note "Weird assignment" form))
    `(set! ,(cadr form) ,(meval (caddr form)))))

; Procedures to be treated specially

(map (lambda (z)
       (define-meval z
	 (lambda (form)
	   (process-label (cadr form))
	   form)))
     '(goto run-machine label))

(define-meval 'assert		;Flush all consistency checking.
  (lambda (form) form 0))

(define-meval 'enforce
  (lambda (form)
    (meval (caddr form))))

; Combinations

(define (meval-combination form)
  (let ((proc (meval (car form)))
	(args (map meval (cdr form))))
    (cond ((lambda-form? proc)
	   (meval-lambda-combination proc args))
	  ((global-variable? proc)
	   (cond ((every constant? args)
		  (let ((probe (foldable-procedure-definition proc)))
		    (if probe
			(let ((val
			       (apply probe (map (lambda (arg)
						   (if (car-is? arg 'quote)
						       (cadr arg)
						       arg))
						 args))))
			  (if (or (number? val) (char? val)
				  (string? val) (boolean? val))
			      val
			      `',val))
			`(,proc ,@args))))
		 ((and (memq proc '(+& -& + -))
		       (equal? (cadr args) 0))
		  (car args))
		 ((and (memq proc '(*& quotient& * quotient))
		       (equal? (cadr args) 1))
		  (car args))
		 ((and (eq? proc 'high-bits)
		       (car-is? (car args) 'high-bits))
		  `(high-bits ,(cadr (car args))
			      ,(+ (caddr (car args)) (cadr args))))
		 ;; adjoin-bits is associative:
		 ;;  (adjoin-bits (adjoin-bits x a m) b n)
		 ;;    == (adjoin-bits x (adjoin-bits a b n) (+ m n))
		 ;; Do this transformation whenever a, b, m, n are constant.
		 ;; (adjoin-bits x y 0) == x
		 ;; (low-bits x 0) == 0
		 ;; (high-bits x 0) == x
		 ;; Yow -- make sure to do ((system-ref memv) x '(n)) ==> (=& x n)
		 (else
		  `(,proc ,@args))))
	  (else
	   `(,proc ,@args)))))

; Optimization of LET forms and inlined procedure calls

(define (meval-lambda-combination proc args)
  (let ((body (caddr proc)))
    (let loop ((vars (cadr proc))
	       (args args)
	       (new-vars '())
	       (new-args '())
	       (subst? #f))
      (cond ((null? vars)
	     (if (not (null? args))
		 (note "too many arguments" `(,proc ,@args)))
	     (let ((body (if subst? (meval body) body)))
	       (if (null? new-vars)
		   body
		   `((lambda ,(reverse new-vars) ,body)
		     ,@(reverse new-args)))))
	    ((null? args)
	     (let ((result `(,proc ,@args)))
	       (note "too few arguments" result)
	       result))
	    ((substitute? (car vars) (car args) body)
	     (set-variable-substitution! (car vars) (car args))
	     (loop (cdr vars)
		   (cdr args)
		   new-vars
		   new-args
		   #t))
	    (else
	     (loop (cdr vars)
		   (cdr args)
		   (cons (car vars) new-vars)
		   (cons (car args) new-args)
		   subst?))))))

(define (substitute? var arg form)
  (and (passable? arg form)
       (or (copyable? arg)
	   (not (occurs? var 2 form)))))

(define (copyable? form)
  (or (not (pair? form))
      (lambda-form? form)
      (and (variable? form) (not (mutable-variable? form)))))

(define (occurs? var n form)
  (letrec ((occurs
	    (lambda (n form)
	      (cond ((eq? form var) 1)
		    ((or (not (pair? form))
			 (eq? (car form) 'quote))
		     0)
		    (else
		     (let loop ((f form) (i 0) (n n))
		       (if (null? f)
			   i
			   (let ((i (+ i (occurs n (car form)))))
			     (if (>= i n)
				 i
				 (loop (cdr form) i (- n i)))))))))))
    (>= (occurs n form) n)))

; Side-effects analysis

(define (passable? form1 form2)
  (and (noninterfering? (effects form1) (affected form2))
       (noninterfering? (affected form1) (effects form2))))

(define (noninterfering? e1 e2)
  (or (null? e1)
      (null? e2)
      (and (not (eq? e1 'any))
	   (not (eq? e2 'any))
	   (not (intersectq? e1 e2)))))

(define (effectless? form)
  (null? (effects form)))

(define (affected form)
  (cond ((mutable-variable? form) (list form))
	((and (pair? form) (symbol? (car form)))
	 (case (car form)
	   ((set!) (affected (caddr form)))
	   ((fetch) (effs-union '(store!) (affected (cadr form))))
	   ((store!) (effs-accumulate affected (cdr form) '()))
	   (else
	    (effs-analyze affected form))))
	(else
	 (effs-analyze affected form))))

(define (effects form)
  (cond ((and (pair? form) (symbol? (car form)))
	 (case (car form)
	   ((set!) (effs-union (list (cadr form))
			       (effects (caddr form))))
	   ((store!)
	    (effs-accumulate effects (cdr form) '(store!)))
	   ((fetch) (effects (cadr form)))))
	(else
	 (effs-analyze effects form))))

(define (effs-analyze analyze form)
  (cond ((not (pair? form)) '())
	((symbol? (car form))
	 (case (car form)
	   ((@ quote lambda) '())
	   (else
	    (effs-accumulate analyze
	      (cdr form)
	      (if (foldable-procedure-definition (car form))
		  '()
		  'any)))))
	((lambda-form? (car form))
	 (effs-accumulate analyze (cdr form) (analyze (caddr (car form)))))
	(else 'any)))

(define (effs-accumulate analyze form-list effs)
  (let loop ((form-list form-list) (effs effs))
    (cond ((eq? effs 'any) 'any)
	  ((null? form-list) effs)
	  (else
	   (let ((e (analyze (car form-list))))
	     (loop (cdr form-list) (effs-union e effs)))))))

(define (effs-union e1 e2)
  (cond ((eq? e1 'any) 'any)
	((eq? e2 'any) 'any)
	(else (unionq e1 e2))))

; General-purpose stuff

(define (mutable-variable? var)
  (and (global-variable? var)
       (let* ((s (symbol->string var))
	      (n (string-length s)))
	 (and (>= n 3)
	      (char=? (string-ref s 0) #\*)
	      (char=? (string-ref s (- n 1)) #\*)))))

(define (any pred l)
  (and (not (null? l))
       (or (pred (car l)) (any pred (cdr l)))))

(define (every pred l)
  (or (null? l)
      (and (pred (car l)) (every pred (cdr l)))))

(define (write-form form)
  (let ((port (fluid @output-port)))
    (pp form port)
    (newline port)
    (write-char #\.)))

(define (write-remark remark)
  (let ((port (fluid @output-port)))
    (newline port)
    (display "; " port)
    (display remark port)
    (newline port)))

; For constant folding

(define (foldable-procedure-definition var)
  (case var
    ((not) not)
    ((+&) +&)
    ((-&) -&)
    ((*&) *&)
    ((<&) <&)
    ((<=&) <=&)
    ((=&) =&)
    ((>=&) >=&)
    ((>&) >&)
    ((quotient&) quotient&)
    ((remainder&) remainder&)
    ((adjoin-bits) adjoin-bits)
    ((low-bits) low-bits)
    ((high-bits) high-bits)
    ((expt) expt)
    ((ascii->char) ascii->char)
    ((char->ascii) char->ascii)
    ((char=?) char=?)
    ((char<?) char<?)
    ((+) +)
    ((-) -)
    ((*) *)
    ((<) <)
    ((<=) <=)
    ((=) =)
    ((>=) >=)
    ((>) >)
    ((quotient) quotient)
    ((remainder) remainder)
    ((%vector-ref) %vector-ref)
    ((%vector-length) %vector-length)
    (else #f)))


(define (ppd x)
  (pp (schemify-top (or (table-ref *processed-definitions* x)
			(table-ref *definitions* x)
			x))))