790 lines
23 KiB
Common Lisp
790 lines
23 KiB
Common Lisp
|
||
; -*- Mode: Lisp -*- Filename: pgencode.s
|
||
|
||
; Last Revision: 1-Oct-85 1630ct
|
||
|
||
;--------------------------------------------------------------------------;
|
||
; ;
|
||
; TI SCHEME -- PCS Compiler ;
|
||
; Copyright 1985 (c) Texas Instruments ;
|
||
; ;
|
||
; David Bartley ;
|
||
; ;
|
||
; Code Generation ;
|
||
; ;
|
||
;--------------------------------------------------------------------------;
|
||
;
|
||
; Note: The current implementation never changes REG-BASE, so the
|
||
; registers may be sparsely used. Consider using fewer registers
|
||
; and implementing a wrap-around algorithm.
|
||
;
|
||
; Note: There is currently no check to ensure that DEST never exceeds
|
||
; MAX-REGNUM. Somebody ought to do something about that!
|
||
; (Implementing wrap-around would fix this, too.)
|
||
;
|
||
;--------------------------------------------------------------------------;
|
||
|
||
(define pcs-gencode
|
||
(lambda (exp)
|
||
(letrec
|
||
;------!
|
||
((debug-mode pcs-debug-mode)
|
||
|
||
(max-regnum 62) ; highest available register number
|
||
; r0 reserved for '()
|
||
; r63 used by ppeep
|
||
(compiled-lambda-list '()) ; code for previously compiled closures
|
||
|
||
(gen-code
|
||
(lambda (entry-name ; label for the code block
|
||
body ; expression to be compiled
|
||
bvl ; bound variable list
|
||
lex-level ; lambda nesting level
|
||
senv ; stack component of the lexical environment
|
||
henv ; heap component of the lexical environment
|
||
cenv) ; compile-time component of the lex env
|
||
(letrec
|
||
;--------------!
|
||
(
|
||
(code '()) ; list of generated instructions and labels
|
||
(tos -1) ; stack level (size of current frame)
|
||
(reg-base -1) ; stack offset equivalent to register 0
|
||
(last-label '()) ; last code entry label referenced
|
||
|
||
(gen
|
||
(lambda (x dest tr?)
|
||
(cond ((atom? (car x))
|
||
(case (car x)
|
||
(quote (gen-quote x dest tr?))
|
||
(T (gen-id x dest tr?))
|
||
(lambda (gen-closure x dest tr?))
|
||
(if (gen-if x dest tr?))
|
||
(set! (gen-set! x dest tr?))
|
||
(%call/cc (gen-ccc x dest tr?))
|
||
(begin (gen-begin (cdr x) dest tr?))
|
||
(%apply (gen-apply x dest tr?))
|
||
(letrec (gen-letrec x dest tr?))
|
||
(else (gen-primitive x dest tr?))))
|
||
((eq? (caar x) 'LAMBDA)
|
||
(gen-let x dest tr?))
|
||
(else
|
||
(gen-application x dest tr?)))))
|
||
|
||
(gen-quote
|
||
(lambda (x dest tr?)
|
||
(emit-load dest
|
||
(if (null? (cadr x)) 0 x)) ; use R0 for '()
|
||
(continue dest tr?)))
|
||
|
||
(gen-id
|
||
(lambda (id dest tr?)
|
||
(let ((name (id-name id))
|
||
(info (assq id senv)))
|
||
(if info
|
||
(let ((dlevel (- lex-level (cddr info)))
|
||
(offset (cadr info)))
|
||
(if (and (zero? dlevel) ( > offset tos))
|
||
(emit-load dest (- offset reg-base) name)
|
||
(emit-load dest `(STACK ,offset ,dlevel) name)))
|
||
(emit-load dest (list 'HEAP name)))
|
||
(continue dest tr?))))
|
||
|
||
(gen-set!
|
||
(lambda (x dest tr?)
|
||
(let* ((id (cadr x))
|
||
(value (caddr x))
|
||
(name (id-name id))
|
||
(info (assq id senv)))
|
||
(gen value dest #!false)
|
||
(if info
|
||
(let ((dlevel (- lex-level (cddr info)))
|
||
(offset (cadr info)))
|
||
(if (and (zero? dlevel) ( > offset tos))
|
||
(emit-load (- offset reg-base) dest (cons 'SET name))
|
||
(emit 'STORE `(STACK ,offset ,dlevel) dest name)))
|
||
(emit 'STORE (list 'HEAP name) dest))
|
||
(continue dest tr?))))
|
||
|
||
(gen-closure
|
||
(lambda (x dest tr?)
|
||
(let ((label (lambda-label x))
|
||
(bvl (lambda-bvl x)))
|
||
(gen-code label
|
||
(lambda-body x)
|
||
bvl
|
||
(add1 lex-level)
|
||
senv
|
||
henv
|
||
cenv)
|
||
(when (or debug-mode (lambda-closed? x))
|
||
(emit-load dest ; set up closure name
|
||
(if (null? (lambda-debug x))
|
||
0 ; use R0 for '()
|
||
(list 'QUOTE (lambda-debug x))))
|
||
(emit 'CLOSE dest
|
||
dest
|
||
(list label (lambda-nargs x)))
|
||
(set! last-label label)
|
||
(continue dest tr?)))))
|
||
|
||
(gen-if
|
||
(lambda (x dest tr?)
|
||
(let ((pred (if-pred x))
|
||
(then (if-then x))
|
||
(else (if-else x)))
|
||
(gen pred dest #!false)
|
||
(restore-regs dest)
|
||
(let* ((tos0 tos)
|
||
(out (gensym 'I)))
|
||
(cond ; (if a b '())
|
||
((equal? else ''())
|
||
(emit-live dest)
|
||
(emit 'JUMP out 'NULL? dest)
|
||
(gen then dest tr?)
|
||
(restore-tos tos0 tr?)
|
||
(emit-label out)
|
||
(continue dest tr?)
|
||
) ; (if a '() c)
|
||
((equal? then ''())
|
||
(emit 'NOT dest dest)
|
||
(emit-live dest)
|
||
(emit 'JUMP out 'NULL? dest)
|
||
(gen else dest tr?)
|
||
(restore-tos tos0 tr?)
|
||
(emit-label out)
|
||
(continue dest tr?)
|
||
) ; (if a a c)
|
||
((or (eq? pred then)
|
||
(and (memq (car pred) ; no side effects?
|
||
'(%%get-global%%
|
||
%%get-scoops%%
|
||
%%get-fluid%%))
|
||
(equal? pred then)))
|
||
(emit-live dest)
|
||
(emit 'JUMP out 'T? dest)
|
||
(gen else dest tr?)
|
||
(restore-tos tos0 tr?)
|
||
(emit-label out)
|
||
(continue dest tr?)
|
||
) ; (if a b c)
|
||
(else
|
||
(let ((lelse (gensym 'L)))
|
||
(emit-live dest)
|
||
(emit 'JUMP lelse 'NULL? dest)
|
||
(gen then dest tr?)
|
||
(restore-tos tos0 tr?)
|
||
(when (not tr?)
|
||
(emit-live dest)
|
||
(emit-jump out))
|
||
(emit-label lelse)
|
||
(gen else dest tr?)
|
||
(restore-tos tos0 tr?)
|
||
(when (not tr?)
|
||
(emit-label out)))))
|
||
))))
|
||
|
||
(gen-ccc
|
||
(lambda (x dest tr?)
|
||
(let* ((fun (cadr x))
|
||
(info (assq fun cenv))) ; CENV = () in debug mode
|
||
(if info
|
||
(let* ((label (cadr info)) ; open call
|
||
(delta-level (- lex-level
|
||
(caddr info)))
|
||
(delta-heap (- (length henv)
|
||
(length (cadddr info)))))
|
||
(set! last-label label)
|
||
(restore-regs dest)
|
||
(if (and tr? ( >= delta-level 0))
|
||
(emit 'CALL
|
||
`(OPEN-TR ,label ,delta-level ,delta-heap)
|
||
'CC)
|
||
(begin
|
||
(save-regs dest)
|
||
(emit 'CALL
|
||
`(OPEN ,label ,delta-level ,delta-heap)
|
||
'CC)
|
||
(emit-copy dest 1)
|
||
(continue dest tr?))))
|
||
(begin ; closed call
|
||
(gen fun dest #!false)
|
||
(restore-regs dest)
|
||
(if tr?
|
||
(emit 'CALL 'CLOSED-TR 'CC dest)
|
||
(begin
|
||
(save-regs dest)
|
||
(emit 'CALL 'CLOSED 'CC dest)
|
||
(emit-copy dest 1))))))))
|
||
|
||
(gen-begin
|
||
(lambda (x dest tr?)
|
||
(if (null? (cdr x))
|
||
(gen (car x) dest tr?)
|
||
(begin
|
||
(gen (car x) dest #!false)
|
||
(gen-begin (cdr x) dest tr?)))))
|
||
|
||
(gen-apply
|
||
(lambda (x dest tr?)
|
||
(let ((fun (cadr x))
|
||
(arg (caddr x))
|
||
(dest1 (add1 dest)))
|
||
(gen arg dest #!false)
|
||
(gen fun dest1 #!false)
|
||
(restore-regs dest)
|
||
(if tr?
|
||
(emit 'CALL 'CLOSED-APPLY-TR dest1 dest)
|
||
(begin
|
||
(save-regs dest)
|
||
(emit 'CALL 'CLOSED-APPLY dest1 dest)
|
||
(emit-copy dest 1))))))
|
||
|
||
(gen-let
|
||
(lambda (x dest tr?)
|
||
(let ((fun (car x))
|
||
(args (cdr x)))
|
||
(gen-args args dest)
|
||
(restore-regs dest)
|
||
(let ((save-henv henv)
|
||
(save-senv senv)
|
||
(save-cenv cenv))
|
||
(set! henv (cons '() henv))
|
||
(let ((newdest (extend-bvl (lambda-bvl fun) dest)))
|
||
(gen (lambda-body fun) newdest tr?)
|
||
(when (not tr?)
|
||
(restore-regs newdest)
|
||
(drop dest)
|
||
(drop-env (- (length henv) ; normally 1 or 0
|
||
(length save-henv)))
|
||
(emit-copy dest newdest))
|
||
(set! henv save-henv)
|
||
(set! senv save-senv)
|
||
(set! cenv save-cenv))))))
|
||
|
||
|
||
;;
|
||
;; LETREC pairs must be handled VERY carefully! We pass over them three
|
||
;; times in order to get CENV, SENV, and (especially) HENV correct when
|
||
;; referenced from within the pair expressions.
|
||
;;
|
||
;; Pass 1 - Determine which runtime variables must be heap allocated
|
||
;; and reserve space for them on the heap-allocated stack.
|
||
;; When done, HENV and SENV reflect the proper lexical
|
||
;; environment for generating the code for the body AND the
|
||
;; pairs themselves.
|
||
;;
|
||
;; Pass 2 - Add all compile-time only variables and "well-behaved"
|
||
;; runtime variables to CENV. Note that CENV entries include
|
||
;; the HENV in effect at the time of CLOSURE, which is AFTER all
|
||
;; pair IDs have been allocated homes (in the first pass).
|
||
;;
|
||
;; Pass 3 - Generate code to assign pair expression values to pair IDs.
|
||
;; Note that Passes 1 and 3 must have exactly the same behavior
|
||
;; with respect to maintaining DEST. Thus, they have the same
|
||
;; general structure.
|
||
|
||
(gen-letrec
|
||
(lambda (x dest tr?)
|
||
(let ((save-henv henv)
|
||
(save-senv senv)
|
||
(save-cenv cenv))
|
||
(set! henv (cons '() henv)) ; add a rib
|
||
(let ((newdest (gen-pairs (letrec-pairs x) dest))
|
||
(body (letrec-body x)))
|
||
(gen body newdest tr?)
|
||
(when (not tr?)
|
||
(restore-regs newdest)
|
||
(drop dest)
|
||
(drop-env (- (length henv) ; normally 1 or 0
|
||
(length save-henv)))
|
||
(emit-copy dest newdest))
|
||
(set! henv save-henv)
|
||
(set! senv save-senv)
|
||
(set! cenv save-cenv)))))
|
||
|
||
(gen-pairs
|
||
(lambda (pairs dest)
|
||
(gen-pairs-1 pairs dest)
|
||
(when (not debug-mode)
|
||
(gen-pairs-2 pairs))
|
||
(gen-pairs-3 pairs dest)))
|
||
|
||
(gen-pairs-1
|
||
(lambda (pairs dest)
|
||
(if (null? pairs)
|
||
(if (null? (car henv))
|
||
(set! henv (cdr henv))
|
||
(begin
|
||
(set-car! henv (reverse! (car henv)))
|
||
(emit 'PUSH-ENV (car henv))))
|
||
(let ((id (caar pairs))
|
||
(exp (cadar pairs)))
|
||
(gen-pairs-1
|
||
(cdr pairs)
|
||
(if (or debug-mode (id-rtv? id))
|
||
(if (or debug-mode (id-heap? id))
|
||
(begin ; heap-alloc lex var
|
||
(set-car! henv
|
||
(cons (id-name id) (car henv)))
|
||
dest)
|
||
(begin ; stack/reg-alloc lex var
|
||
(set! senv
|
||
(cons (cons id
|
||
(cons (+ reg-base dest)
|
||
lex-level))
|
||
senv))
|
||
(add1 dest))) ; reserve a register
|
||
dest))))))
|
||
|
||
|
||
(gen-pairs-2
|
||
(lambda (pairs)
|
||
(when pairs ; not called in debug mode
|
||
(let ((id (caar pairs))
|
||
(exp (cadar pairs)))
|
||
(when (or (not (id-rtv? id))
|
||
(and (not (id-set!? id))
|
||
(eq? (car exp) 'lambda)
|
||
(not (negative? (lambda-nargs exp)))))
|
||
(set! cenv
|
||
(cons (list id (lambda-label exp)
|
||
(add1 lex-level) henv)
|
||
cenv))))
|
||
(gen-pairs-2 (cdr pairs)))))
|
||
|
||
(gen-pairs-3
|
||
(lambda (pairs dest)
|
||
(if (null? pairs)
|
||
dest
|
||
(let ((id (caar pairs))
|
||
(exp (cadar pairs)))
|
||
(gen exp dest #!false)
|
||
(restore-regs dest)
|
||
(gen-pairs-3
|
||
(cdr pairs)
|
||
(if (or debug-mode (id-rtv? id))
|
||
(if (or debug-mode (id-heap? id))
|
||
(begin
|
||
(when (not (equal? exp '(quote ())))
|
||
(emit 'STORE (list 'HEAP (id-name id))
|
||
dest))
|
||
dest)
|
||
(add1 dest))
|
||
dest))))))
|
||
|
||
;; Bound variable lists are similar to LETREC pairs, but much easier to
|
||
;; deal with, since they are always runtime variables. Thus, EXTEND-BVL
|
||
;; is a simplified combination of GEN-PAIRS-1 (setting up HENV and SENV)
|
||
;; and GEN-PAIRS-3 (emitting PUSH-ENV instructions when needed).
|
||
|
||
(extend-bvl
|
||
(lambda (bvl dest)
|
||
(extend-bvl-1 bvl dest)
|
||
(extend-bvl-2 bvl dest)))
|
||
|
||
(extend-bvl-1
|
||
(lambda (bvl dest)
|
||
(if (null? bvl)
|
||
(if (and (not debug-mode)
|
||
(null? (car henv)))
|
||
(set! henv (cdr henv)) ; null env frame
|
||
(begin
|
||
(set-car! henv (reverse! (car henv)))
|
||
(emit 'PUSH-ENV (car henv))))
|
||
(let ((id (car bvl)))
|
||
(if (or debug-mode (id-heap? id))
|
||
(set-car! henv (cons (id-name id) (car henv)))
|
||
(set! senv
|
||
(cons (cons id
|
||
(cons (+ reg-base dest)
|
||
lex-level))
|
||
senv)))
|
||
(extend-bvl-1 (cdr bvl) (add1 dest))))))
|
||
|
||
(extend-bvl-2
|
||
(lambda (bvl dest)
|
||
(if (null? bvl)
|
||
dest
|
||
(let ((id (car bvl)))
|
||
(when (or debug-mode (id-heap? id))
|
||
(emit 'STORE (list 'HEAP (id-name id)) dest))
|
||
(extend-bvl-2 (cdr bvl) (add1 dest))))))
|
||
|
||
(gen-application
|
||
(lambda (x dest tr?)
|
||
(let ((fun (car x)))
|
||
(let ((nargs (length (cdr x))))
|
||
(when (not (zero? nargs))
|
||
(gen-args (cdr x) dest))
|
||
(let ((info (assq fun cenv))) ; CENV = () in debug mode
|
||
(if info
|
||
;; open call
|
||
(let* ((label (cadr info))
|
||
(delta-level (- lex-level
|
||
(caddr info)))
|
||
(delta-heap (- (length henv)
|
||
(length (cadddr info)))))
|
||
(when (not (= nargs (lambda-nargs (id-init fun))))
|
||
(syntax-error "Wrong number of arguments in call"
|
||
(id-name fun)))
|
||
(set! last-label label)
|
||
(restore-regs dest)
|
||
(if (and tr? ; tail recursive
|
||
( >= delta-level 0)) ; frame not needed
|
||
(begin
|
||
(move-regs dest 1 nargs)
|
||
(if (zero? delta-level)
|
||
(begin
|
||
(drop-all)
|
||
(drop-env delta-heap)
|
||
(emit-live nargs)
|
||
(emit-jump label))
|
||
(emit 'CALL
|
||
`(OPEN-TR ,label ,delta-level
|
||
,delta-heap)
|
||
(list nargs))))
|
||
(begin
|
||
(save-regs dest)
|
||
(move-regs dest 1 nargs)
|
||
(emit 'CALL
|
||
`(OPEN ,label ,delta-level ,delta-heap)
|
||
(list nargs))
|
||
(emit-copy dest 1)
|
||
(continue dest tr?))))
|
||
;; closed call
|
||
(let ((funreg (+ dest nargs)) ; compute function here
|
||
(nargs1 (+ nargs 1))) ; then move it here
|
||
;; must compute function before moving regs down
|
||
(gen fun funreg #!false)
|
||
(restore-regs dest)
|
||
(if tr?
|
||
(begin
|
||
(move-regs dest 1 nargs1)
|
||
(emit 'CALL
|
||
'CLOSED-TR (list nargs) nargs1))
|
||
(begin
|
||
(save-regs dest)
|
||
(move-regs dest 1 nargs1)
|
||
(emit 'CALL
|
||
`CLOSED (list nargs) nargs1)
|
||
(emit-copy dest 1))))))))))
|
||
|
||
(out-of-registers!
|
||
(lambda ()
|
||
(error " *** Compiler ran out of registers ***")))
|
||
|
||
(gen-args
|
||
(lambda (args dest)
|
||
(when args
|
||
(when (> dest max-regnum)
|
||
(out-of-registers!))
|
||
(gen (car args) dest #!false)
|
||
(gen-args (cdr args)(add1 dest)))))
|
||
|
||
(gen-primitive
|
||
(lambda (x dest tr?)
|
||
(let ((primop (car x)))
|
||
;; (when (null? primop)
|
||
;; (set! **null-primop** x)
|
||
;; (writeln "++ Null primop found, saved in **NULL-PRIMOP**"))
|
||
(cond (( >= (+ dest (length (cdr x))) max-regnum)
|
||
(out-of-registers!))
|
||
((memq primop '(%%get-global%% %%set-global%%
|
||
%%get-scoops%% %%set-scoops%%
|
||
%%def-global%% %%get-fluid%%
|
||
%%set-fluid%% %%bind-fluid%%
|
||
%%unbind-fluid%%))
|
||
(case primop
|
||
(%%get-global%% (gen-global-ref x dest tr? 'HEAP))
|
||
(%%set-global%% (gen-global-set x dest tr? 'HEAP))
|
||
(%%get-scoops%% (gen-global-ref x dest tr? 'GLOBAL))
|
||
(%%set-scoops%% (gen-global-set x dest tr? 'GLOBAL))
|
||
(%%def-global%% (gen-global-def x dest tr?))
|
||
(%%get-fluid%% (gen-fluid-ref x dest tr?))
|
||
(%%set-fluid%% (gen-fluid-set x dest tr?))
|
||
(%%bind-fluid%% (gen-fluid-bind x dest tr?))
|
||
(else (gen-fluid-unbind x dest tr?))))
|
||
((memq primop '(%xesc)) ;variable-length instructions
|
||
(let* ((inst-length (cadr x))
|
||
(src-regs (gen-prim-args (cddr x) dest))
|
||
(newdest (if (null? src-regs)
|
||
dest
|
||
(car src-regs)))
|
||
(instr `(,primop ,newdest ,inst-length ,@src-regs)))
|
||
(restore-regs dest)
|
||
(emit* instr)
|
||
(emit-copy dest newdest)
|
||
(continue dest tr?)))
|
||
((and (memq primop '(+ - * / ))
|
||
(eq? (car (caddr x)) 'quote)
|
||
(integer? (cadr (caddr x)))
|
||
(< (abs (cadr (caddr x))) 128))
|
||
(gen (cadr x) dest #!false)
|
||
(restore-regs dest)
|
||
(emit (cdr (assq primop
|
||
'((+ . %+imm)(- . %+imm)
|
||
(* . %*imm)(/ . %/imm))))
|
||
dest
|
||
dest
|
||
(if (eq? primop '-)
|
||
`(quote ,(minus (cadr (caddr x))))
|
||
(caddr x)))
|
||
(continue dest tr?))
|
||
(else
|
||
(let* ((src-regs (gen-prim-args (cdr x) dest))
|
||
(newdest (if (null? src-regs)
|
||
dest
|
||
(car src-regs)))
|
||
(instr (cons primop (cons newdest src-regs))))
|
||
(restore-regs dest)
|
||
(emit* instr)
|
||
(emit-copy dest newdest)
|
||
(continue dest tr?)))))))
|
||
|
||
(gen-prim-args
|
||
(lambda (args dest)
|
||
(cond ((null? args) ; 0 args
|
||
'())
|
||
((null? (cdr args)) ; 1 arg
|
||
(gen (car args) dest #!false)
|
||
(list dest))
|
||
(else
|
||
(let ((arg1 (car args))
|
||
(arg2 (cadr args))
|
||
(dest1 (+ dest 1)))
|
||
(if (and (memq (car arg1) '(t quote %%get-global%%))
|
||
(not (memq (car arg2) '(t quote %%get-global%%))))
|
||
(begin
|
||
(gen arg2 dest #!false)
|
||
(gen arg1 dest1 #!false) ; lex var or constant
|
||
(cons dest1
|
||
(cons dest
|
||
(gen-prim-args (cddr args)(+ dest 2)))))
|
||
(begin
|
||
(gen arg1 dest #!false)
|
||
(cons dest (gen-prim-args (cdr args) dest1)))))))))
|
||
|
||
(gen-global-ref
|
||
(lambda (x dest tr? kind)
|
||
(emit-load dest (list kind (cadr (cadr x))))
|
||
(continue dest tr?)))
|
||
|
||
(gen-global-set
|
||
(lambda (x dest tr? kind)
|
||
(let ((symbol (cadr (cadr x)))
|
||
(value (caddr x)))
|
||
(gen value dest #!false)
|
||
(restore-regs dest)
|
||
(emit 'STORE (list kind symbol) dest)
|
||
(continue dest tr?))))
|
||
|
||
(gen-global-def
|
||
(lambda (x dest tr?)
|
||
(let ((symbol (cadr (cadr x)))
|
||
(value (caddr x)))
|
||
(gen value dest #!false)
|
||
(restore-regs dest)
|
||
(emit 'STORE (list 'GLOBAL-DEF symbol) dest)
|
||
(emit-load dest (cadr x))
|
||
(continue dest tr?))))
|
||
|
||
(gen-fluid-ref
|
||
(lambda (x dest tr?)
|
||
(emit-load dest (list 'FLUID (cadr (cadr x))))
|
||
(continue dest tr?)))
|
||
|
||
(gen-fluid-set
|
||
(lambda (x dest tr?)
|
||
(let ((symbol (cadr (cadr x)))
|
||
(value (caddr x)))
|
||
(gen value dest #!false)
|
||
(restore-regs dest)
|
||
(emit 'STORE (list 'FLUID symbol) dest)
|
||
(continue dest tr?))))
|
||
|
||
(gen-fluid-bind
|
||
(lambda (x dest tr?)
|
||
(let ((symbol (cadr (cadr x)))
|
||
(value (caddr x)))
|
||
(gen value dest #!false)
|
||
(restore-regs dest)
|
||
(emit 'BIND-FLUID symbol dest)
|
||
(continue dest tr?))))
|
||
|
||
(gen-fluid-unbind
|
||
(lambda (x dest tr?)
|
||
(let ((symlist (cadr (cadr x))))
|
||
(emit 'UNBIND-FLUIDS symlist)
|
||
(continue dest tr?))))
|
||
|
||
(continue
|
||
(lambda (dest tr?)
|
||
(when tr? ; tail recursive
|
||
(restore-regs dest)
|
||
(if (not (= dest 1))
|
||
(emit-copy 1 dest))
|
||
(emit 'CALL 'EXIT 1))))
|
||
|
||
(emit
|
||
(lambda instr
|
||
(set! code (cons instr code))))
|
||
|
||
(emit*
|
||
(lambda (instr)
|
||
(set! code (cons instr code))))
|
||
|
||
(emit-label
|
||
(lambda (tag)
|
||
(set! code (cons tag code))))
|
||
|
||
(emit-load
|
||
(lambda args
|
||
(set! code (cons (cons 'LOAD args) code))))
|
||
|
||
(emit-copy
|
||
(lambda (dest src)
|
||
(if (not (= dest src))
|
||
(emit 'LOAD dest src))))
|
||
(emit-live
|
||
(lambda (reg)
|
||
(emit 'LIVE
|
||
(if (zero? reg)
|
||
'()
|
||
(cons 1 reg)))))
|
||
|
||
(emit-jump
|
||
(lambda (label)
|
||
(set! code (cons (cons 'JUMP (cons label '(ALWAYS)))
|
||
code))))
|
||
|
||
(emit-push
|
||
(lambda (reg)
|
||
(letrec
|
||
((pushback
|
||
(lambda (reg prev curr)
|
||
(cond ((or (null? curr) ; start
|
||
(atom? (car curr)) ; label
|
||
(memq (caar curr)
|
||
'(POP PUSH DROP JUMP CALL))
|
||
(and (not (atom? (cdar curr)))
|
||
(equal? reg (cadar curr))
|
||
(or (not (eq? (caar curr) 'LOAD))
|
||
(not (number? (caddr (car curr)))))))
|
||
(let ((tail (cons `(PUSH () ,reg) curr)))
|
||
(if (null? prev)
|
||
(set! code tail)
|
||
(set-cdr! prev tail))))
|
||
((and (eq? (caar curr) 'LOAD)
|
||
(= reg (cadar curr))
|
||
(number? (caddr (car curr))))
|
||
(pushback (caddr (car curr)) curr (cdr curr)))
|
||
(t (pushback reg curr (cdr curr)))))))
|
||
(begin
|
||
(pushback reg '() code)
|
||
(set! tos (add1 tos))
|
||
(if (not (= tos (+ reg reg-base)))
|
||
(error " *** EMIT-PUSH error: " reg reg-base tos))))))
|
||
|
||
(emit-pop
|
||
(lambda (reg)
|
||
(if (not (= tos (+ reg reg-base)))
|
||
(error " *** EMIT-POP error: " reg reg-base tos))
|
||
(emit 'POP reg)
|
||
(set! tos (sub1 tos))))
|
||
|
||
(save-regs
|
||
(lambda (reg)
|
||
(let ((reg-to-push (add1 (- tos reg-base))))
|
||
(when ( < reg-to-push reg)
|
||
(emit-push reg-to-push)
|
||
(save-regs reg)))))
|
||
|
||
(restore-regs
|
||
(lambda (reg)
|
||
(let ((reg-to-pop (- tos reg-base)))
|
||
(when ( >= reg-to-pop reg)
|
||
(emit-pop reg-to-pop)
|
||
(restore-regs reg)))))
|
||
|
||
(restore-tos
|
||
(lambda (tos0 tr?)
|
||
(cond (tr? (set! tos tos0))
|
||
(( > tos tos0) (emit-pop (- tos reg-base))
|
||
(restore-tos tos0 tr?))
|
||
(( < tos tos0) (emit-push (add1 (- tos reg-base)))
|
||
(restore-tos tos0 tr?)))))
|
||
|
||
(drop-all
|
||
(lambda ()
|
||
(let ((count (add1 tos)))
|
||
(when ( > count 0)
|
||
(emit 'DROP (list count))
|
||
(set! tos -1)))))
|
||
|
||
(drop ; drop down to and including REG
|
||
(lambda (reg)
|
||
(let* ((newtos (sub1 (+ reg reg-base)))
|
||
(count (- tos newtos)))
|
||
(when ( > count 0)
|
||
(emit 'DROP (list count))
|
||
(set! tos newtos)))))
|
||
|
||
(drop-env
|
||
(lambda (count)
|
||
(when (> count 0)
|
||
(emit 'DROP-ENV (list count)))))
|
||
|
||
(move-regs
|
||
(lambda (from to count)
|
||
(if ( > from to)
|
||
(when ( > count 0)
|
||
(emit-copy to from)
|
||
(move-regs (add1 from)(add1 to)(sub1 count))))))
|
||
|
||
;--------------!
|
||
) ;; body of gen-code
|
||
(let ((save-henv henv)
|
||
(save-senv senv)
|
||
(save-cenv cenv))
|
||
(set! henv (cons '() henv)) ; add a rib
|
||
(let ((newdest (if (eq? entry-name '==main==)
|
||
1
|
||
(extend-bvl bvl 1))))
|
||
(gen body newdest #!true)
|
||
(set! compiled-lambda-list
|
||
(cons (cons entry-name
|
||
(cons last-label (reverse! code)))
|
||
compiled-lambda-list))
|
||
(set! henv save-henv)
|
||
(set! senv save-senv)
|
||
(set! cenv save-cenv)
|
||
)))))
|
||
|
||
(flatten
|
||
(lambda (cl)
|
||
(if (null? cl)
|
||
cl
|
||
(let* ((first (car cl))
|
||
(label (car first))
|
||
(last-label (cadr first))
|
||
(oplist (cddr first))
|
||
(rest (flat** last-label (cdr cl) '())))
|
||
(cons label
|
||
(append! oplist
|
||
(flatten rest)))))))
|
||
|
||
|
||
(flat**
|
||
(lambda (label a b)
|
||
(cond ((null? label) a)
|
||
((null? a) b)
|
||
((eq? label (caar a)) (append! a b))
|
||
(t (flat** label (cdr a) (cons (car a) b))))))
|
||
|
||
;------!
|
||
)
|
||
(begin ;; body of pcs-gencode
|
||
(gen-code '==main== exp '() 1 '() '() '())
|
||
(flatten compiled-lambda-list)
|
||
))))
|
||
|