home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
MacFormat 1994 November
/
macformat-018.iso
/
Utility Spectacular
/
Developer
/
macgambit-20-compiler-src-p2
/
Interp⁄Comp (.scm)
/
front.scm
< prev
next >
Encoding:
Amiga
Atari
Commodore
DOS
FM Towns/JPY
Macintosh
Macintosh JP
NeXTSTEP
RISC OS/Acorn
Shift JIS
UTF-8
Wrap
Text File
|
1994-07-26
|
73.9 KB
|
2,172 lines
|
[
TEXT/gamI
]
;==============================================================================
; file: "front.scm"
;------------------------------------------------------------------------------
;
; Front-end of GAMBIT compiler
;
;------------------------------------------------------------------------------
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
; The file compiler:
; -----------------
; sample use:
;
; (cf "tak" 'M68000) -- compile 'tak.scm' for M68000 target
; (cf "tak" 'M68000 'VERBOSE) -- produce compiler trace
; (cf "tak" 'M68000 'REPORT) -- show usage of global variables
; (cf "tak" 'M68000 'PVM) -- write PVM code on 'tak.pvm'
; (cf "tak" 'M68000 'DEBUG) -- generate code with debugging info
; (cf "tak" 'M68000 'EXPANSION) -- show code after source-to-source transform
; (cf "tak" 'M68000 'ASM 'STATS) -- various back-end options
(define (cf source target-name . opts)
(let ((module-name (file-name (file-root source)))
(info-port (if (memq 'VERBOSE opts) (current-output-port) #f))
(program
(append (list BEGIN-sym)
program-prefix
(list (list **INCLUDE-sym source))
program-suffix)))
(let ((result (compile-program program
target-name
opts
module-name
(file-root source)
info-port)))
(if (and info-port (not (eq? info-port (current-output-port))))
(close-output-port info-port))
result)))
(define program-prefix #f)
(set! program-prefix '())
(define program-suffix #f)
(set! program-suffix '())
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
; The expression compiler:
; -----------------------
; sample use:
;
; (ce '(+ 2 3) 'M68000) -- compile the expression (+ 2 3)
(define (ce expr target-name . opts)
(let ((info-port (if (memq 'VERBOSE opts) (current-output-port) #f)))
(let ((result (compile-program expr
target-name
opts
"#"
"#"
info-port)))
(if (and info-port (not (eq? info-port (current-output-port))))
(close-output-port info-port))
result)))
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
; The program compiler:
; --------------------
(define (compile-program program target-name opts module-name dest info-port)
(define (compiler-body)
(scheme-global-var-set!
(scheme-global-var (string->canonical-symbol "##COMPILATION-OPTIONS"))
opts)
(ptree.begin! info-port)
(virtual.begin!)
(select-target! target-name info-port)
(parse-program
(list (expression->source program #f))
(make-global-environment)
(lambda (lst env)
(let ((parsed-program
(map (lambda (x) (normalize-parse-tree (car x) (cdr x))) lst)))
(if (memq 'EXPANSION opts)
(let ((port (current-output-port)))
(display "Expansion:" port)
(newline port)
(let loop ((l parsed-program))
(if (pair? l)
(let ((ptree (car l)))
(pp-expression (parse-tree->expression ptree) port)
(loop (cdr l)))))
(newline port)))
(let ((module-init-proc
(compile-parsed-program module-name parsed-program env info-port)))
(if (memq 'REPORT opts)
(generate-report env))
(if (memq 'PVM opts)
(let ((pvm-port (open-output-file (string-append dest ".pvm"))))
(virtual.dump module-init-proc pvm-port)
(close-output-port pvm-port)))
(target.dump module-init-proc dest opts)))))
(unselect-target!)
(virtual.end!)
(ptree.end!)
#t)
(let ((successful (with-exception-handling compiler-body)))
(if info-port
(if successful
(begin
(display "Compilation finished." info-port)
(newline info-port))
(begin
(display "Compilation terminated abnormally." info-port)
(newline info-port))))
successful))
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
; Report generation:
(define (generate-report env)
(let ((vars (sort-list (env-global-variables env)
(lambda (x y)
(string<? (symbol->string (var-name x))
(symbol->string (var-name y))))))
(decl (env-declarations env)))
(define (report title pred? vars wrote-something?)
(if (pair? vars)
(let ((var (car vars)))
(if (pred? var)
(begin
(if (not wrote-something?)
(begin
(display " ")
(display title)
(newline)))
(let loop1 ((l (var-refs var)) (r? #f) (c? #f))
(if (pair? l)
(let* ((x (car l))
(y (node-parent x)))
(if (and y (app? y) (eq? x (app-oper y)))
(loop1 (cdr l) r? #t)
(loop1 (cdr l) #t c?)))
(let loop2 ((l (var-sets var)) (d? #f) (a? #f))
(if (pair? l)
(if (set? (car l))
(loop2 (cdr l) d? #t)
(loop2 (cdr l) #t a?))
(begin
(display " [")
(if d? (display "D") (display " "))
(if a? (display "A") (display " "))
(if r? (display "R") (display " "))
(if c? (display "C") (display " "))
(display "] ")
(display (var-name var)) (newline))))))
(report title pred? (cdr vars) #t))
(cons (car vars) (report title pred? (cdr vars) wrote-something?))))
(begin
(if wrote-something? (newline))
'())))
(display "Global variable usage:") (newline)
(newline)
(report "OTHERS"
(lambda (x) #t)
(report "EXTENDED"
(lambda (x) (target.prim-info (var-name x)))
(report "STANDARD"
(lambda (x) (standard-procedure (var-name x) decl))
vars
#f)
#f)
#f)))
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
(define (compile-parsed-program module-name program env info-port)
(if info-port
(display "Compiling:" info-port))
(set! trace-indentation 0)
(set! *bbs* (make-bbs))
(set! *global-env* env)
(set! proc-tree '())
(set! proc-queue '())
(set! constant-vars '())
(set! known-procs '())
(restore-context
(make-context 0 '() (list ret-var) '() (entry-interrupt) #f))
(let* ((entry-lbl (bbs-new-lbl! *bbs*))
(body-lbl (bbs-new-lbl! *bbs*))
(frame (current-frame ret-var-set)))
(bbs-entry-lbl-num-set! *bbs* entry-lbl)
(set! entry-bb
(make-bb (make-LABEL-PROC entry-lbl 0 0 #f #f frame #f)
*bbs*))
(bb-put-branch! entry-bb
(make-JUMP (make-lbl body-lbl) #f #f frame #f))
(set! *bb*
(make-bb (make-LABEL-SIMP body-lbl frame #f)
*bbs*))
(let loop1 ((l program))
(if (not (null? l))
(let ((node (car l)))
(if (def? node)
(let* ((var (def-var node))
(val (global-val var)))
(if (and val (prc? val))
(add-constant-var var
(make-obj
(make-proc-obj
(symbol->string (var-name var)) ; name
#t ; primitive?
#f ; code
(call-pattern val) ; call-pat
#t ; side-effects?
'() ; strict-pat
'(#f))))))) ; type
(loop1 (cdr l)))))
(let loop2 ((l program))
(if (null? l)
(let ((ret-opnd (var->opnd ret-var)))
(seal-bb #t 'RETURN)
(dealloc-slots nb-slots)
(bb-put-branch! *bb*
(make-JUMP ret-opnd #f #f (current-frame (set-empty)) #f)))
(let ((node (car l)))
(if (def? node)
(begin
(gen-define (def-var node) (def-val node) info-port)
(loop2 (cdr l)))
(if (null? (cdr l))
(gen-node node ret-var-set 'tail)
(begin
(gen-node node ret-var-set 'need)
(loop2 (cdr l))))))))
(let loop ()
(if (pair? proc-queue)
(let ((x (car proc-queue)))
(set! proc-queue (cdr proc-queue))
(gen-proc (car x) (cadr x) (caddr x) info-port)
(trace-unindent info-port)
(loop))))
(if info-port
(begin
(newline info-port)
(newline info-port)))
(bbs-purify! *bbs*)
(let ((proc
(make-proc-obj
(string-append "###" module-name) ; name
#t ; primitive?
*bbs* ; code
'(0) ; call-pat
#t ; side-effects?
'() ; strict-pat
'(#f)))) ; type
(set! *bb* '())
(set! *bbs* '())
(set! *global-env* '())
(set! proc-tree '())
(set! proc-queue '())
(set! constant-vars '())
(set! known-procs '())
(clear-context)
proc)))
(define *bb* '())
(define *bbs* '())
(define *global-env* '())
(define proc-tree '())
(define proc-queue '())
(define constant-vars '())
(define known-procs '())
(define trace-indentation '())
(define (trace-indent info-port)
(set! trace-indentation (+ trace-indentation 1))
(if info-port
(begin
(newline info-port)
(let loop ((i trace-indentation))
(if (> i 0)
(begin (display " " info-port) (loop (- i 1))))))))
(define (trace-unindent info-port)
(set! trace-indentation (- trace-indentation 1)))
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
(define (gen-define var node info-port)
(if (prc? node)
(let* ((p-bbs *bbs*)
(p-bb *bb*)
(p-proc-tree proc-tree)
(p-proc-queue proc-queue)
(p-known-procs known-procs)
(p-context (current-context))
(bbs (make-bbs))
(lbl1 (bbs-new-lbl! bbs)) ; arg check entry point
(lbl2 (bbs-new-lbl! bbs)) ; no arg check entry point
(context (entry-context node '()))
(frame (context->frame
context
(set-union (free-variables (prc-body node))
ret-var-set)))
(bb1 (make-bb
(make-LABEL-PROC
lbl1
(length (prc-parms node))
(prc-min node)
(prc-rest node)
#f
frame
(source-comment node))
bbs))
(bb2 (make-bb
(make-LABEL-SIMP
lbl2
frame
(source-comment node))
bbs)))
(define (do-body)
(gen-proc node bb2 context info-port)
(let loop ()
(if (pair? proc-queue)
(let ((x (car proc-queue)))
(set! proc-queue (cdr proc-queue))
(gen-proc (car x) (cadr x) (caddr x) info-port)
(trace-unindent info-port)
(loop))))
(trace-unindent info-port)
(bbs-purify! *bbs*))
(context-entry-bb-set! context bb1)
(bbs-entry-lbl-num-set! bbs lbl1)
(bb-put-branch! bb1
(make-JUMP (make-lbl lbl2) #f #f frame (source-comment node)))
(set! *bbs* bbs)
(set! proc-tree '())
(set! proc-queue '())
(set! known-procs '())
(if (constant-var? var)
(let-constant-var var (make-lbl lbl1)
(lambda ()
(add-known-proc lbl1 node)
(do-body)))
(do-body))
(set! *bbs* p-bbs)
(set! *bb* p-bb)
(set! proc-tree p-proc-tree)
(set! proc-queue p-proc-queue)
(set! known-procs p-known-procs)
(restore-context p-context)
(let* ((x (assq var constant-vars))
(proc (if x
(let ((p (cdr x)))
(proc-obj-code-set! (obj-val p) bbs)
p)
(make-obj
(make-proc-obj
(symbol->string (var-name var)) ; name
#f ; primitive?
bbs ; code
(call-pattern node) ; call-pat
#t ; side-effects?
'() ; strict-pat
'(#f)))))) ; type
(put-copy proc
(make-glo (var-name var))
#f
ret-var-set)))
(put-copy (gen-node node ret-var-set 'need)
(make-glo (var-name var))
#f
ret-var-set)))
(define (call-pattern node)
(make-pattern (prc-min node) (length (prc-parms node)) (prc-rest node)))
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
; Runtime context manipulation (i.e. where the variables are, what registers
; are in use, etc.)
; runtime context description: nb-slots = number of slots presently allocated
; for the current frame on the stack, slots = list of variables associated with
; each slot (topmost slot first), regs = list of variables contained in each
; register, closed = list of variables which are closed with respect to the
; current procedure, interrupt = what is the maximum number of PVM instructions
; that can be executed before doing an interrupt check and have interrupts been
; checked since entry to this procedure, entry-bb = the entry basic block for
; the procedure containing this context (must have a label of type PROC).
(define (make-context nb-slots slots regs closed interrupt entry-bb)
(vector nb-slots slots regs closed interrupt entry-bb))
(define (context-nb-slots x) (vector-ref x 0))
(define (context-slots x) (vector-ref x 1))
(define (context-regs x) (vector-ref x 2))
(define (context-closed x) (vector-ref x 3))
(define (context-interrupt x) (vector-ref x 4))
(define (context-entry-bb x) (vector-ref x 5))
(define (context-entry-bb-set! x y) (vector-set! x 5 y))
(define nb-slots '())
(define slots '())
(define regs '())
(define closed '())
(define interrupt '())
(define entry-bb '())
(define (restore-context context)
(set! nb-slots (context-nb-slots context))
(set! slots (context-slots context))
(set! regs (context-regs context))
(set! closed (context-closed context))
(set! interrupt (context-interrupt context))
(set! entry-bb (context-entry-bb context)))
(define (clear-context)
(restore-context (make-context '() '() '() '() '() '())))
(define (current-context)
(make-context nb-slots slots regs closed interrupt entry-bb))
(define (current-frame live)
(make-frame nb-slots slots regs closed live))
(define (context->frame context live)
(make-frame (context-nb-slots context)
(context-slots context)
(context-regs context)
(context-closed context)
live))
(define (make-interrupt checked? delta)
(cons checked? delta))
(define (interrupt-checked? x) (car x))
(define (interrupt-delta x) (cdr x))
(define (entry-interrupt)
(make-interrupt #f (- interrupt-period interrupt-head)))
(define (return-interrupt interrupt)
(let ((delta (interrupt-delta interrupt)))
(make-interrupt (interrupt-checked? interrupt)
(+ interrupt-head (max delta interrupt-tail)))))
(define (interrupt-merge interrupt other-interrupt)
(make-interrupt
(or (interrupt-checked? interrupt)
(interrupt-checked? other-interrupt))
(max (interrupt-delta interrupt)
(interrupt-delta other-interrupt))))
(define interrupt-period #f) ; Lmax
(set! interrupt-period 90)
(define interrupt-head #f) ; E
(set! interrupt-head 15)
(define interrupt-tail #f) ; R
(set! interrupt-tail 15)
; (entry-context proc closed) returns the context in existence upon entry to
; the procedure `proc'
(define (entry-context proc closed)
(define (empty-vars-list n)
(if (> n 0)
(cons empty-var (empty-vars-list (- n 1)))
'()))
(let* ((parms (prc-parms proc))
(pc (target.label-info (prc-min proc) (length parms) (prc-rest proc) (not (null? closed))))
(fs (pcontext-fs pc))
(slots-list (empty-vars-list fs))
(regs-list (empty-vars-list target.nb-regs)))
(define (assign-var-to-loc var loc)
(let ((x (cond ((reg? loc)
(let ((i (reg-num loc)))
(if (<= i target.nb-regs)
(nth-after regs-list i)
(compiler-internal-error
"entry-context, reg out of bound in back-end's pcontext"))))
((stk? loc)
(let ((i (stk-num loc)))
(if (<= i fs)
(nth-after slots-list (- fs i))
(compiler-internal-error
"entry-context, stk out of bound in back-end's pcontext"))))
(else
(compiler-internal-error
"entry-context, loc other than reg or stk in back-end's pcontext")))))
(if (eq? (car x) empty-var)
(set-car! x var)
(compiler-internal-error
"entry-context, duplicate location in back-end's pcontext"))))
(let loop ((l (pcontext-map pc)))
(if (not (null? l))
(let* ((couple (car l))
(name (car couple))
(loc (cdr couple)))
(cond ((eq? name 'return)
(assign-var-to-loc ret-var loc))
((eq? name 'closure-env)
(assign-var-to-loc closure-env-var loc))
(else
(assign-var-to-loc (list-ref parms (- name 1)) loc)))
(loop (cdr l)))))
(make-context fs slots-list regs-list closed (entry-interrupt) #f)))
(define (get-var opnd)
(cond ((glo? opnd)
(env-lookup-global-var *global-env* (glo-name opnd)))
((reg? opnd)
(list-ref regs (reg-num opnd)))
((stk? opnd)
(list-ref slots (- nb-slots (stk-num opnd))))
(else
(compiler-internal-error
"get-var, location must be global, register or stack slot"))))
(define (put-var opnd new)
(define (put-v opnd new)
(cond ((reg? opnd)
(set! regs (replace-nth regs (reg-num opnd) new)))
((stk? opnd)
(set! slots (replace-nth slots (- nb-slots (stk-num opnd)) new)))
(else
(compiler-internal-error
"put-var, location must be register or stack slot, for var:"
(var-name new)))))
(if (eq? new ret-var) ; only keep one copy of return address
(let ((x (var->opnd ret-var)))
(and x (put-v x empty-var))))
(put-v opnd new))
(define (flush-regs)
(set! regs '()))
(define (push-slot)
(set! nb-slots (+ nb-slots 1))
(set! slots (cons empty-var slots)))
(define (dealloc-slots n)
(set! nb-slots (- nb-slots n))
(set! slots (nth-after slots n)))
(define (pop-slot)
(dealloc-slots 1))
(define (replace-nth l i v)
(if (null? l)
(if (= i 0)
(list v)
(cons empty-var (replace-nth l (- i 1) v)))
(if (= i 0)
(cons v (cdr l))
(cons (car l) (replace-nth (cdr l) (- i 1) v)))))
(define (live-vars live)
(if (not (set-empty? (set-intersection live (list->set closed))))
(set-adjoin live closure-env-var)
live))
(define (dead-slots live)
(let ((live-v (live-vars live)))
(define (loop s l i)
(cond ((null? l) (list->set (reverse s)))
((set-member? (car l) live-v)
(loop s (cdr l) (- i 1)))
(else
(loop (cons i s) (cdr l) (- i 1)))))
(loop '() slots nb-slots)))
(define (live-slots live)
(let ((live-v (live-vars live)))
(define (loop s l i)
(cond ((null? l) (list->set (reverse s)))
((set-member? (car l) live-v)
(loop (cons i s) (cdr l) (- i 1)))
(else
(loop s (cdr l) (- i 1)))))
(loop '() slots nb-slots)))
(define (dead-regs live)
(let ((live-v (live-vars live)))
(define (loop s l i)
(cond ((>= i target.nb-regs) (list->set (reverse s)))
((null? l)
(loop (cons i s) l (+ i 1)))
((and (set-member? (car l) live-v)
(not (memq (car l) slots)))
(loop s (cdr l) (+ i 1)))
(else
(loop (cons i s) (cdr l) (+ i 1)))))
(loop '() regs 0)))
(define (live-regs live)
(let ((live-v (live-vars live)))
(define (loop s l i)
(cond ((null? l) (list->set (reverse s)))
((and (set-member? (car l) live-v)
(not (memq (car l) slots)))
(loop (cons i s) (cdr l) (+ i 1)))
(else
(loop s (cdr l) (+ i 1)))))
(loop '() regs 0)))
(define (lowest-dead-slot live)
(make-stk (or (lowest (dead-slots live)) (+ nb-slots 1))))
(define (highest-live-slot live)
(make-stk (or (highest (live-slots live)) 0)))
(define (lowest-dead-reg live)
(let ((x (lowest (set-remove (dead-regs live) 0))))
(if x (make-reg x) #f)))
(define (highest-dead-reg live)
(let ((x (highest (dead-regs live))))
(if x (make-reg x) #f)))
(define (highest set) ; return highest number in the set
(if (set-empty? set) #f (apply max (set->list set))))
(define (lowest set) ; return lowest number in the set
(if (set-empty? set) #f (apply min (set->list set))))
(define (above set n) ; return numbers above n in the set
(set-keep (lambda (x) (> x n)) set))
(define (below set n) ; return numbers below n in the set
(set-keep (lambda (x) (< x n)) set))
(define (var->opnd var)
(let ((x (assq var constant-vars)))
(if x
(cdr x)
(if (global? var)
(make-glo (var-name var))
(let ((n (pos-in-list var regs)))
(if n
(make-reg n)
(let ((n (pos-in-list var slots)))
(if n
(make-stk (- nb-slots n))
(let ((n (pos-in-list var closed)))
(if n
(make-clo (var->opnd closure-env-var) (+ n 1))
(compiler-internal-error
"var->opnd, variable is not accessible:" (var-name var))))))))))))
(define (source-comment node)
(let ((x (make-comment)))
(comment-put! x 'SOURCE (node-source node))
x))
;------------------------------------------------------------------------------
(define (add-constant-var var opnd)
(set! constant-vars (cons (cons var opnd) constant-vars)))
(define (let-constant-var var opnd thunk)
(let* ((x (assq var constant-vars))
(temp (cdr x)))
(set-cdr! x opnd)
(thunk)
(set-cdr! x temp)))
(define (constant-var? var)
(assq var constant-vars))
(define (not-constant-var? var)
(not (constant-var? var)))
(define (add-known-proc label proc)
(set! known-procs (cons (cons label proc) known-procs)))
;------------------------------------------------------------------------------
;
; generate code for a procedure
(define (gen-proc proc bb context info-port)
(trace-indent info-port)
(if info-port
(if (prc-name proc)
(display (prc-name proc) info-port)
(display "\"unknown\"" info-port)))
(let ((lbl (bb-lbl-num bb))
(live (set-union (free-variables (prc-body proc)) ret-var-set)))
(set! *bb* bb)
(restore-context context)
(gen-node (prc-body proc) ret-var-set 'tail)))
(define (schedule-gen-proc proc closed-list)
(let* ((lbl1 (bbs-new-lbl! *bbs*)) ; arg check entry point
(lbl2 (bbs-new-lbl! *bbs*)) ; no arg check entry point
(context (entry-context proc closed-list))
(frame (context->frame
context
(set-union (free-variables (prc-body proc))
ret-var-set)))
(bb1 (make-bb
(make-LABEL-PROC
lbl1
(length (prc-parms proc))
(prc-min proc)
(prc-rest proc)
(not (null? closed-list))
frame
(source-comment proc))
*bbs*))
(bb2 (make-bb
(make-LABEL-SIMP
lbl2
frame
(source-comment proc))
*bbs*)))
(context-entry-bb-set! context bb1)
(bb-put-branch! bb1
(make-JUMP (make-lbl lbl2) #f #f frame (source-comment proc)))
(set! proc-tree (cons (cons lbl1 (bb-lbl-num entry-bb)) proc-tree))
(set! proc-queue (cons (list proc bb2 context) proc-queue))
(make-lbl lbl1)))
;------------------------------------------------------------------------------
;
; generate code for an expression
(define (gen-node node live why)
(cond ((cst? node)
(gen-return
(make-obj (cst-val node))
why
node))
((ref? node)
(let* ((var (ref-var node))
(name (var-name var)))
(gen-return
(cond ((eq? why 'side)
(make-obj undef-object))
((global? var)
(let ((prim (target.prim-info* name (node-decl node))))
(if prim (make-obj prim) (var->opnd var))))
(else
(var->opnd var)))
why
node)))
((set? node)
(let* ((src (gen-node (set-val node)
(set-adjoin live (set-var node))
'keep))
(dst (var->opnd (set-var node))))
(put-copy src dst #f live)
(gen-return (make-obj undef-object) why node)))
((def? node)
(compiler-internal-error
"gen-node, 'def' node not at root of parse tree"))
((tst? node)
(gen-tst node live why))
((conj? node)
(gen-conj/disj node live why))
((disj? node)
(gen-conj/disj node live why))
((prc? node)
(let* ((closed (not-constant-closed-vars node))
(closed-list (set->list closed))
(proc-lbl (schedule-gen-proc node closed-list)))
(let ((opnd
(if (null? closed-list)
(begin
(add-known-proc (lbl-num proc-lbl) node)
proc-lbl)
(begin
(dealloc-slots (- nb-slots
(stk-num (highest-live-slot
(set-union closed live)))))
(push-slot)
(let ((slot (make-stk nb-slots))
(var (make-temp-var 'closure)))
(put-var slot var)
(bb-put-non-branch! *bb*
(make-MAKE_CLOSURES
(list (make-closure-parms
slot
(lbl-num proc-lbl)
(map var->opnd closed-list)))
(current-frame (set-adjoin live var))
(source-comment node)))
slot)))))
(gen-return opnd why node))))
((app? node)
(gen-call node live why))
((fut? node)
(gen-fut node live why))
(else
(compiler-internal-error
"gen-node, unknown parse tree node type:" node))))
(define (gen-return opnd why node)
(cond ((eq? why 'tail)
(let ((var (make-temp-var 'result)))
(put-copy opnd target.proc-result var ret-var-set)
(let ((ret-opnd (var->opnd ret-var)))
(seal-bb (intr-checks? (node-decl node)) 'RETURN)
(dealloc-slots nb-slots)
(bb-put-branch! *bb*
(make-JUMP ret-opnd
#f
#f
(current-frame (set-singleton var))
(source-comment node))))))
(else
opnd)))
(define (not-constant-closed-vars val)
(set-keep not-constant-var? (free-variables val)))
;------------------------------------------------------------------------------
;
; generate code for a conditional
(define (predicate node live cont)
(define (cont* true-lbl false-lbl)
(cont false-lbl true-lbl))
(define (generic-true-test)
(predicate-test node live **NOT-proc-obj '0 (list node) cont*))
(cond ((or (conj? node) (disj? node))
(predicate-conj/disj node live cont))
((app? node)
(let ((proc (node->proc (app-oper node))))
(if proc
(let ((spec (specialize-for-call proc (node-decl node))))
(if (and (proc-obj-test spec)
(nb-args-conforms? (length (app-args node))
(proc-obj-call-pat spec)))
(if (eq? spec **NOT-proc-obj)
(predicate (car (app-args node)) live cont*)
(predicate-test node live spec
(proc-obj-strict-pat proc)
(app-args node)
cont))
(generic-true-test)))
(generic-true-test))))
(else
(generic-true-test))))
(define (predicate-conj/disj node live cont)
(let* ((pre (if (conj? node) (conj-pre node) (disj-pre node)))
(alt (if (conj? node) (conj-alt node) (disj-alt node)))
(alt-live (set-union live (free-variables alt))))
(predicate pre alt-live
(lambda (true-lbl false-lbl)
(let ((pre-context (current-context)))
(set! *bb* (make-bb
(make-LABEL-SIMP
(if (conj? node) true-lbl false-lbl)
(current-frame alt-live)
(source-comment pre))
*bbs*))
(predicate alt live
(lambda (true-lbl2 false-lbl2)
(let ((alt-context (current-context)))
(restore-context pre-context)
(set! *bb* (make-bb
(make-LABEL-SIMP
(if (conj? node) false-lbl true-lbl)
(current-frame live)
(source-comment alt))
*bbs*))
(merge-contexts-and-seal-bb
alt-context
live
(intr-checks? (node-decl node))
'INTERNAL)
(bb-put-branch! *bb*
(make-JUMP
(make-lbl (if (conj? node) false-lbl2 true-lbl2))
#f
#f
(current-frame live)
(source-comment node)))
(cont true-lbl2 false-lbl2)))))))))
(define (predicate-test node live test strict-pat args cont)
(let loop ((args* args) (liv live) (vars* '()))
(if (not (null? args*))
(let* ((needed (vals-live-vars liv (cdr args*)))
(var
(save-var (gen-node (car args*) needed 'need)
(make-temp-var 'predicate)
needed)))
(loop (cdr args*) (set-adjoin liv var) (cons var vars*)))
(let* ((true-lbl (bbs-new-lbl! *bbs*))
(false-lbl (bbs-new-lbl! *bbs*)))
(seal-bb (intr-checks? (node-decl node)) 'INTERNAL)
(bb-put-branch! *bb*
(make-COND
test
(flag-pot-fut (map var->opnd (reverse vars*))
(lambda (i) (pattern-member? i strict-pat))
(node-decl node))
true-lbl
false-lbl
#f
(current-frame live)
(source-comment node)))
(cont true-lbl false-lbl)))))
(define (gen-tst node live why)
(let ((pre (tst-pre node))
(con (tst-con node))
(alt (tst-alt node)))
(predicate pre (set-union live (free-variables con) (free-variables alt))
(lambda (true-lbl false-lbl)
(let ((pre-context (current-context))
(true-bb (make-bb
(make-LABEL-SIMP
true-lbl
(current-frame (set-union live (free-variables con)))
(source-comment con))
*bbs*))
(false-bb (make-bb
(make-LABEL-SIMP
false-lbl
(current-frame (set-union live (free-variables alt)))
(source-comment alt))
*bbs*)))
(set! *bb* true-bb)
(let ((con-opnd (gen-node con live why)))
(if (eq? why 'tail)
(begin
(restore-context pre-context)
(set! *bb* false-bb)
(gen-node alt live why))
(let* ((result-var (make-temp-var 'result))
(live-after (set-adjoin live result-var)))
(save-opnd-to-reg con-opnd
target.proc-result
result-var
live)
(let ((con-context (current-context))
(con-bb *bb*))
(restore-context pre-context)
(set! *bb* false-bb)
(save-opnd-to-reg (gen-node alt live why)
target.proc-result
result-var
live)
(let ((next-lbl (bbs-new-lbl! *bbs*))
(alt-bb *bb*))
(if (> (context-nb-slots con-context) nb-slots)
(begin
(seal-bb (intr-checks? (node-decl node)) 'INTERNAL)
(let ((alt-context (current-context)))
(restore-context con-context)
(set! *bb* con-bb)
(merge-contexts-and-seal-bb
alt-context
live-after
(intr-checks? (node-decl node))
'INTERNAL)))
(let ((alt-context (current-context)))
(restore-context con-context)
(set! *bb* con-bb)
(seal-bb (intr-checks? (node-decl node)) 'INTERNAL)
(let ((con-context* (current-context)))
(restore-context alt-context)
(set! *bb* alt-bb)
(merge-contexts-and-seal-bb
con-context*
live-after
(intr-checks? (node-decl node))
'INTERNAL))))
(let ((frame (current-frame live-after)))
(bb-put-branch! con-bb
(make-JUMP
(make-lbl next-lbl)
#f
#f
frame
(source-comment node)))
(bb-put-branch! alt-bb
(make-JUMP
(make-lbl next-lbl)
#f
#f
frame
(source-comment node)))
(set! *bb* (make-bb
(make-LABEL-SIMP
next-lbl
frame
(source-comment node))
*bbs*))
target.proc-result)))))))))))
(define (nb-args-conforms? n call-pat)
(pattern-member? n call-pat))
; 'merge-contexts-and-seal-bb' generates code to transform the current
; context (i.e. reg and stack values and frame size) to 'other-context' only
; considering the variables in 'live'.
(define (merge-contexts-and-seal-bb other-context live checks? where)
(let ((live-v (live-vars live))
(other-nb-slots (context-nb-slots other-context))
(other-regs (context-regs other-context))
(other-slots (context-slots other-context))
(other-interrupt (context-interrupt other-context))
(other-entry-bb (context-entry-bb other-context)))
(let loop1 ((i (- target.nb-regs 1)))
(if (>= i 0)
(let ((other-var (reg->var other-regs i))
(var (reg->var regs i)))
(if (and (not (eq? var other-var)) ; if var not already there and
(set-member? other-var live-v)) ; must keep other-var somewhere
(let ((r (make-reg i)))
(put-var r empty-var)
(if (not (or (not (set-member? var live-v))
(memq var regs)
(memq var slots)))
(let ((top (make-stk (+ nb-slots 1))))
(put-copy r top var live-v)))
(put-copy (var->opnd other-var) r other-var live-v)))
(loop1 (- i 1)))))
(let loop2 ((i 1))
(if (<= i other-nb-slots)
(let ((other-var (stk->var other-slots i))
(var (stk->var slots i)))
(if (and (not (eq? var other-var)) ; if var not already there and
(set-member? other-var live-v)) ; must keep other-var somewhere
(let ((s (make-stk i)))
(if (<= i nb-slots) (put-var s empty-var))
(if (not (or (not (set-member? var live-v))
(memq var regs)
(memq var slots)))
(let ((top (make-stk (+ nb-slots 1))))
(put-copy s top var live-v)))
(put-copy (var->opnd other-var) s other-var live-v))
(if (> i nb-slots)
(let ((top (make-stk (+ nb-slots 1))))
(put-copy (make-obj undef-object) top empty-var live-v))))
(loop2 (+ i 1)))))
(dealloc-slots (- nb-slots other-nb-slots))
(let loop3 ((i (- target.nb-regs 1)))
(if (>= i 0)
(let ((other-var (reg->var other-regs i))
(var (reg->var regs i)))
(if (not (eq? var other-var))
(put-var (make-reg i) empty-var))
(loop3 (- i 1)))))
(let loop4 ((i 1))
(if (<= i other-nb-slots)
(let ((other-var (stk->var other-slots i))
(var (stk->var slots i)))
(if (not (eq? var other-var))
(put-var (make-stk i) empty-var))
(loop4 (+ i 1)))))
(seal-bb checks? where)
(set! interrupt (interrupt-merge interrupt other-interrupt))
(if (not (eq? entry-bb other-entry-bb))
(compiler-internal-error
"merge-contexts-and-seal-bb, entry-bb's do not agree"))))
(define (seal-bb checks? where)
(define (last-pair l)
(if (pair? (cdr l)) (last-pair (cdr l)) l))
(define (intr-check-at split-point)
(let loop ((i 0) (l1 (bb-non-branch-instrs *bb*)) (l2 '()))
(if (< i split-point)
(loop (+ i 1) (cdr l1) (cons (car l1) l2))
(let* ((label-instr (bb-label-instr *bb*))
(non-branch-instrs1 (reverse l2))
(non-branch-instrs2 l1)
(frame (pvm-instr-frame
(car (last-pair (cons label-instr
non-branch-instrs1)))))
(prec-bb (make-bb label-instr *bbs*))
(new-lbl (bbs-new-lbl! *bbs*)))
(bb-non-branch-instrs-set! prec-bb non-branch-instrs1)
(bb-put-branch! prec-bb
(make-JUMP (make-lbl new-lbl) #f #t frame #f))
(bb-label-instr-set! *bb* (make-LABEL-SIMP new-lbl frame #f))
(bb-non-branch-instrs-set! *bb* non-branch-instrs2)
(set! interrupt (make-interrupt #t 0))))))
(define (intr-check-at-end)
(intr-check-at (length (bb-non-branch-instrs *bb*))))
(define (impose-intr-check-constraints)
(let ((n (+ (length (bb-non-branch-instrs *bb*)) 1))
(delta (interrupt-delta interrupt)))
(if (> (+ delta n) interrupt-period)
(begin
(intr-check-at (max (- interrupt-period delta) 0))
(impose-intr-check-constraints)))))
(if checks? (impose-intr-check-constraints))
(let* ((n (+ (length (bb-non-branch-instrs *bb*)) 1))
(delta (+ (interrupt-delta interrupt) n))
(checked? (interrupt-checked? interrupt)))
(if (and checks?
(case where
((CALL)
(> delta (- interrupt-period interrupt-head)))
((TAIL-CALL)
(> delta interrupt-tail))
((RETURN)
(and checked? (> delta (+ interrupt-head interrupt-tail))))
((INTERNAL)
#f)
(else
(compiler-internal-error "seal-bb, unknown 'where':" where))))
(intr-check-at-end)
(set! interrupt (make-interrupt checked? delta)))))
(define (reg->var regs i)
(cond ((null? regs)
'())
((> i 0)
(reg->var (cdr regs) (- i 1)))
(else
(car regs))))
(define (stk->var slots i)
(let ((j (- (length slots) i)))
(if (< j 0)
'()
(list-ref slots j))))
;------------------------------------------------------------------------------
;
; generate code for a conjunction or disjunction
(define (gen-conj/disj node live why)
(let ((pre (if (conj? node) (conj-pre node) (disj-pre node)))
(alt (if (conj? node) (conj-alt node) (disj-alt node))))
(let ((needed (set-union live (free-variables alt)))
(bool? (boolean-value? pre))
(predicate-var (make-temp-var 'predicate)))
(define (general-predicate node live cont)
(let* ((con-lbl (bbs-new-lbl! *bbs*))
(alt-lbl (bbs-new-lbl! *bbs*)))
(save-opnd-to-reg (gen-node pre live 'need)
target.proc-result
predicate-var
live)
(seal-bb (intr-checks? (node-decl node)) 'INTERNAL)
(bb-put-branch! *bb*
(make-COND
**NOT-proc-obj
(flag-pot-fut (list target.proc-result)
(lambda (i) #t)
(node-decl node))
alt-lbl
con-lbl
#f
(current-frame (set-adjoin live predicate-var))
(source-comment node)))
(cont con-lbl alt-lbl)))
(define (alternative con-lbl alt-lbl)
(let* ((pre-context (current-context))
(result-var (make-temp-var 'result))
(con-live (if bool? live (set-adjoin live predicate-var)))
(alt-live (set-union live (free-variables alt)))
(con-bb (make-bb
(make-LABEL-SIMP
con-lbl
(current-frame con-live)
(source-comment node))
*bbs*))
(alt-bb (make-bb
(make-LABEL-SIMP
alt-lbl
(current-frame alt-live)
(source-comment alt))
*bbs*)))
(if bool?
(begin
(set! *bb* con-bb)
(save-opnd-to-reg (make-obj (if (conj? node) false-object #t))
target.proc-result
result-var
live))
(put-var (var->opnd predicate-var) result-var))
(let ((con-context (current-context)))
(set! *bb* alt-bb)
(restore-context pre-context)
(let ((alt-opnd (gen-node alt live why)))
(if (eq? why 'tail)
(begin
(restore-context con-context)
(set! *bb* con-bb)
(let ((ret-opnd (var->opnd ret-var))
(result-set (set-singleton result-var)))
(seal-bb (intr-checks? (node-decl node)) 'RETURN)
(dealloc-slots nb-slots)
(bb-put-branch! *bb*
(make-JUMP ret-opnd
#f
#f
(current-frame result-set)
(source-comment node)))))
(let ((alt-context* (current-context))
(alt-bb* *bb*))
(restore-context con-context)
(set! *bb* con-bb)
(seal-bb (intr-checks? (node-decl node)) 'INTERNAL)
(let ((con-context* (current-context))
(next-lbl (bbs-new-lbl! *bbs*)))
(restore-context alt-context*)
(set! *bb* alt-bb*)
(save-opnd-to-reg alt-opnd
target.proc-result
result-var
live)
(merge-contexts-and-seal-bb
con-context*
(set-adjoin live result-var)
(intr-checks? (node-decl node))
'INTERNAL)
(let ((frame (current-frame (set-adjoin live result-var))))
(bb-put-branch! *bb*
(make-JUMP
(make-lbl next-lbl)
#f
#f
frame
(source-comment node)))
(bb-put-branch! con-bb
(make-JUMP
(make-lbl next-lbl)
#f
#f
frame
(source-comment node)))
(set! *bb* (make-bb
(make-LABEL-SIMP
next-lbl
frame
(source-comment node))
*bbs*))
target.proc-result))))))))
((if bool? predicate general-predicate) pre needed
(lambda (true-lbl false-lbl)
(if (conj? node)
(alternative false-lbl true-lbl)
(alternative true-lbl false-lbl)))))))
;------------------------------------------------------------------------------
;
; generate code for a procedure call
(define (gen-call node live why)
(let* ((oper (app-oper node))
(args (app-args node))
(nb-args (length args)))
(if (and (prc? oper) ; applying a lambda-expr is like a 'let' or 'letrec'
(not (prc-rest oper))
(= (length (prc-parms oper)) nb-args))
(gen-let (prc-parms oper) args (prc-body oper) live why)
(if (inlinable-app? node)
(let ((eval-order (arg-eval-order #f args))
(vars (map (lambda (x) (cons x #f)) args)))
(let loop ((l eval-order) (liv live))
(if (not (null? l))
(let* ((needed (vals-live-vars liv (map car (cdr l))))
(arg (car (car l)))
(pos (cdr (car l)))
(var
(save-var (gen-node arg needed 'need)
(make-temp-var pos)
needed)))
(set-cdr! (assq arg vars) var)
(loop (cdr l) (set-adjoin liv var)))
(let ((loc (if (eq? why 'side)
(make-reg 0)
(or (lowest-dead-reg live) (lowest-dead-slot live)))))
(if (and (stk? loc) (> (stk-num loc) nb-slots)) (push-slot))
(let* ((args (map var->opnd (map cdr vars)))
(var (make-temp-var 'result))
(proc (node->proc oper))
(strict-pat (proc-obj-strict-pat proc)))
(if (not (eq? why 'side)) (put-var loc var))
(bb-put-non-branch! *bb*
(make-APPLY (specialize-for-call proc (node-decl node))
(flag-pot-fut
args
(lambda (i) (pattern-member? i strict-pat))
(node-decl node))
(if (eq? why 'side) #f loc)
(current-frame (if (eq? why 'side) live (set-adjoin live var)))
(source-comment node)))
(gen-return loc why node))))))
(let* ((calling-local-proc?
(and (ref? oper)
(let ((opnd (var->opnd (ref-var oper))))
(and (lbl? opnd)
(let ((x (assq (lbl-num opnd) known-procs)))
(and x
(let ((proc (cdr x)))
(and (not (prc-rest proc))
(= (prc-min proc) nb-args)
(= (length (prc-parms proc)) nb-args)
(lbl-num opnd)))))))))
(jstate
(get-jump-state
args
(if calling-local-proc?
(target.label-info nb-args nb-args #f #f)
(target.jump-info nb-args))))
(in-stk (jump-state-in-stk jstate))
(in-reg (jump-state-in-reg jstate))
(eval-order (arg-eval-order (if calling-local-proc? #f oper) in-reg))
(live-after (if (eq? why 'tail) (set-remove live ret-var) live))
(live-for-regs (args-live-vars live eval-order))
(return-lbl (if (eq? why 'tail) #f (bbs-new-lbl! *bbs*))))
; save regs on stack if they contain values needed after the call
(save-regs (live-regs live-after)
(stk-live-vars live-for-regs in-stk why))
(let ((frame-start (stk-num (highest-live-slot live-after))))
(let loop1 ((l in-stk) (liv live-after) (i (+ frame-start 1)))
(if (not (null? l))
; ==== FIRST: evaluate arguments that go onto stack
(let ((arg (car l))
(slot (make-stk i))
(needed (set-union (stk-live-vars liv (cdr l) why)
live-for-regs)))
(if arg
(let ((var (if (and (eq? arg 'return) (eq? why 'tail))
ret-var
(make-temp-var (- frame-start i)))))
(save-opnd-to-stk (if (eq? arg 'return)
(if (eq? why 'tail)
(var->opnd ret-var)
(make-lbl return-lbl))
(gen-node arg needed 'need))
slot
var
needed)
(loop1 (cdr l) (set-adjoin liv var) (+ i 1)))
(begin
(if (> i nb-slots)
(put-copy (make-obj undef-object) slot empty-var liv))
(loop1 (cdr l) liv (+ i 1)))))
(let loop2 ((l eval-order) (liv liv) (reg-map '()) (oper-var '()))
(if (not (null? l))
; ==== SECOND: evaluate operator and args that go in registers
(let* ((arg (car (car l)))
(pos (cdr (car l)))
(needed (args-live-vars liv (cdr l)))
(var (if (and (eq? arg 'return) (eq? why 'tail))
ret-var
(make-temp-var pos)))
(opnd (if (eq? arg 'return)
(if (eq? why 'tail)
(var->opnd ret-var)
(make-lbl return-lbl))
(gen-node arg needed 'need))))
(if (eq? pos 'operator)
; operator
(if (and (ref? arg)
(not (or (obj? opnd) (lbl? opnd))))
(loop2 (cdr l)
(set-adjoin liv (ref-var arg))
reg-map
(ref-var arg))
(begin
(save-arg opnd var needed)
(loop2 (cdr l)
(set-adjoin liv var)
reg-map
var)))
; return address or argument
(let ((reg (make-reg pos)))
(if (all-args-trivial? (cdr l))
(save-opnd-to-reg opnd reg var needed)
(save-in-slot opnd var needed))
(loop2 (cdr l)
(set-adjoin liv var)
(cons (cons pos var) reg-map)
oper-var))))
(let loop3 ((i (- target.nb-regs 1)))
(if (>= i 0)
; ==== THIRD: reload spilled registers
(let ((couple (assq i reg-map)))
(if couple
(let ((var (cdr couple)))
(if (not (eq? (reg->var regs i) var))
(save-opnd-to-reg (var->opnd var) (make-reg i) var liv))))
(loop3 (- i 1)))
; ==== FOURTH: jump to procedure
(let ((opnd (if calling-local-proc?
(make-lbl (+ calling-local-proc? 1))
(var->opnd oper-var))))
(seal-bb (intr-checks? (node-decl node))
(if return-lbl 'CALL 'TAIL-CALL))
(dealloc-slots (- nb-slots (+ frame-start (length in-stk))))
(bb-put-branch! *bb*
(make-JUMP
(car (flag-pot-fut (list opnd)
(lambda (i) #t)
(node-decl node)))
(if calling-local-proc? #f nb-args)
#f
(current-frame liv)
(source-comment node)))
; ==== FIFTH: put return label if there is one
(let ((result-var (make-temp-var 'result)))
(dealloc-slots (- nb-slots frame-start))
(flush-regs)
(put-var target.proc-result result-var)
(if return-lbl
(begin
(set! interrupt (return-interrupt interrupt))
(set! *bb*
(make-bb
(make-LABEL-RETURN
return-lbl
#f
(current-frame (set-adjoin live result-var))
(source-comment node))
*bbs*))))
target.proc-result))))))))))))))
(define (contained-reg/slot opnd)
(cond ((reg? opnd)
opnd)
((stk? opnd)
opnd)
((clo? opnd)
(contained-reg/slot (clo-base opnd)))
(else
#f)))
(define (opnd-needed opnd needed)
(let ((x (contained-reg/slot opnd)))
(if x
(set-adjoin needed (get-var x))
needed)))
(define (save-opnd opnd live)
(let ((slot (lowest-dead-slot live)))
(put-copy opnd slot (get-var opnd) live)))
(define (save-regs regs live)
(for-each (lambda (i) (save-opnd (make-reg i) live)) (set->list regs)))
(define (save-opnd-to-reg opnd reg var live)
(if (set-member? (reg-num reg) (live-regs live))
(save-opnd reg (opnd-needed opnd live)))
(put-copy opnd reg var live))
(define (save-opnd-to-stk opnd stk var live)
(if (set-member? (stk-num stk) (live-slots live))
(save-opnd stk (opnd-needed opnd live)))
(put-copy opnd stk var live))
(define (all-args-trivial? l)
(if (null? l)
#t
(let ((arg (car (car l))))
(or (eq? arg 'return)
(and (trivial? arg)
(all-args-trivial? (cdr l)))))))
(define (every-trivial? l)
(or (null? l)
(and (trivial? (car l))
(every-trivial? (cdr l)))))
(define (trivial? node)
(or (cst? node)
(ref? node)
(and (set? node) (trivial? (set-val node)))
(and (inlinable-app? node) (every-trivial? (app-args node)))))
(define (inlinable-app? node)
(if (app? node)
(let ((proc (node->proc (app-oper node))))
(and proc
(let ((spec (specialize-for-call proc (node-decl node))))
(and (proc-obj-inlinable spec)
(nb-args-conforms? (length (app-args node))
(proc-obj-call-pat spec))))))
#f))
(define (boolean-value? node)
(or (and (conj? node)
(boolean-value? (conj-pre node))
(boolean-value? (conj-alt node)))
(and (disj? node)
(boolean-value? (disj-pre node))
(boolean-value? (disj-alt node)))
(boolean-app? node)))
(define (boolean-app? node)
(if (app? node)
(let ((proc (node->proc (app-oper node))))
(if proc
(eq? (type-name (proc-obj-type proc)) 'BOOLEAN)
#f))
#f))
(define (node->proc node)
(cond ((cst? node)
(if (proc-obj? (cst-val node))
(cst-val node)
#f))
((ref? node)
(if (global? (ref-var node))
(target.prim-info* (var-name (ref-var node)) (node-decl node))
#f))
(else
#f)))
(define (specialize-for-call proc decl)
((proc-obj-specialize proc) decl))
(define (flag-pot-fut opnds strict? decl)
(define (flag opnds i)
(if (pair? opnds)
(let ((opnd (car opnds)))
(cons (if (and (not (or (lbl? opnd) (obj? opnd))) (strict? i))
(put-pot-fut opnd)
opnd)
(flag (cdr opnds) (+ i 1))))
'()))
(if (autotouch? decl)
(flag opnds 0)
opnds))
(define (get-jump-state args pc)
(define (empty-node-list n)
(if (> n 0)
(cons #f (empty-node-list (- n 1)))
'()))
(let* ((fs (pcontext-fs pc))
(slots-list (empty-node-list fs))
(regs-list (empty-node-list target.nb-regs)))
(define (assign-node-to-loc var loc)
(let ((x (cond ((reg? loc)
(let ((i (reg-num loc)))
(if (<= i target.nb-regs)
(nth-after regs-list i)
(compiler-internal-error
"jump-state, reg out of bound in back-end's pcontext"))))
((stk? loc)
(let ((i (stk-num loc)))
(if (<= i fs)
(nth-after slots-list (- i 1))
(compiler-internal-error
"jump-state, stk out of bound in back-end's pcontext"))))
(else
(compiler-internal-error
"jump-state, loc other than reg or stk in back-end's pcontext")))))
(if (not (car x))
(set-car! x var)
(compiler-internal-error
"jump-state, duplicate location in back-end's pcontext"))))
(let loop ((l (pcontext-map pc)))
(if (not (null? l))
(let* ((couple (car l))
(name (car couple))
(loc (cdr couple)))
(cond ((eq? name 'return)
(assign-node-to-loc 'return loc))
(else
(assign-node-to-loc (list-ref args (- name 1)) loc)))
(loop (cdr l)))))
(vector slots-list regs-list)))
(define (jump-state-in-stk x) (vector-ref x 0))
(define (jump-state-in-reg x) (vector-ref x 1))
(define (arg-eval-order oper nodes)
(define (loop nodes pos part1 part2)
(cond ((null? nodes)
(let ((p1 (reverse part1))
(p2 (free-vars-order part2)))
(cond ((not oper)
(append p1 p2))
((trivial? oper)
(append p1 p2 (list (cons oper 'operator))))
(else
(append (cons (cons oper 'operator) p1) p2)))))
((not (car nodes))
(loop (cdr nodes)
(+ pos 1)
part1
part2))
((or (eq? (car nodes) 'return)
(trivial? (car nodes)))
(loop (cdr nodes)
(+ pos 1)
part1
(cons (cons (car nodes) pos) part2)))
(else
(loop (cdr nodes)
(+ pos 1)
(cons (cons (car nodes) pos) part1)
part2))))
(loop nodes 0 '() '()))
(define (free-vars-order l)
(let ((bins '())
(ordered-args '()))
(define (free-v x)
(if (eq? x 'return)
(set-empty)
(free-variables x)))
(define (add-to-bin! x)
(let ((y (assq x bins)))
(if y
(set-cdr! y (+ (cdr y) 1))
(set! bins (cons (cons x 1) bins)))))
(define (payoff-if-removed node)
(let ((x (free-v node)))
(let loop ((l (set->list x)) (r 0))
(if (null? l)
r
(let ((y (cdr (assq (car l) bins))))
(loop (cdr l) (+ r (quotient 1000 (* y y))))))))) ; heuristic
(define (remove-free-vars! x)
(let loop ((l (set->list x)))
(if (not (null? l))
(let ((y (assq (car l) bins)))
(set-cdr! y (- (cdr y) 1))
(loop (cdr l))))))
(define (find-max-payoff l thunk)
(if (null? l)
(thunk '() -1)
(find-max-payoff (cdr l)
(lambda (best-arg best-payoff)
(let ((payoff (payoff-if-removed (car (car l)))))
(if (>= payoff best-payoff)
(thunk (car l) payoff)
(thunk best-arg best-payoff)))))))
(define (remove x l)
(cond ((null? l) '())
((eq? x (car l)) (cdr l))
(else (cons (car l) (remove x (cdr l))))))
(for-each (lambda (x)
(for-each add-to-bin! (set->list (free-v (car x)))))
l)
(let loop ((args l) (ordered-args '()))
(if (null? args)
(reverse ordered-args)
(find-max-payoff args
(lambda (best-arg best-payoff)
(remove-free-vars! (free-v (car best-arg)))
(loop (remove best-arg args) (cons best-arg ordered-args))))))))
(define (args-live-vars live order)
(cond ((null? order)
live)
((eq? (car (car order)) 'return)
(args-live-vars (set-adjoin live ret-var)
(cdr order)))
(else
(args-live-vars (set-union live (free-variables (car (car order))))
(cdr order)))))
(define (stk-live-vars live slots why)
(cond ((null? slots)
live)
((not (car slots))
(stk-live-vars live
(cdr slots)
why))
((eq? (car slots) 'return)
(stk-live-vars (if (eq? why 'tail) (set-adjoin live ret-var) live)
(cdr slots)
why))
(else
(stk-live-vars (set-union live (free-variables (car slots)))
(cdr slots)
why))))
;------------------------------------------------------------------------------
;
; generate code for a 'let' or 'letrec'
(define (gen-let vars vals node live why)
(let ((var-val-map (pair-up vars vals))
(var-set (list->set vars))
(all-live (set-union live
(free-variables node)
(apply set-union (map free-variables vals)))))
(define (var->val var) (cdr (assq var var-val-map)))
(define (proc-var? var) (prc? (var->val var)))
(define (closed-vars var const-proc-vars)
(set-difference (not-constant-closed-vars (var->val var))
const-proc-vars))
(define (no-closed-vars? var const-proc-vars)
(set-empty? (closed-vars var const-proc-vars)))
(define (closed-vars? var const-proc-vars)
(not (no-closed-vars? var const-proc-vars)))
(define (compute-const-proc-vars proc-vars)
(let loop1 ((const-proc-vars proc-vars))
(let ((new-const-proc-vars
(set-keep (lambda (x) (no-closed-vars? x const-proc-vars))
const-proc-vars)))
(if (not (set-equal? new-const-proc-vars const-proc-vars))
(loop1 new-const-proc-vars)
const-proc-vars))))
(let* ((proc-vars (set-keep proc-var? var-set))
(const-proc-vars (compute-const-proc-vars proc-vars))
(clo-vars (set-keep (lambda (x) (closed-vars? x const-proc-vars))
proc-vars))
(clo-vars-list (set->list clo-vars)))
(for-each
(lambda (proc-var)
(let ((label (schedule-gen-proc (var->val proc-var) '())))
(add-known-proc (lbl-num label) (var->val proc-var))
(add-constant-var proc-var label)))
(set->list const-proc-vars))
(let ((non-clo-vars-list
(set->list
(set-keep (lambda (var)
(and (not (set-member? var const-proc-vars))
(not (set-member? var clo-vars))))
vars)))
(liv (set-union live
(apply
set-union
(map (lambda (x) (closed-vars x const-proc-vars))
clo-vars-list))
(free-variables node))))
(let loop2 ((vars* non-clo-vars-list))
(if (not (null? vars*))
(let* ((var (car vars*))
(val (var->val var))
(needed (vals-live-vars liv
(map var->val (cdr vars*)))))
(if (var-useless? var)
(gen-node val needed 'side)
(save-val (gen-node val needed 'need) var needed))
(loop2 (cdr vars*)))))
(if (pair? clo-vars-list)
(begin
(dealloc-slots
(- nb-slots (stk-num (highest-live-slot liv))))
(let loop3 ((l clo-vars-list))
(if (not (null? l))
(begin
(push-slot)
(let ((var (car l))
(slot (make-stk nb-slots)))
(put-var slot var)
(loop3 (cdr l))))))
(bb-put-non-branch! *bb*
(make-MAKE_CLOSURES
(map (lambda (var)
(let ((closed-list
(set->list (closed-vars var const-proc-vars))))
(if (null? closed-list)
(compiler-internal-error
"gen-let, no closed variables:" (var-name var))
(make-closure-parms
(var->opnd var)
(lbl-num (schedule-gen-proc
(var->val var)
closed-list))
(map var->opnd closed-list)))))
clo-vars-list)
(current-frame live)
(source-comment node)))))
(gen-node node live why)))))
(define (save-arg opnd var live)
(if (glo? opnd)
(add-constant-var var opnd)
(save-val opnd var live)))
(define (save-val opnd var live)
(cond ((or (obj? opnd) (lbl? opnd))
(add-constant-var var opnd))
((and (reg? opnd)
(not (set-member? (reg-num opnd) (live-regs live))))
(put-var opnd var))
((and (stk? opnd)
(not (set-member? (stk-num opnd) (live-slots live))))
(put-var opnd var))
(else
(save-in-slot opnd var live))))
(define (save-in-slot opnd var live)
(let ((slot (lowest-dead-slot live)))
(put-copy opnd slot var live)))
(define (save-var opnd var live)
(cond ((or (obj? opnd) (lbl? opnd))
(add-constant-var var opnd)
var)
((or (glo? opnd) (reg? opnd) (stk? opnd))
(get-var opnd))
(else
(let ((dest (or (highest-dead-reg live) (lowest-dead-slot live))))
(put-copy opnd dest var live)
var))))
(define (put-copy opnd loc var live)
(if (and (stk? loc) (> (stk-num loc) nb-slots)) (push-slot))
(if var (put-var loc var))
(if (not (eq? opnd loc))
(bb-put-non-branch! *bb*
(make-COPY opnd loc (current-frame (if var (set-adjoin live var) live)) #f))))
(define (var-useless? var)
(and (set-empty? (var-refs var))
(set-empty? (var-sets var))))
(define (vals-live-vars live vals)
(if (null? vals)
live
(vals-live-vars (set-union live (free-variables (car vals)))
(cdr vals))))
;------------------------------------------------------------------------------
;
; generate code for a future
(define (gen-fut node live why)
(let* ((val (fut-val node))
(clo-vars (not-constant-closed-vars val))
(clo-vars-list (set->list clo-vars))
(ret-var* (make-temp-var 0))
(live-after live)
(live-starting-task (set-adjoin (set-union live-after clo-vars)
ret-var*))
(task-lbl (bbs-new-lbl! *bbs*))
(return-lbl (bbs-new-lbl! *bbs*)))
; save regs on stack if they contain values needed after the future
(save-regs (live-regs live-after)
live-starting-task)
(let ((frame-start (stk-num (highest-live-slot live-after))))
; move return address to where task expects it
(save-opnd-to-reg (make-lbl return-lbl)
target.task-return
ret-var*
(set-remove live-starting-task ret-var*))
; save variables that the task needs (that are not in regs)
(let loop1 ((l clo-vars-list) (i 0))
(if (null? l)
(dealloc-slots (- nb-slots (+ frame-start i)))
(let ((var (car l))
(rest (cdr l)))
(if (memq var regs)
(loop1 rest i)
(let loop2 ((j (- target.nb-regs 1)))
(if (>= j 0)
(if (or (>= j (length regs))
(not (set-member? (list-ref regs j) live-starting-task)))
(let ((reg (make-reg j)))
(put-copy (var->opnd var) reg var live-starting-task)
(loop1 rest i))
(loop2 (- j 1)))
(let ((slot (make-stk (+ frame-start (+ i 1))))
(needed (list->set rest)))
(if (and (or (> (stk-num slot) nb-slots)
(not (memq (list-ref slots (- nb-slots (stk-num slot))) regs)))
(set-member? (stk-num slot) (live-slots needed)))
(save-opnd slot live-starting-task))
(put-copy (var->opnd var) slot var live-starting-task)
(loop1 rest (+ i 1)))))))))
(seal-bb (intr-checks? (node-decl node)) 'CALL)
(bb-put-branch! *bb*
(make-JUMP (make-lbl task-lbl)
#f
#f
(current-frame live-starting-task)
(source-comment node)))
(let ((method
(futures-method (node-decl node)))
(task-context
(make-context (- nb-slots frame-start)
(reverse (nth-after (reverse slots) frame-start))
(cons ret-var (cdr regs))
'()
interrupt
entry-bb))
(return-context
(make-context frame-start
(nth-after slots (- nb-slots frame-start))
'()
closed
(return-interrupt interrupt)
entry-bb)))
(restore-context task-context)
(set! *bb* (make-bb
(make-LABEL-TASK
task-lbl
method
(current-frame live-starting-task)
(source-comment node))
*bbs*))
(gen-node val ret-var-set 'tail)
(let ((result-var (make-temp-var 'future)))
(restore-context return-context)
(put-var target.proc-result result-var)
(set! *bb* (make-bb
(make-LABEL-RETURN
return-lbl
method
(current-frame (set-adjoin live result-var))
(source-comment node))
*bbs*))
(gen-return target.proc-result why node))))))
;------------------------------------------------------------------------------
