;;; TidbitCedar.scheme
;;; Copyright Ó 1988, 1989, 1991 by Xerox Corporation. All rights reserved.
;;; Last changed by Pavel on August 11, 1989 6:25:38 pm PDT
;;; Cedar code generation
(define (generate! code initial-pc continuation-pc)
(generate-tails code continuation-pc)
(generate-head code initial-pc continuation-pc))
(define (generate-tails code continuation-pc)
(unless (null? code)
(let ((inst (car code)))
(case (car inst)
((←)
(generate-tails (cdr code) continuation-pc))
((tail-call return)
(unless (null? (cdr code))
(error 'generate! code "BUG: Code after RETURN or TAIL-CALL")))
((call)
(if (null? (cdr code))
(set-cdr! (cddr inst) continuation-pc)
(let ((new-pc (next-pc!)))
(generate! (cdr code) new-pc continuation-pc)
(set-cdr! (cddr inst) new-pc))))
((if)
(if (cadr inst)
;; Complex IF (contains CALL instructions)
(cond
((null? (cdr code)) ; Nothing after this CALL
(set-car! (cdr inst) continuation-pc)
(generate-tails (cadddr inst) continuation-pc)
(generate-tails (car (cddddr inst)) continuation-pc))
(else
(let ((new-pc (next-pc!)))
(set-car! (cdr inst) new-pc)
(generate-tails (cadddr inst) new-pc)
(generate-tails (car (cddddr inst)) new-pc)
(generate! (cdr code) new-pc continuation-pc))))
;; Simple IF (no CALL instructions)
(generate-tails (cdr code) continuation-pc)))))))
(define *current-pc* (make-dynamic 0))
(define (generate-head code initial-pc continuation-pc)
(emit-nest (format #f "~S => {" initial-pc))
(dynamic-bind ((*current-pc* initial-pc))
(generate-seq code continuation-pc))
(emit-unnest "};"))
(define (generate-seq code continuation-pc)
(if (null? code)
(generate-goto continuation-pc)
(generate-nonempty-seq code continuation-pc)))
(define (generate-nonempty-seq code continuation-pc)
(generate-inst (car code) continuation-pc (null? (cdr code)))
(unless (or (null? (cdr code))
(eq? (caar code) 'call)
(and (eq? (caar code) 'if)
(cadar code)))
(generate-nonempty-seq (cdr code) continuation-pc)))
(define (generate-goto pc)
(generate-pc pc)
(emit "LOOP;"))
(define (generate-pc pc)
(unless (= pc (+ (dynamic-ref *current-pc*) 1))
(emit (format #f "pc ← ~S;" pc))))
(define (generate-bottom bottom)
(unless (= bottom 0)
(emit (format #f "bottom ← ~S;" bottom))))
(define (generate-n n)
(unless (= n 2)
(emit (format #f "n ← ~S;" n))))
(define (generate-inst inst continuation-pc at-end?)
(case (car inst)
((←) ; (← sname name)
(if (string? (caddr inst))
(emit (format #f "~A ← ~A;" (cadr inst) (caddr inst)))
(emit (format #f "~A ← CloseProcedure[~A, env];"
(cadr inst)
(cadr (caddr inst)))))
(when (and continuation-pc at-end?)
(generate-goto continuation-pc)))
((return) ; (return)
(dynamic-set! *return-exit-used* #t)
(emit "GOTO returnExit;"))
((tail-call) ; (tail-call n bottom)
(dynamic-set! *tail-call-exit-used* #t)
(generate-n (cadr inst))
(generate-bottom (caddr inst))
(emit "GOTO tailExit;"))
((call) ; (call n bottom . return-pc)
(dynamic-set! *fall-thru-code-used* #t)
(generate-pc (cdddr inst))
(generate-n (cadr inst))
(generate-bottom (caddr inst)))
((if) ; (if cont-pc sname then-seq else-seq)
(let ((cont-pc (cadr inst))
(test (caddr inst))
(then-seq (cadddr inst))
(else-seq (car (cddddr inst))))
(define (doit label seq)
(emit-nest (format #f "~A => {" label))
(generate-seq seq cont-pc)
(emit-unnest "};"))
(unless (and (null? then-seq) (null? else-seq))
(emit-nest (format #f "SELECT ~A FROM" test))
(doit "false, NIL" else-seq)
(doit "ENDCASE" then-seq)
(unnest))
(when (and (not cont-pc)
(generate-goto continuation-pc))))))
) ; end export