(in-package "XLSCMP")

#|
clean up, reduce use of global/special variables
clean up, separate out initialisation code generation
implement large case with hashtable?

need to test %catch-tagbody with changes

think about implementation of mvcall -- alternative to %mv-collect

simplifyer rules: drop unused variables from continuations?
be carefull about unused vs real multiple values (for dropping no side eff.)
constant folded version of nth-value?
push code generaotr test into simplifier?

need to recheck calling, test calling speed
|#

#|
Value registers of zero are used to communicate that values should
(only) be stored in the multiple value array. This should work OK since
the zero register is reserved for the real final value continuation.

Continuations are represented in two parts. Part lives in the
continuation stack, part on the value stack. The value stack part may
be shared -- this is true for the local calls generated by things like
unwind-protect. These local functions cannot overlay their call frame
on a tail call, since that would clobber the part on the value stack.
The byte code interpreter checks for this possibility by checking
whether the current call stack part of the framt is identical to the
one for the next continuation on the stack.
|#

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;
;;;;;                            Code Generator
;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defvar *code*)
(defvar *literals*)
(defvar *functions*)
(defvar *labels*)
(defvar *registers*)
(defvar *constants*)
(defvar *protected-continuations*)

(defun generate-code (pieces)
  (let ((*code* nil)
	(*literals* nil)
	(*functions* nil)
	(*labels* nil))
    (initialize-functions pieces)
    (dolist (p pieces)
      (let ((label (make-label (first p)))
	    (code (second p)))
	(push-label (first p))
	(generate-lambda-code label code)))
    (peephole-optimize (list (reverse *code*)
			     (reverse *literals*)
			     (get-function-label (first (first pieces)))
			     nil
			     (nreverse (mapcar #'second *functions*)))
		       (get-function-labels))))

(defun generate-lambda-code (label n)
  (let ((*registers* nil)
	(*constants* nil)
	(*protected-continuations* nil))
    (assign-registers n)
    ;;**** clean this up!!
    (let* ((consts (nreverse *constants*))
	   (ainfo (lambda-node-lambda-list n))
	   (nc (length consts))
	   (nv (lambda-list-num-variables ainfo))
	   (nr (count-registers))
	   (nreq (first ainfo))
	   (nopt (second ainfo))
	   (odef (coerce (third ainfo) 'vector))
	   (allow-keys (fourth ainfo))
	   (rest (sixth ainfo)))
      (cond
       ((and (= nopt 0) (not allow-keys) (not rest))
	(push-instruction `(%initialize-0 ,nreq ,nc ,@consts ,(- nr nv nc))))
       ((and (not allow-keys) (not rest))
	(let ((ol (add-literal (make-constant-node `(quote ,odef)))))
	  (push-instruction
	   `(%initialize 1 ,nreq ,nopt ,ol ,nc ,@consts ,(- nr nv nc)))))
       ((not allow-keys)
	(if (< 0 nopt)
	    (let ((ol (add-literal (make-constant-node `(quote ,odef)))))
	      (push-instruction
	       `(%initialize 2 ,nreq ,nopt ,ol ,nc ,@consts ,(- nr nv nc))))
	  (push-instruction
	   `(%initialize 2 ,nreq ,nopt ,nc ,@consts ,(- nr nv nc)))))
       (t
	(let* ((kdefs (fifth ainfo))
	       (allow-other-keys (seventh ainfo))
	       (ksyms (eighth ainfo))
	       (kdl (add-literal (make-constant-node `(quote ,kdefs))))
	       (ksl (add-literal (make-constant-node `(quote ,ksyms))))
	       (aok (if allow-other-keys 1 0))
	       (r (if rest 1 0)))		  
	  (if (< 0 nopt)
	      (let ((ol (add-literal (make-constant-node `(quote ,odef)))))
		(push-instruction
		 `(%initialize 3 ,nreq ,nopt ,ol ,r ,aok ,ksl ,kdl
			       ,nc ,@consts ,(- nr nv nc))))
	      (push-instruction
	       `(%initialize 3 ,nreq ,nopt ,r ,aok ,ksl ,kdl
			     ,nc ,@consts ,(- nr nv nc))))))))
    (set-function-data-registers (get-function-data label) (register-map))
    (generate-body-code (lambda-node-body n))))

(defun generate-body-code (form)
  (do ((trees (list form)))
      ((null trees))
      (let ((p (first trees)))
	(setf trees
	      (cond
	       ((leaf-node-p p) (push-label p) (rest trees))
	       ((leaf-node-p (call-node-function p))
		(generate-symbol-call-code p (rest trees)))
	       (t (generate-lambda-call-code p (rest trees))))))))

(defun lifted-lfun-node-p (n) (and (leaf-node-p n) (get-function-label n)))

(defun generate-symbol-call-code (n rest)
  (let ((f (call-node-function n)))
    (cond
     ((gfun-node-p f) (generate-gfun-call-code n rest))
     ((lifted-lfun-node-p f) (generate-lfun-call-code n rest))
     (t (generate-continuation-call-code n rest)))))

(defun generate-lambda-call-code (n rest)
  (let* ((f (call-node-function n))
	 (alist (lambda-node-arglist f))
	 (body (lambda-node-body f))
	 (args (call-node-args n)))
    (mapc #'(lambda (x y)
	      (unless (leaf-node-p y) 
		      (push (lambda-node-body y) rest)
		      (push x rest)))
          alist
	  args)
    (push body rest)
    rest))


(defun generate-gfun-call-code (n rest)
  (let* ((f (call-node-function n))
	 (cg (get-code-generator (gfun-symbol f) n)))
    (if cg
	(funcall cg n rest)
        (let* ((c (get-continuation (call-node-arg n 0)))
	       (aregs (mapcar #'find-register (rest (call-node-args n))))
	       (na (length aregs))
	       (s (add-literal f)))
	  (if (final-value-continuation-p c)
	      (let ((cr (continuation-register c)))
		(push-instruction `(%call ,s ,cr ,na ,@aregs)))
	      (let ((vr (continuation-value-register c)))
		(push-instruction `(%save-call ,s ,vr ,na ,@aregs))))
	  (cleanup-continuation c rest nil)))))

(defun generate-lfun-call-code (n rest)
  (let* ((f (call-node-function n))
	 (c (get-continuation (call-node-arg n 0)))
	 (aregs (mapcar #'find-register (rest (call-node-args n))))
	 (na (length aregs))
	 (s (get-function-label f)))
    (if (final-value-continuation-p c)
	(let ((cr (continuation-register c)))
	  (push-instruction `(%lcall ,s ,cr ,na ,@aregs)))
        (let ((vr (continuation-value-register c)))
	  (push-instruction `(%save-lcall ,s ,vr ,na ,@aregs))))
    (cleanup-continuation c rest nil)))

;;**** needs to be thought through relative to %y
(defun generate-continuation-call-code (n rest)
  (let ((c (get-continuation (call-node-function n))))
    (case (continuation-type c)
     (final-value
      (let ((cr (continuation-register c))
	    (vr (find-register (call-node-arg n 0))))
	(push-instruction `(%set-one-value ,vr))
	(push-instruction `(%return ,cr))))
     ((protected multiple-value)
      (let ((aregs (mapcar #'find-register (call-node-args n))))
	(cond
	 ((= (length aregs) 1)
	  (push-instruction `(%set-one-value ,@aregs)))
	 (t (warn "multiple value continuation in callposition ~
                   with more than one argument")
	    (push-instruction `(%set-values ,(length aregs) ,@aregs))))))
     (t
      (let* ((fsym (continuation-name c))
	     (f (continuation-function c))
	     (b (lambda-node-body f))
	     (vars (lambda-node-arglist f))
	     (vals (call-node-args n)))
	(mapc #'(lambda (x y)
		  (when (any-references-p y b)
			(let ((xr (find-register x))
			      (yr (find-register y)))
			  (push-instruction `(%copy ,xr ,yr)))))
	      vals
	      vars)
	(push-instruction `(%goto ,(make-label fsym))))))
    (cleanup-continuation c rest nil)))


;;;;
;;;; Function Information Representation
;;;;

(defun initialize-functions (pieces)
  (dolist (p pieces)
    (let* ((label (make-label (first p)))
	   (d (make-function-data label (leaf-node-value (first p)))))
      (push (list label d) *functions*))))

(defun make-function-data (label name) (list label name nil))

(defun get-function-data (label) (second (assoc label *functions*)))
(defun get-function-label (f) (first (assoc (make-label f) *functions*)))
(defun get-function-labels () (mapcar #'first *functions*))

(defun set-function-data-registers (fd r) (setf (third fd) r))


;;;;
;;;; Continuation Handling
;;;;

(defun get-continuation (n)
  (if (lambda-node-p n)
      (cons nil n)
      (let ((cf (find-lambda-binding n)))
	(cons n (if cf
		    cf
		    (if (member n *protected-continuations*)
			'protected
		        'final))))))

(defun register-protected-continuation (k)
  (pushnew k *protected-continuations*))

(defun immediate-continuation-p (c)
  (and (lambda-node-p (cdr c)) (null (continuation-name c))))

(defun continuation-value-ignored-p (c)
  (and (not (multiple-value-continuation-p c))
       (or (null (lambda-node-arglist (cdr c)))
	   (not (any-references-p (first (lambda-node-arglist (cdr c)))
				  (cdr c))))))

(defun final-value-continuation-p (c) (eq (cdr c) 'final))

(defun protected-continuation-p (c) (eq (cdr c) 'protected))

(defun continuation-register (c) (if (car c) (find-register (car c))))

(defun multiple-value-continuation-p (c)
  (multiple-value-continuation-node-p (cdr c)))

(defun continuation-value-register (c)
  (if (and (lambda-node-p (cdr c))
	   (not (continuation-value-ignored-p c))
	   (not (multiple-value-continuation-p c)))
      (find-register (first (lambda-node-arglist (cdr c))))
      0))

(defun continuation-name (c) (car c))
(defun continuation-function (c) (if (lambda-node-p (cdr c)) (cdr c)))

(defun continuation-type (c)
  (cond
   ((final-value-continuation-p c) 'final-value)
   ((protected-continuation-p c) 'protected)
   ((multiple-value-continuation-p c) 'multiple-value)
   ((continuation-value-ignored-p c) 'value-ignored)
   (t 'one-value)))

(defun cleanup-continuation (c rest inline)
  (if (final-value-continuation-p c)
      (if inline
	  (let ((cr (continuation-register c)))
	    (push-instruction `(%return ,cr))))
      (if (immediate-continuation-p c)
	  (push (lambda-node-body (cdr c)) rest)
	  (push-instruction `(%goto ,(make-label (continuation-name c))))))
  rest)


;;;;
;;;; Register Handling
;;;;

(defun find-register (v)
  (let ((e (assoc v *registers*)))
    (if e (cdr e) (error "register not found"))))

(defun assign-registers (n)
  (assign-registers-1 (lambda-node-body n)
		      (add-lambda-frame (lambda-node-arglist n) nil)))

(defun pop-unused-frames (env n) 
  (let ((frame (first env)))
    (if (and frame
	     (eq (cdr frame) 'continuation)
	     (every #'(lambda (x) (not (any-references-p x n))) (car frame)))
	(pop-unused-frames (cdr env) n)
        env)))		    

(defun setq-continuation-p (n)
  (if (continuation-node-p n)
      (let* ((b (lambda-node-body n))
	     (f (call-node-function b)))
	(if (and (gfun-eq f '%setq) (= (length (lambda-node-arglist n)) 1))
	    (let ((v (first (lambda-node-arglist n)))
		  (c (call-node-arg b 0)))
	      (and (eq v (call-node-arg b 2))
		   (assoc (call-node-arg b 1) *registers*)
		   (not (any-references-p v c))))))))

(defun add-register-frame (vars type env)
  (let ((maxreg 0))
    (dolist (e env) (incf maxreg (length (car e))))
    (dolist (v vars)
      (push (cons v maxreg) *registers*)
      (incf maxreg))
    (cons (cons vars type) env)))

(defun add-lambda-frame (vars env) (add-register-frame vars 'lambda env))

(defun add-continuation-frame (n env)
  (if (setq-continuation-p n)
      (let ((v (first (lambda-node-arglist n)))
	    (vv (call-node-arg (lambda-node-body n) 1)))
	(push (cons v (cdr (assoc vv *registers*))) *registers*)
	(pop-unused-frames env n))
      (let ((alist (lambda-node-arglist n))
	    (b (lambda-node-body n)))
	(if (and (not (multiple-value-continuation-node-p n))
		 (some #'(lambda (x) (any-references-p x b)) alist))
	    (add-register-frame alist
				'continuation
				(pop-unused-frames env n))
	    (pop-unused-frames env n)))))

(defun assign-registers-1 (n env)
  (let ((f (call-node-function n))
	(args (call-node-args n)))
    (setf env (pop-unused-frames env n)) ;;**** is this OK?
    (when (lambda-node-p f)
	  (let ((nfvars nil))
	    (mapc #'(lambda (x y)
		      (unless (lambda-node-p y)
			      (push x nfvars)
			      (push (add-literal y) *constants*)))
		  (lambda-node-arglist f)
		  args)
	    ;;**** think about this -- should only have non-nil nfvars once
	    (assign-registers-1 (lambda-node-body f)
				    (add-lambda-frame (nreverse nfvars) env))))
    (if (gfun-eq f '%y)
	(assign-registers-1 (lambda-node-body (call-node-arg n 0)) env)
        (let ((is-y-list (gfun-eq f '%y-list)))
	  (dolist (a args)
	    (when (lambda-node-p a)
	      (let ((new-env (if (and (continuation-node-p a) (not is-y-list))
				 (add-continuation-frame a env)
			         (add-lambda-frame (lambda-node-arglist a)
						   env))))
		(assign-registers-1 (lambda-node-body a) new-env))))))))

(defun count-registers ()
  (let ((n 0))
    (dolist (r *registers* n)
      (setf n (max n (+ (cdr r) 1))))))

(defun register-map ()
  (flet ((rsym (x) (if (symbolp x) x (leaf-node-value x))))
    (let ((regs nil))
      (dolist (r *registers*)
        (let* ((v (rsym (car r)))
	       (i (cdr r))
	       (e (assoc i regs)))
	  (if e (pushnew v (rest e)) (push (list i v) regs))))
      (sort regs #'(lambda (x y) (< (first x) (first y)))))))


;;;;
;;;; Instruction Representation
;;;;

(defun make-label (v)
  (let ((e (assoc v *labels*)))
    (if e
	(cdr e)
        (let ((s (gensym (string (leaf-node-value v)))))
	  (push (cons v s) *labels*)
	  s))))

(defun make-label-node (&optional (label "LABEL"))
  (make-leaf-node (gensym (string label))))

(defun push-label (v) (push (make-label v) *code*))
(defun push-instruction (i) (push i *code*))


;;;;
;;;; Literals Representation
;;;;

(defun next-literal-index () (length *literals*))

(defun literal-value (v)
  (let ((c (leaf-node-value v)))
    (if (and (consp c) (eq (first c) 'quote)) (second c) c)))

(defun push-literal (v)
  (let ((n (next-literal-index)))
    (push (literal-value v) *literals*)
    n))

(defun add-literal (c) (add-literal-value (literal-value c)))

(defun add-literal-value (v)
  (let ((p (position v *literals*)))
    (if p
	(- (length *literals*) p 1)
        (prog1 (length *literals*) (push v *literals*)))))


;;;;
;;;; Code Generator Support for Special Instuctions
;;;;

(defun get-code-generator (s n)
  (let* ((e (get s 'cmp-code-generator))
	 (test (first e))
	 (f (second e)))
    (if test (if (funcall test n) f) f)))

(defun set-code-generator (s g)
  (let ((e (get s 'cmp-code-generator)))
    (if e
	(setf (second e) g)
        (setf (get s 'cmp-code-generator) (list nil g)))))

(defun set-code-generator-test (s g)
  (let ((e (get s 'cmp-code-generator)))
    (if e
	(setf (first e) g)
        (setf (get s 'cmp-code-generator) (list g nil)))))

(defmacro define-code-generator (sym &rest body)
  `(set-code-generator ',sym #'(lambda ,@body)))

(defmacro define-code-generator-test (sym &rest body)
  `(set-code-generator-test ',sym #'(lambda ,@body)))

(defun generate-inline-function-code (f n rest)
  (let* ((c (get-continuation (call-node-arg n 0)))
	 (vr (continuation-value-register c))
	 (args (rest (call-node-args n))))
    (funcall f args vr)
    (cleanup-continuation c rest t)))

(defmacro define-inline-function-generator (sym &rest body)
  `(define-code-generator ,sym (n rest)
     (generate-inline-function-code #'(lambda ,@body) n rest)))

(defmacro define-standard-inline-generator (sym &optional
						(name sym)
						(llist nil llist-supplied))
  `(progn
     ,@(if llist-supplied `((define-lambda-list ,sym ,llist)))
     (define-inline-function-generator ,sym (args r)
     (push-instruction
      (cons ',name (append (mapcar #'find-register args) (list r)))))))

(defmacro define-standard-inline-generator-2 (sym &rest args)
  `(progn
     (define-standard-inline-generator ,sym ,@args)
     (define-code-generator-test ,sym (n) (= (call-node-arg-count n) 3))))

(defmacro define-test-code-generator-1 (name opcode)
  `(define-code-generator ,name (n rest)
     (let* ((cons (call-node-arg n 0))
	    (alt (call-node-arg n 1))
	    (vr (find-register (call-node-arg n 2)))
	    (clab (if (lambda-node-p cons) (make-label-node "THEN") cons))
	    (alab (if (lambda-node-p alt) (make-label-node "ELSE") alt)))
       (push-instruction
	(list '%test-1 ,opcode (make-label clab) (make-label alab) vr))
       (when (lambda-node-p alt)
	     (push (lambda-node-body alt) rest)
	     (push alab rest))
       (when (lambda-node-p cons)
	     (push (lambda-node-body cons) rest)
	     (push clab rest))
       rest)))

(defmacro define-test-code-generator-2 (name opcode)
  `(define-code-generator ,name (n rest)
     (let* ((cons (call-node-arg n 0))
	    (alt (call-node-arg n 1))
	    (vr1 (find-register (call-node-arg n 2)))
	    (vr2 (find-register (call-node-arg n 3)))
	    (clab (if (lambda-node-p cons) (make-label-node "THEN") cons))
	    (alab (if (lambda-node-p alt) (make-label-node "ELSE") alt)))
       (push-instruction
	(list '%test-2 ,opcode (make-label clab) (make-label alab) vr1 vr2))
       (when (lambda-node-p alt)
	     (push (lambda-node-body alt) rest)
	     (push alab rest))
       (when (lambda-node-p cons)
	     (push (lambda-node-body cons) rest)
	     (push clab rest))
       rest)))


(defmacro define-test-arith-code-generator-2 (name opcode)
  `(define-code-generator ,name (n rest)
     (let* ((cons (call-node-arg n 0))
	    (alt (call-node-arg n 1))
	    (vr1 (find-register (call-node-arg n 2)))
	    (vr2 (find-register (call-node-arg n 3)))
	    (clab (if (lambda-node-p cons) (make-label-node "THEN") cons))
	    (alab (if (lambda-node-p alt) (make-label-node "ELSE") alt)))
       (push-instruction
	(list '%test-arith-2
	      ,(char-int opcode)
	      (make-label clab)
	      (make-label alab)
	      vr1
	      vr2))
       (when (lambda-node-p alt)
	     (push (lambda-node-body alt) rest)
	     (push alab rest))
       (when (lambda-node-p cons)
	     (push (lambda-node-body cons) rest)
	     (push clab rest))
       rest)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;
;;;;;                       Specific Code Generators
;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;
;;;; Test/Case Code Generators
;;;;

(define-test-code-generator-1 %test 0)
(define-test-code-generator-1 %test-consp 1)
(define-test-code-generator-1 %test-supplied-p 2)
(define-test-code-generator-1 %test-endp 3)

(define-test-code-generator-2 %test-eq    0)
(define-test-code-generator-2 %test-eql   1)
(define-test-code-generator-2 %test-equal 2)

(define-test-arith-code-generator-2 %test=  #\=)
(define-test-arith-code-generator-2 %test/= #\#)
(define-test-arith-code-generator-2 %test<  #\<)
(define-test-arith-code-generator-2 %test>  #\>)
(define-test-arith-code-generator-2 %test<= #\L)
(define-test-arith-code-generator-2 %test>= #\G)

(define-code-generator %case (n rest)
  (let* ((var (find-register (call-node-arg n 0)))
	 (choices (find-register (call-node-arg n 1)))
	 (actions (rest (rest (call-node-args n))))
	 (labels nil))
    (dolist (a actions)
      (cond
       ((lambda-node-p a)
	(let ((lab (make-label-node "CASE")))
	  (push (lambda-node-body a) rest)
	  (push lab rest)
	  (push (make-label lab) labels)))
       (t (push (make-label a) labels))))
    (push-instruction `(%case ,var ,choices ,@(reverse labels)))
    rest))


;;;;
;;;; Multiple Value Code Generators
;;;;

(define-code-generator %mvc (n rest)
  (let ((c (get-continuation (call-node-arg n 0)))
	(f (call-node-arg n 1)))
    (if (final-value-continuation-p c)
	(let ((cr (continuation-register c)))
	  (cond
	   ((gfun-node-p f)
	    (push-instruction `(%mvcall ,(add-literal f) ,cr)))
	   ((lifted-lfun-node-p f)
	    (push-instruction `(%mvlcall ,(get-function-label f) ,cr)))
	   (t
	    (push-instruction `(%mvvcall ,(find-register f) ,cr)))))
        (let ((vr (continuation-value-register c)))
	  (cond
	   ((gfun-node-p f)
	    (push-instruction `(%save-mvcall ,(add-literal f) ,vr)))
	   ((lifted-lfun-node-p f)
	    (push-instruction `(%save-mvlcall ,(get-function-label f) ,vr)))
	   (t
	    (push-instruction `(%save-mvvcall ,(find-register f) ,vr))))))
    (cleanup-continuation c rest nil)))

;;**** is the continuation necessarily both immediate and not multiple value?
(define-code-generator %mvcc (n rest)
  (let* ((k (call-node-arg n 0))
	 (alist (lambda-node-arglist k))
	 (b (lambda-node-body k)))    
    (if (some #'(lambda (x) (any-references-p x b)) alist)
	(let ((vregs (mapcar #'find-register alist)))
	  (push-instruction `(%get-values ,(length vregs) ,@vregs))))
    (cons b rest)))

(define-code-generator values (n rest)
  (let* ((c (get-continuation (call-node-arg n 0)))
	 (aregs (mapcar #'find-register (rest (call-node-args n))))
	 (r (continuation-value-register c)))
    ;;**** check number of values against limit
    (push-instruction `(%set-values ,(length aregs) ,@aregs))
    (unless (= r 0)
	    (warn "VALUES occurred in non-multiple value continuations")
	    (push-instruction `(%get-one-value ,r)))
    (cleanup-continuation c rest t)))

(define-code-generator values-list (n rest)
  (let* ((c (get-continuation (call-node-arg n 0)))
	 (ar (find-register (call-node-arg n 1)))
	 (r (continuation-value-register c)))
    (push-instruction `(%set-values-list ,ar))
    (unless (= r 0)
	    (warn "VALUES-LIST occurred in non-multiple value continuations")
	    (push-instruction `(%get-one-value ,r)))
    (cleanup-continuation c rest t)))


;;;;
;;;; Catch/Throw/Unwind-Protect Code Generators
;;;;

(defun cleanup-protected-continuation (label c rest)
  (push label rest)
  (let ((r (continuation-value-register c)))
    (unless (= r 0) (push-instruction `(%get-one-value ,r))))
  (cleanup-continuation c rest t))

(define-code-generator %catch (n rest)
  (let* ((c (get-continuation (call-node-arg n 0)))
	 (tr (find-register (call-node-arg n 1)))
	 (form-fun (call-node-arg n 2))
	 (fb (lambda-node-body form-fun))
	 (fv (first (lambda-node-arglist form-fun)))
	 (fr (find-register fv))
	 (label (make-label-node "C")))
    (push-instruction `(%catch ,tr ,(make-label label) ,fr))
    (push fb rest)
    (cleanup-protected-continuation label c rest)))

(define-code-generator %throw (n rest)
  (let ((tr (find-register (call-node-arg n 0))))
    (push-instruction `(%throw ,tr))
    rest))

(define-code-generator %catch-block (n rest)
  (let* ((c (get-continuation (call-node-arg n 0)))
	 (nr (find-register (call-node-arg n 1)))
	 (form-fun (call-node-arg n 2))
	 (fb (lambda-node-body form-fun))
	 (fv (first (lambda-node-arglist form-fun)))
	 (fr (find-register fv))
	 (ftr (find-register (second (lambda-node-arglist form-fun))))
	 (label (make-label-node "C")))
    (push-instruction `(%catch-block ,nr ,(make-label label) ,fr ,ftr))
    (push fb rest)
    (cleanup-protected-continuation label c rest)))

(define-code-generator %throw-return-from (n rest)
  (let ((tr (find-register (call-node-arg n 0))))
    (push-instruction `(%throw-return-from ,tr))
    rest))

(define-code-generator %catch-tagbody (n rest)
  (cons (lambda-node-body (call-node-arg n 1)) rest))

(define-code-generator %do-catch-tagbody (n rest)
  (let* ((c (get-continuation (call-node-arg n 0)))
	 (vr (continuation-value-register c))
	 (start (call-node-arg n 1))
	 (slab (if (lambda-node-p start) (make-label-node "TAGBODY") start))
	 (cr (find-register (call-node-arg n 2)))
	 (tr (find-register (call-node-arg n 3))))
    (push-instruction `(%catch-tagbody ,(make-label slab) ,cr ,tr ,vr))
    (when (lambda-node-p start)
	  (push (lambda-node-body start) rest)
	  (push slab rest))
    (cleanup-continuation c rest t)))

(define-code-generator %throw-go (n rest)
  (let* ((tr (find-register (call-node-arg n 0)))
	 (target (call-node-arg n 1))
	 (tlab (if (lambda-node-p target) (make-label-node "TARGET") target)))
    (push-instruction `(%throw-go ,tr ,(make-label tlab)))
    (when (lambda-node-p target)
	  (push (lambda-node-body target) rest)
	  (push tlab rest))
    rest))

(define-code-generator %errset (n rest)
  (let* ((c (get-continuation (call-node-arg n 0)))
	 (form-fun (call-node-arg n 1))
	 (fi (find-register (call-node-arg n 2)))
	 (fb (lambda-node-body form-fun))
	 (fv (first (lambda-node-arglist form-fun)))
	 (fr (find-register fv))
	 (label (make-label-node "C")))
    (push-instruction `(%errset ,(make-label label) ,fr ,fi))
    (push fb rest)
    (cleanup-protected-continuation label c rest)))

(define-code-generator %unwind-protect (n rest)
  (let* ((c (get-continuation (call-node-arg n 0)))
	 (prot-form (call-node-arg n 1))
	 (pfb (lambda-node-body prot-form))
	 (pfv (first (lambda-node-arglist prot-form)))
	 (pfr (find-register pfv))
	 (unwind-form (call-node-arg n 2))
	 (ufb (lambda-node-body unwind-form))
	 (ufv (first (lambda-node-arglist unwind-form)))
	 (ufr (find-register ufv))
	 (label1 (make-label-node "U"))
	 (label2 (make-label-node "U")))
    (push-instruction
     `(%unwind-protect ,(make-label label1) ,(make-label label2) ,pfr ,ufr))
    (push pfb rest)
    (push label1 rest)
    (push ufb rest)
    (cleanup-protected-continuation label2 c rest)))

(define-code-generator %dynamic-bind (n rest)
  (let* ((c (get-continuation (call-node-arg n 0)))
	 (svr (find-register (call-node-arg n 1)))
	 (vvr (find-register (call-node-arg n 2)))
	 (body-form (call-node-arg n 3))
	 (bfb (lambda-node-body body-form))
	 (bfv (first (lambda-node-arglist body-form)))
	 (ulabel (make-label bfv))
	 (label (make-label-node "D")))
    (register-protected-continuation bfv)
    (push-instruction `(%dynamic-bind ,svr ,vvr))
    (push-instruction `(%goto ,(make-label label)))
    (push-instruction (make-label bfv))
    (push-instruction '(%dynamic-unbind))
    (push bfb rest)
    (cleanup-protected-continuation label c rest)))


;;;;
;;;; Y Combinator/Closure Code Generators
;;;;

(define-code-generator %y (n rest)
  (let* ((f (call-node-arg n 0))
	 (names (reverse (lambda-node-arglist f)))
	 (b (lambda-node-body f))
	 (bf (call-node-function b)))
    (when (gfun-eq bf '%make-y-closures)
	  (let* ((bc (call-node-arg b 0))
		 (cr (mapcar #'find-register (lambda-node-arglist bc)))
		 (n (length cr))
		 (bargs (rest (call-node-args b)))
		 (fi (mapcar #'(lambda (x y) (get-function-label x)) bargs cr))
		 (fvr (mapcar #'find-register (nthcdr n bargs)))
		 (nv (length fvr))
		 (ficr nil))
	    (mapc #'(lambda (x y) (push x ficr) (push y ficr)) fi cr)
	    (setf ficr (nreverse ficr))
	    (push-instruction `(%make-y-closures ,n ,nv ,@ficr ,@fvr))
	    (setf b (lambda-node-body bc))))
    (let* ((y-list-args (call-node-args b))
	   (body (first y-list-args))
	   (conts (reverse (rest y-list-args))))
      (mapc #'(lambda (x y) 
		(push (lambda-node-body y) rest)
		(push x rest))
	    names
	    conts)
      (push (lambda-node-body body) rest)
      rest)))

(define-inline-function-generator %make-closure (args r)
  (let ((f (get-function-label (first args)))
	(n (length (rest args)))
	(aregs (mapcar #'find-register (rest args))))
    (push-instruction `(%make-closure ,f ,r ,n ,@aregs))))


;;;;
;;;; Funcall/Apply Code Generators
;;;;

(define-code-generator funcall (n rest)
  (let* ((c (get-continuation (call-node-arg n 0)))
	 (fr (find-register (call-node-arg n 1)))
	 (aregs (mapcar #'find-register (rest (rest (call-node-args n)))))
	 (na (length aregs)))
    (if (final-value-continuation-p c)
	(let ((cr (continuation-register c)))
	  (push-instruction `(%vcall ,fr ,cr ,na ,@aregs)))
        (let ((vr (continuation-value-register c)))
	  (push-instruction `(%save-vcall ,fr ,vr ,na ,@aregs))))
    (cleanup-continuation c rest nil)))
     

;;;;
;;;; Inlined Internal Codes
;;;;

(define-inline-function-generator %symval (args r)
  (push-instruction `(%symval ,(add-literal (first args)) ,r)))

(define-inline-function-generator %symfun (args r)
  (push-instruction `(%symfun ,(add-literal (first args)) ,r)))

(define-inline-function-generator %set-symval (args r)
  (push-instruction `(%set-symval ,(add-literal (first args))
				  ,(find-register (second args))
				  ,r)))

(define-standard-inline-generator %copy)

(define-code-generator %setq (n rest)
  (let* ((c (get-continuation (call-node-arg n 0)))
	 (p (find-register (call-node-arg n 1)))
	 (q (find-register (call-node-arg n 2)))
	 (r (continuation-value-register c)))
    (push-instruction `(%copy ,q ,p))
    (cond
     ((/= r 0) (push-instruction `(%copy ,q ,r)))
     ((not (eq (continuation-type c) 'value-ignored))
      (push-instruction `(%set-one-value ,q))))
    (cleanup-continuation c rest t)))

(define-standard-inline-generator %supplied-p)
(define-standard-inline-generator %make-cell)
(define-standard-inline-generator %cell-value)
(define-standard-inline-generator %set-cell-value)


;**** drop once implementation changes
(define-code-generator %mv-collect (n rest)
  (cleanup-continuation (get-continuation (call-node-arg n 0)) rest nil))

(define-standard-inline-generator %nth-value %nth-value (x))

(define-code-generator %push-values (n rest)
  (let* ((c (get-continuation (call-node-arg n 0)))
	 (r (continuation-value-register c)))
    (unless (= r 0) (push-instruction `(%push-values ,r)))
    (cleanup-continuation c rest nil)))

(define-code-generator %pop-values (n rest)
  (let* ((c (get-continuation (call-node-arg n 0)))
	 (nv (find-register (call-node-arg n 1)))
	 (r (continuation-value-register c)))
    (push-instruction `(%pop-values ,nv))
    (unless (= r 0) (push-instruction `(%get-one-value ,r)))
    (cleanup-continuation c rest t)))


;;;;
;;;; Inlined Function Code Generators
;;;;

;;**** these could handle 3 args specially but funcall for 4 or more
(define-lambda-list + (&rest a))
(define-inline-function-generator + (args r)
  (push-instruction `(%arith2 ,(char-int #\+)
			      ,(find-register (first args))
			      ,(find-register (second args))
			      ,r)))
(define-code-generator-test + (n) (= (call-node-arg-count n) 3))

(define-lambda-list * (&rest a))
(define-inline-function-generator * (args r)
  (push-instruction `(%arith2 ,(char-int #\*)
			      ,(find-register (first args))
			      ,(find-register (second args))
			      ,r)))
(define-code-generator-test * (n) (= (call-node-arg-count n) 3))

(define-lambda-list - (x &rest a))
(define-inline-function-generator - (args r)
  (case (length args)
    (1 (push-instruction `(%arith1 ,(char-int #\-)
				   ,(find-register (first args)) ,r)))
    (2 (push-instruction `(%arith2 ,(char-int #\-)
				   ,(find-register (first args))
				   ,(find-register (second args))
				   ,r)))))
(define-code-generator-test - (n) (<= (call-node-arg-count n) 3))

(define-lambda-list / (x &rest a))
(define-inline-function-generator / (args r)
  (case (length args)
    (1 (push-instruction `(%arith1 ,(char-int #\/)
				   ,(find-register (first args)) ,r)))
    (2 (push-instruction `(%arith2 ,(char-int #\/)
				   ,(find-register (first args))
				   ,(find-register (second args))
				   ,r)))))
(define-code-generator-test / (n) (<= (call-node-arg-count n) 3))

(define-lambda-list min (x &rest a))
(define-inline-function-generator min (args r)
  (push-instruction `(%arith2 ,(char-int #\m)
			      ,(find-register (first args))
			      ,(find-register (second args))
			      ,r)))
(define-code-generator-test min (n) (= (call-node-arg-count n) 3))

(define-lambda-list max (x &rest a))
(define-inline-function-generator max (args r)
  (push-instruction `(%arith2 ,(char-int #\M)
			      ,(find-register (first args))
			      ,(find-register (second args))
			      ,r)))
(define-code-generator-test max (n) (= (call-node-arg-count n) 3))

(defmacro define-arith-pred-generator-2 (sym char)
  `(progn
    (define-lambda-list ,sym (x &rest a))
    (define-inline-function-generator ,sym (args r)
      (push-instruction
       (list '%arith-pred2
	     (char-int ,char)
	     (find-register (first args))
	     (find-register (second args))
	     r)))
    (define-code-generator-test ,sym (n) (= (call-node-arg-count n) 3))))

(define-arith-pred-generator-2 <  #\<)
(define-arith-pred-generator-2 <= #\L)
(define-arith-pred-generator-2 =  #\=)
(define-arith-pred-generator-2 /= #\#)
(define-arith-pred-generator-2 >= #\G)
(define-arith-pred-generator-2 >  #\>)

(define-standard-inline-generator-2 get %get)
(define-standard-inline-generator-2 %set-get)

(define-standard-inline-generator consp %consp (x))
(define-standard-inline-generator endp %endp (x))
(define-standard-inline-generator eq %eq (x y))
(define-standard-inline-generator eql %eql (x y))
(define-standard-inline-generator equal %equal (x y))

(define-inline-function-generator aref (args r)
  (case (length args)
    (2 (push-instruction `(%aref1 ,(find-register (first args))
				  ,(find-register (second args))
				  ,r)))
    (3 (push-instruction `(%aref2 ,(find-register (first args))
				  ,(find-register (second args))
				  ,(find-register (third args))
				  ,r)))))
(define-code-generator-test aref (n) (<= 3 (call-node-arg-count n) 4))
(define-lambda-list aref (x &rest args))

(define-inline-function-generator %set-aref (args r)
  (case (length args)
    (3 (push-instruction `(%set-aref1 ,(find-register (first args))
				      ,(find-register (second args))
				      ,(find-register (third args))
				      ,r)))
    (4 (push-instruction `(%set-aref2 ,(find-register (first args))
				      ,(find-register (second args))
				      ,(find-register (third args))
				      ,(find-register (fourth args))
				      ,r)))))
(define-code-generator-test %set-aref (n) (<= 4 (call-node-arg-count n) 5))
(define-lambda-list %set-aref (x v &rest args))

;;**** check if others are needed
(define-standard-inline-generator %set-nth %set-nth (i x v))
(define-standard-inline-generator rplaca %rplaca (x v))
(define-standard-inline-generator rplacd %rplacd (x v))
(define-standard-inline-generator %set-svref %set-svref (x i v))
(define-standard-inline-generator %set-elt %set-elt (x i v))

(define-standard-inline-generator nth %nth (i x))
(define-standard-inline-generator svref %svref (x i))
(define-standard-inline-generator elt %elt (x i))

(define-standard-inline-generator cons %cons (x y))

(define-lambda-list 1+ (x))
(define-inline-function-generator 1+ (args r)
  (push-instruction `(%arith1 ,(char-int #\p)
			      ,(find-register (first args))
			      ,r)))

(define-lambda-list 1- (x))
(define-inline-function-generator 1- (args r)
  (push-instruction `(%arith1 ,(char-int #\m)
			      ,(find-register (first args))
			      ,r)))


;;
;; SLOT-VALUE
;;

(define-lambda-list slot-value (x &optional y))

(define-inline-function-generator slot-value (args r)
  (case (length args)
    (1 (push-instruction `(%slot-value ,(find-register (first args)) ,r)))
    (2 (push-instruction `(%set-slot-value ,(find-register (first args))
					   ,(find-register (second args))
					   ,r)))))

;;
;; C?R, C??R and C???R
;;

(define-lambda-list car (x))
(define-standard-inline-generator car %car)

(define-lambda-list cdr (x))
(define-standard-inline-generator cdr %cdr)

(defmacro define-cxr-generator (name n x)
  `(progn
     (define-lambda-list ,name (x))
     (define-inline-function-generator ,name (args r)
       (push-instruction (list '%cxr ,n ,x  (find-register (first args)) r)))))

(define-cxr-generator caar 2 #b11)
(define-cxr-generator cadr 2 #b10)
(define-cxr-generator cdar 2 #b01)
(define-cxr-generator cddr 2 #b00)

(define-cxr-generator caaar 3 #b111)
(define-cxr-generator caadr 3 #b110)
(define-cxr-generator cadar 3 #b101)
(define-cxr-generator caddr 3 #b100)
(define-cxr-generator cdaar 3 #b011)
(define-cxr-generator cdadr 3 #b010)
(define-cxr-generator cddar 3 #b001)
(define-cxr-generator cdddr 3 #b000)

;;
;; CAR and CDR setf methods
;;

(define-standard-inline-generator %set-car %set-car (x v))
(define-standard-inline-generator %set-cdr %set-cdr (x v))