(define stack-base-words 1)
(define closure-base-words 2)

(define cg
  (lambda (exp fs dd cd nextlab)
    (record-case exp
      [bound (n name)
	(cg-ref `(fp ,(* (+ n stack-base-words) ws)) dd cd nextlab)]
      [free (n name)
	(cg-ref `(cp ,(* (+ n closure-base-words) ws)) dd cd nextlab)]
      [quote (obj) ... ]
      [begin (a b)
	(let ([new-label (gen-label "begin")])
	  (instructions
	    (cg a fs 'effect new-label new-label)
	    `(label ,new-label)
	    (cg b fs dd cd nextlab)))]
      [if (t c a) ... ]
      [build-closure (code . fvars) ... ]
      [else
        (if (symbol? (car exp))
	    (cg-prim (car exp) (cdr exp) fs dd cd nextlab)
            (if (eq? cd 'return)
                ...
                ...))])))

(define cg-prim
  (lambda (name args fs dd cd nextlab)
    (instructions
      
      (case name
	[(car)
	 (let ([endargs (gen-label "endargs")])
	   (instructions
	     (cg (car args) (+ fs (* (length (cdr args)) ws))
	       'ac endargs endargs)
	     `(label ,endargs)
	     (cg-prim-tf (lambda (reg) 
			   `(ld (ac ,(- pair-tag)) ,reg))
	       fs dd cd nextlab)))]
	
	[(cdr)
	 (let ([endargs (gen-label "endargs")])
	   (instructions
	     (cg (car args) (+ fs (* (length (cdr args)) ws))
	       'ac endargs endargs)
	     `(label ,endargs)
	     (cg-prim-tf (lambda (reg) 
			   `(ld (ac ,(- ws pair-tag)) ,reg))
	       fs dd cd nextlab)))]
	[(cons)
	 (if (null? args)
	     (instructions)
	     (let ([endargs (gen-label "endargs")])
	       (instructions
		 (cg-arguments fs (cdr args))
		 (cg (car args) (+ fs (* (length (cdr args)) ws))
		   'ac endargs endargs)
		 `(label ,endargs))))
	 (cg-dispatch dd cd
	   (lambda ()			; begin
	     (instructions))
	   (lambda ()			; if
	     (cg-jump (car cd) nextlab))
	   (lambda ()			; return
	     (instructions
	       (cg-allocate (* ws 2) t1)
	       `(st ac (t1 0))
	       `(ld (fp ,fs) ac)
	       `(st ac (t1 ,ws))
	       `(or t1 ,pair-tag ac)
	       (cg-return)))
	   (lambda ()			; reg
	     (instructions
	       (cg-allocate (* ws 2) t1)
	       `(st ac (t1 0))
	       `(ld (fp ,fs) ac)
	       `(st ac (t1 ,ws))
	       `(or t1 ,pair-tag ,dd)
	       (cg-jump cd nextlab)))
	   (lambda ()			; reg-offset
	     (instructions
	       (cg-allocate (* ws 2) t1)
	       `(st ac (t1 0))
	       `(ld (fp ,fs) ac)
	       `(st ac (t1 ,ws))
	       `(or t1 ,pair-tag ac)
	       `(st ac ,dd)
	       (cg-jump cd nextlab))))]
	[(pair?)
	 (cg-dispatch dd cd
	   (lambda ()			; begin
	     (instructions))
	   (lambda ()			; if
	     (let ([endargs (gen-label "endargs")])
	       (instructions
		 (cg (car args) (+ fs (* (length (cdr args)) ws))
		   'ac endargs endargs)
		 `(label ,endargs)))
	     (instructions
	       `(andn ac ,mask ac)
	       `(cmp ac ,pair-tag)
	       (cg-branch cd nextlab 'be 'bne)))
	   (lambda ()			; return
	     (cg `(if (pair? ,(car args)) '#t '#f) fs dd cd nextlab))
	   (lambda ()			; reg
	     (cg `(if (pair? ,(car args)) '#t '#f) fs dd cd nextlab))
	   (lambda ()			; reg-offset
	     (cg `(if (pair? ,(car args)) '#t '#f) fs dd cd nextlab)))
	 ]))))

(define cg-return
  (lambda ()
    (instructions
      `(ld (fp 0) t1)
      `(jmp t1)
      `(nop))))

(define cg-allocate
  (lambda (bytes reg)
    (let ([real-bytes (quotient (+ bytes 7) 8)])
      (instructions
	`(mov ap ,reg)
	`(add ap ,real-bytes ap)))))

(define cg-prim-tf
  (lambda (inst-gen fs dd cd nextlab)
    (cg-dispatch dd cd
      (lambda ()			; begin
	(instructions))
      (lambda ()			;if
	(instructions
	  (inst-gen 'ac)
	  `(cmp ac ,(encode #f))
	  (cg-branch cd nextlab 'bne 'be)))
      (lambda ()			; return
	(instructions
	  (inst-gen 'ac)
	  `(ld (fp 0) t1)
	  `(jmp t1)
	  `(nop)))
      (lambda ()			; reg
	(instructions
	  (inst-gen dd)
	  (cg-jump cd nextlab)))
      (lambda ()			; reg-off
	(let ([register (car dd)]
	      [offset (cadr dd)])
	  (instructions
	    (inst-gen 'ac)
	    `(st ac (,register ,offset))
	    (cg-jump cd nextlab)))))))



(define cg-dispatch-dd
  (lambda (dd reg reg-off)
    (cond
      [(eq? dd 'effect)
       
       (instructions)]
      [(pair? dd)
       (reg)]
      [else
	(reg-off)])))


(define cg-arguments
  (lambda (fs ls)
    (if (null? ls)
	(instructions)
	(let ([argslab (gen-label "arg")])
	  (instructions
	    (cg (car ls) fs `(fp ,fs) argslab argslab)
	    `(label ,argslab)
	    (cg-arguments (+ fs ws) (cdr ls)))))))

(define cg-ref
  (lambda (location dd cd nextlab)
    (cg-dispatch
      dd cd
      (lambda ()			; begin
	(instructions))
      (lambda ()			; if
	(instructions
	  `(ld ,location t1)
	  `(cmp t1 ,(encode #f))
	  (cg-branch cd nextlab 'bne 'be)))
      (lambda ()			; return
	(if (eq? dd 'ac)
	    (instructions
	      `(ld ,location ac)
	      `(ld (fp 0) t1)
	      `(jmp t1)
	      `(nop))
	    (error 'cg "sanity-check")))
      (lambda ()			; reg
	(instructions
	  `(ld ,location ,dd)
	  (cg-jump cd nextlab)))
      (lambda ()			; reg-off
	(let ([register (car dd)]
	      [offset (cadr dd)])
	  (instructions
	    `(ld ,location t1)
	    `(st t1 (,register ,offset))
	    (cg-jump cd nextlab)))))))

(define cg-dispatch
  (lambda (cd dd do-begin do-if do-return do-reg do-reg-offset)
    (cond
      [(eq? dd 'effect)
       (cond
	 [(eq? cd 'return)
	  (error 'cg "sanity-check")]
	 [(pair? cd)
	  (do-if)]
	 [else
	   (do-begin)]			; (begin x ...)
	 )]
      [(pair? dd)
       (cond
	 [(eq? cd 'return)
	  (error 'cg "sanity-check")]
	 [(pair? cd)
	  (error 'cg "sanity-check")]
	 [else
	   (do-reg-offset)])]
      [else
	(cond
	  [(eq? cd 'return)
	   (do-return)]
	  [(pair? cd)
	   (error 'cg "sanity-check")]
	  [else
	    (do-reg)])])))

(define cg-jump
  (lambda (cd nextlab)
    (if (eq? cd nextlab)
	(instructions)
	(instructions
	  `(ba ,cd)
	  `(nop)))))

(define cg-branch
  (lambda (cd nextlab br-true br-false)
    (let ([truelab (car cd)]
	  [falselab (cadr cd)])
      (cond
	[(eq? truelab nextlab)
	 (instructions
	   `(,br-false ,falselab)
	   `(nop))]
	[(eq? falselab nextlab)
	 (instructions
	   `(,br-true ,truelab)
	   `(nop))]
	[else
	  (instructions
	    `(,br-false ,falselab)
	    `(nop)
	    `(ba ,truelab)
	    `(nop))]))))