(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 () (instructions))
(lambda () (cg-jump (car cd) nextlab))
(lambda () (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 () (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 () (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 () (instructions))
(lambda () (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 () (cg `(if (pair? ,(car args)) '#t '#f) fs dd cd nextlab))
(lambda () (cg `(if (pair? ,(car args)) '#t '#f) fs dd cd nextlab))
(lambda () (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 () (instructions))
(lambda () (instructions
(inst-gen 'ac)
`(cmp ac ,(encode #f))
(cg-branch cd nextlab 'bne 'be)))
(lambda () (instructions
(inst-gen 'ac)
`(ld (fp 0) t1)
`(jmp t1)
`(nop)))
(lambda () (instructions
(inst-gen dd)
(cg-jump cd nextlab)))
(lambda () (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 () (instructions))
(lambda () (instructions
`(ld ,location t1)
`(cmp t1 ,(encode #f))
(cg-branch cd nextlab 'bne 'be)))
(lambda () (if (eq? dd 'ac)
(instructions
`(ld ,location ac)
`(ld (fp 0) t1)
`(jmp t1)
`(nop))
(error 'cg "sanity-check")))
(lambda () (instructions
`(ld ,location ,dd)
(cg-jump cd nextlab)))
(lambda () (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)] )]
[(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))]))))