Permalink
Fetching contributors…
Cannot retrieve contributors at this time
3938 lines (3422 sloc) 141 KB
;;;============================================================================
;;; File: "_front.scm"
;;; Copyright (c) 1994-2015 by Marc Feeley, All Rights Reserved.
(include "fixnum.scm")
(include-adt "_envadt.scm")
(include-adt "_gvmadt.scm")
(include-adt "_ptreeadt.scm")
(include-adt "_sourceadt.scm")
'(begin;**********brad
(##include "../gsc/_utilsadt.scm")
(##include "../gsc/_ptree1adt.scm")
(##include "../gsc/_envadt.scm")
(##include "../gsc/_gvmadt.scm")
(##include "../gsc/_hostadt.scm")
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (zzzbb-put-non-branch! bb text gvm-instr)
(let ((frame (gvm-instr-frame gvm-instr))
(comment (gvm-instr-comment gvm-instr)))
'
(bb-put-non-branch! bb
(make-copy (make-obj text)
(make-glo '***)
frame
comment))
(bb-put-non-branch! bb gvm-instr)))
;;;----------------------------------------------------------------------------
;;;; Front-end of GAMBIT compiler
;;;----------------------------------------------------------------------------
;; sample use:
;;
;; (cf "tak" '((target c)) #f #f #f) -- compile tak.scm to tak.c with C back-end
;; (cf "tak" '() #f #f #f) -- compile tak.scm with default back-end
;; (cf "tak" '() "foo.c" #f #f) -- compile tak.scm to foo.c
;; (cf "tak" '((verbose)) #f #f #f) -- produce compiler trace
;; (cf "tak" '((report)) #f #f #f) -- show usage of global variables
;; (cf "tak" '((gvm)) #f #f #f) -- write GVM code on 'tak.gvm'
;; (cf "tak" '((debug)) #f #f #f) -- generate code with debugging info
;; (cf "tak" '((expansion)) #f #f #f) -- show code after source-to-source transf.
;; (cf "tak" '((asm) (stats)) #f #f #f) -- various back-end options
(define cf #f)
(set! cf
(lambda (input opts output-filename-gen module-name unique-name)
(with-exception-handling
(lambda ()
(let* ((t
(assq 'target opts))
(unhandled-opts
(handle-options
opts
(target-options
(target-get
(if (and t (pair? (cdr t)))
(cadr t)
(default-target)))))))
(set! warnings-requested? compiler-option-warnings)
(let* ((info-port
(if compiler-option-verbose
(current-output-port)
#f))
(result
(if (not (null? unhandled-opts))
(compiler-error
"Unhandled compiler options:" unhandled-opts)
(compile-program
input
(if t
opts
(cons (list 'target (default-target)) opts))
output-filename-gen
module-name
unique-name
info-port))))
result))))))
(define (handle-options opts target-specific-options)
(reset-options)
(let ((rev-unhandled-opts '()))
(for-each
(lambda (opt)
(let ((handled?
(and (pair? opt)
(case (car opt)
((target)
#t) ;; target option handled previously
((warnings)
(set! compiler-option-warnings #t)
#t)
((verbose)
(set! compiler-option-verbose #t)
#t)
((report)
(set! compiler-option-report #t)
#t)
((expansion)
(set! compiler-option-expansion #t)
#t)
((gvm)
(set! compiler-option-gvm #t)
#t)
((debug)
(set! compiler-option-debug #t)
#t)
((debug-location)
(set! compiler-option-debug-location #t)
#t)
((debug-source)
(set! compiler-option-debug-source #t)
#t)
((debug-environments)
(set! compiler-option-debug-environments #t)
#t)
((track-scheme)
(set! compiler-option-track-scheme #t)
#t)
((c dynamic exe obj link flat
check force keep-c
o l prelude postlude
cc-options ld-options-prelude ld-options
asm)
#t) ;; these options are innocuous
(else
;; OK if the option is a target specific option
(assq (car opt) target-specific-options))))))
(if (not handled?)
(set! rev-unhandled-opts
(cons opt rev-unhandled-opts)))))
opts)
(if (or compiler-option-debug-location
compiler-option-debug-source
compiler-option-debug-environments)
(set! compiler-option-debug #t)
(begin
(set! compiler-option-debug-location #t)
(set! compiler-option-debug-source #t)
(set! compiler-option-debug-environments #t)))
(reverse rev-unhandled-opts)))
(define (reset-options)
(set! compiler-option-warnings #f)
(set! compiler-option-verbose #f)
(set! compiler-option-report #f)
(set! compiler-option-expansion #f)
(set! compiler-option-gvm #f)
(set! compiler-option-debug #f)
(set! compiler-option-debug-location #f)
(set! compiler-option-debug-source #f)
(set! compiler-option-debug-environments #f)
(set! compiler-option-track-scheme #f))
(define compiler-option-warnings #f)
(define compiler-option-verbose #f)
(define compiler-option-report #f)
(define compiler-option-expansion #f)
(define compiler-option-gvm #f)
(define compiler-option-debug #f)
(define compiler-option-debug-location #f)
(define compiler-option-debug-source #f)
(define compiler-option-debug-environments #f)
(define compiler-option-track-scheme #f)
(define ##compilation-options '())
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;;;; The program compiler
(define wrap-program #f)
(set! wrap-program
(lambda (program)
program))
(define expand-source #f)
(set! expand-source
(lambda (program)
program))
(define (compile-program-frontend
input
opts
output-filename-gen
module-name
unique-name
info-port
inner)
(scheme-global-var-define!
(scheme-global-var
(string->canonical-symbol "##compilation-options"))
opts)
(env.begin!)
(ptree.begin! info-port)
(virtual.begin!)
(let ((target-name (cadr (assq 'target opts))))
(target-select! target-name info-port))
(let* ((output-filename
(and output-filename-gen
(output-filename-gen)))
(root
(if output-filename
(path-strip-extension output-filename)
(path-strip-directory (path-strip-extension input))))
(output
(if output-filename
output-filename
(string-append root (caar target.file-extensions))))
(module-name
(or module-name
(path-strip-directory root)))
(unique-name
(or unique-name
module-name)))
(if (not (valid-module-name? module-name))
(compiler-error
"Invalid characters in file name (must be a symbol with no \"#\")")
(let ()
(define (add-loading-of-required-modules ptrees source env comp-scope)
(let ((required-modules
(table-ref comp-scope 'required-modules '())))
(if (pair? required-modules)
(let ((env
(add-extended-bindings
(add-proper-tail-calls
(add-safe env)))))
(append
(map (lambda (module-ref)
(new-call source env
(new-ref source env
(env-lookup-global-var
env
'##load-required-module))
(list (new-cst source env
module-ref))))
required-modules)
ptrees))
ptrees)))
(let* ((v1 (read-source input #f #t))
(script-line (vector-ref v1 0))
(expr (vector-ref v1 1))
(program (expand-source (wrap-program expr)))
(x (##in-new-compilation-scope
(lambda ()
(parse-program
program
(make-global-environment)
module-name
vector))))
(v2 (car x))
(comp-scope (cdr x))
(lst (vector-ref v2 0))
(env (vector-ref v2 1))
(c-intf (vector-ref v2 2))
(ptrees (add-loading-of-required-modules lst program env comp-scope))
(parsed-program (normalize-program ptrees))
(result
(inner parsed-program
env
opts
root
output
module-name
unique-name
c-intf
comp-scope
script-line)))
(target-unselect!)
(virtual.end!)
(ptree.end!)
(env.end!)
result)))))
(define (compile-program
input
opts
output-filename-gen
module-name
unique-name
info-port)
(set! warnings-requested? compiler-option-warnings)
(let ((result
(with-exception-handling
(lambda ()
(compile-program-frontend
input
opts
output-filename-gen
module-name
unique-name
info-port
(lambda (parsed-program
env
opts
root
output
module-name
unique-name
c-intf
comp-scope
script-line)
(if compiler-option-expansion
(let ((port (current-output-port)))
(display "Expansion:" port)
(newline port)
(let loop ((l parsed-program))
(if (pair? l)
(let ((ptree (car l)))
(newline port)
(pp-expression (parse-tree->expression ptree) port)
(loop (cdr l)))))
(newline port)))
(let* ((module-procs
(compile-parsed-program module-name
parsed-program
env
c-intf
info-port))
(module-meta-info
(append
(table->list comp-scope)
(if script-line
(list (cons 'script-line script-line))
'())))
(module-descr
;; TODO: support type descriptor
(vector (string->symbol module-name)
(car module-procs)
1 ;; preload flag, note that linker may change this
module-meta-info
#f ;; space for foreign pointer to ___module_struct
)))
(if compiler-option-report
(generate-report env))
(if compiler-option-gvm
(let ((gvm-port
(open-output-file (string-append root ".gvm"))))
(virtual.dump module-procs gvm-port)
(close-output-port gvm-port)))
(target.dump
module-procs
output
c-intf
module-descr
unique-name
opts)
(dump-c-intf module-procs root c-intf)
output)))))))
(if info-port
(if result
(begin
(display "Compilation finished." info-port)
(newline info-port))
(begin
(display "Compilation terminated abnormally." info-port)
(newline info-port))))
result))
(define (expand-program input . rest)
(let ((opts #f)
(loc-table #f))
(if (pair? rest)
(begin
(set! opts (car rest))
(if (pair? (cdr rest))
(set! loc-table (car (cdr rest))))))
(if (not opts)
(set! opts (list (list 'target (c#default-target)))))
(set! warnings-requested? compiler-option-warnings)
(with-exception-handling
(lambda ()
(compile-program-frontend
input
opts
#f
#f
#f
#f
(lambda (parsed-program
env
opts
root
output
module-name
unique-name
c-intf
comp-scope
script-line)
(map (lambda (x)
(parse-tree->expression x loc-table))
parsed-program)))))))
(define (valid-module-name? module-name)
; Valid module names are exactly the valid symbols except those
; containing "#". A module name can also be a number.
(define (valid-char? c)
(and (not (memv c '(#\# #\; #\( #\) #\ #\[ #\] #\{ #\} #\" #\' #\` #\,)))
(not (char-whitespace? c))))
(let ((n (string-length module-name)))
(and (> n 0) ; should not be empty
(not (string=? module-name ".")) ; should not be "."
;;(not (string->number module-name 10)) ; should not be a number
(let loop ((i 0))
(if (< i n)
(if (valid-char? (string-ref module-name i))
(loop (+ i 1))
#f)
#t)))))
(define (dump-c-intf module-procs root c-intf)
(let ((decls (c-intf-decls c-intf))
(procs (c-intf-procs c-intf))
(inits (c-intf-inits c-intf)))
(if (or (not (null? decls))
(not (null? procs))
(not (null? inits)))
(let* ((module-name
(proc-obj-name (car module-procs)))
(filename
(string-append root ".c"))
(port
(open-output-file filename)))
(display "/* File: \"" port)
(display filename port)
(display "\", C-interface file produced by Gambit " port)
(display (compiler-version-string) port)
(display " */" port)
(newline port)
(display "#define " port)
(display c-id-prefix port)
(display "MODULE_NAME \"" port)
(display module-name port)
(display "\"" port)
(newline port)
(display "#define " port)
(display c-id-prefix port)
(display "MODULE_LINKER " port)
(display c-id-prefix port)
(display (scheme-id->c-id module-name) port)
(newline port)
(display "#define " port)
(display c-id-prefix port)
(display "VERSION " port)
(display (compiler-version) port)
(newline port)
;; ******************to be fixed
(if (not (null? procs))
(begin
(display "#define " port)
(display c-id-prefix port)
(display "C_PRC_COUNT " port)
(display (length procs) port)
(newline port)))
(display "#include \"gambit.h\"" port)
(newline port)
(display c-id-prefix port)
(display "BEGIN_MODULE" port)
(newline port)
(for-each
(lambda (x)
(let ((scheme-name (c-proc-scheme-name x)))
(display c-id-prefix port)
(display "SUPPLY_PRM(" port)
(display c-id-prefix port)
(display "P_" port)
(display (scheme-id->c-id scheme-name) port)
(display ")" port)
(newline port)))
procs)
(newline port)
(for-each
(lambda (x)
(display x port)
(newline port))
decls)
(if (not (null? procs))
(begin
(for-each
(lambda (x)
(let ((scheme-name (c-proc-scheme-name x))
(c-name (c-proc-c-name x))
(arity (c-proc-arity x))
(body (c-proc-body x)))
(display c-id-prefix port)
(display "BEGIN_C_COD(" port)
(display c-name port)
(display "," port)
(display c-id-prefix port)
(display "P_" port)
(display (scheme-id->c-id scheme-name) port)
(display "," port)
(display arity port)
(display ")" port)
(newline port)
;;???????????????????????????????????????????????
(display "#undef ___ARG1" port)
(newline port)
(display "#define ___ARG1 ___R1" port)
(newline port)
(display "#undef ___ARG2" port)
(newline port)
(display "#define ___ARG2 ___R2" port)
(newline port)
(display "#undef ___ARG3" port)
(newline port)
(display "#define ___ARG3 ___R3" port)
(newline port)
(display "#undef ___RESULT" port)
(newline port)
(display "#define ___RESULT ___R1" port)
(newline port)
(display body port)
(display c-id-prefix port)
(display "END_C_COD" port)
(newline port)))
procs)
(newline port)
(display c-id-prefix port)
(display "BEGIN_C_PRC" port)
(newline port)
(let loop ((i 0) (lst procs))
(if (not (null? lst))
(let* ((x (car lst))
(scheme-name (c-proc-scheme-name x))
(c-name (c-proc-c-name x))
(arity (c-proc-arity x)))
(if (= i 0)
(display " " port)
(display "," port))
(display c-id-prefix port)
(display "DEF_C_PRC(" port)
(display c-name port)
(display "," port)
(display c-id-prefix port)
(display "P_" port)
(display (scheme-id->c-id scheme-name) port)
(display "," port)
(display arity port)
(display ")" port)
(newline port)
(loop (+ i 1) (cdr lst)))))
(display c-id-prefix port)
(display "END_C_PRC" port)
(newline port)))
(newline port)
(display c-id-prefix port)
(display "BEGIN_PRM" port)
(newline port)
(for-each
(lambda (x)
(display x port)
(newline port))
inits)
(display c-id-prefix port)
(display "END_PRM" port)
(newline port)
(close-output-port port)))))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;;;; Report generation
(define (generate-report env)
(let ((vars (sort-variables (env-global-variables 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 (ptset->list (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 (ptset->list (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))
'())))
(define (classify var std?)
(let ((proc (target.prim-info (var-name var))))
(and proc
(standard-procedure?
proc
std?
(not std?)
(scheme-dialect env)))))
(display "Global variable usage:") (newline)
(newline)
(report "OTHERS"
(lambda (var) #t)
(report "EXTENDED"
(lambda (var) (classify var #f))
(report "STANDARD"
(lambda (var) (classify var #t))
vars
#f)
#f)
#f)))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
(define (compile-parsed-program module-name program env c-intf info-port)
(if info-port
(display "Compiling:" info-port))
(set! trace-indentation 0)
(set! *bbs* (make-bbs))
(set! *global-env* env)
(set! proc-queue '())
(set! known-procs '())
(restore-context
(make-context 0 '() (list ret-var) '() (entry-poll) #f))
(let ((procs
(let loop1 ((l program) (procs '()))
(if (not (null? l))
(let ((node (car l)))
(if (def? node)
(let* ((var (def-var node))
(val (global-single-def var)))
(if (and val (prc? val))
(let ((proc
(make-proc-obj
(symbol->string (var-name var)) ; name
(prc-c-name val) ; c-name
#t ; primitive?
#f ; code
(call-pattern val) ; call-pat
#t ; side-effects?
'() ; strict-pat
0 ; lift-pat
'(#f) ; type
#f))) ; standard
(add-constant-var var (make-obj proc))
(loop1 (cdr l) (cons proc procs)))
(loop1 (cdr l) procs)))
(loop1 (cdr l) procs)))
(let loop2 ((l (c-intf-procs c-intf)) (procs procs))
(if (not (null? l))
(let* ((x (car l))
(name (c-proc-scheme-name x))
(arity (c-proc-arity x))
(sym (string->canonical-symbol name))
(var (env-lookup-global-var *global-env* sym))
(pat (make-pattern arity 0 0 #f))
(proc
(make-proc-obj
name ; name
#f ; c-name
#t ; primitive?
x ; code
pat ; call-pat
#t ; side-effects?
'() ; strict-pat
0 ; lift-pat
'(#f) ; type
#f))) ; standard
(add-constant-var var (make-obj proc))
(set-car! l proc)
(loop2 (cdr l) (cons proc procs)))
(reverse procs)))))))
(let* ((entry-lbl
(bbs-new-lbl! *bbs*))
(body-lbl
(bbs-new-lbl! *bbs*))
(frame
(current-frame ret-var-set))
(node1
(car program)))
(bbs-entry-lbl-num-set! *bbs* entry-lbl)
(set! entry-bb
(make-bb (make-label-entry
entry-lbl
0
'()
#f
#f
#f
frame
(node->comment node1))
*bbs*))
(bb-put-branch! entry-bb
(make-jump (make-lbl body-lbl)
#f
#f
#f
frame
(node->comment node1)))
(set! *bb*
(make-bb (make-label-simple body-lbl frame (node->comment node1))
*bbs*))
(let loop3 ((l program))
(let ((node (car l)))
(if (def? node)
(gen-define (def-var node) (def-val node) info-port)
(gen-node node
ret-var-set
(if (null? (cdr l))
(make-reason-tail)
(make-reason-side))))
(if (null? (cdr l))
(if (def? node)
(gen-return node
ret-var-set
(make-reason-tail)
(make-obj void-object)))
(loop3 (cdr l)))))
(let loop4 ()
(if (pair? proc-queue)
(let ((proc-info (car proc-queue)))
(set! proc-queue (cdr proc-queue))
(gen-proc proc-info info-port)
(trace-unindent info-port)
(loop4))))
(if info-port
(begin
(newline info-port)
(newline info-port)))
(bbs-purify! *bbs*)
(let ((proc
(make-proc-obj
(string-append module-prefix module-name) ; name
#f ; c-name
#t ; primitive?
*bbs* ; code
'(0) ; call-pat
#t ; side-effects?
'() ; strict-pat
0 ; lift-pat
'(#f) ; type
#f))) ; standard
(set! *bb* '())
(set! *bbs* '())
(set! *global-env* '())
(set! proc-queue '())
(set! known-procs '())
(clear-context)
(cons proc procs)))))
(define *bb* '())
(define *bbs* '())
(define *global-env* '())
(define proc-queue '())
(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-queue proc-queue)
(p-known-procs known-procs)
(p-context (current-context)))
(set! *bbs* (make-bbs))
(set! proc-queue '())
(set! known-procs '())
(let* ((proc-info (schedule-gen-proc node #f))
(entry-lbl-num (proc-info-lbl1 proc-info)))
(define (do-body)
(let loop ()
(if (pair? proc-queue)
(let ((proc-info (car proc-queue)))
(set! proc-queue (cdr proc-queue))
(gen-proc proc-info info-port)
(trace-unindent info-port)
(loop))))
(trace-unindent info-port)
(bbs-purify! *bbs*))
(bbs-entry-lbl-num-set! *bbs* entry-lbl-num)
(if (constant-var? var)
(let-constant-var var (make-lbl entry-lbl-num)
(lambda ()
(add-known-proc proc-info)
(do-body)))
(do-body))
(let ((bbs *bbs*)
(x (var-constant var)))
(set! *bbs* p-bbs)
(set! *bb* p-bb)
(set! proc-queue p-proc-queue)
(set! known-procs p-known-procs)
(restore-context p-context)
(if x
;;; (let ((proc (obj-val (cdr x))))
(let ((proc (obj-val x)))
(proc-obj-code-set! proc bbs))
(let ((proc
(make-proc-obj
(symbol->string (var-name var)) ; name
(prc-c-name node) ; c-name
#f ; primitive?
bbs ; code
(call-pattern node) ; call-pat
#t ; side-effects?
'() ; strict-pat
0 ; lift-pat
'(#f) ; type
#f))) ; standard
(put-copy 1 (make-obj proc)
(make-glo (var-name var))
#f
ret-var-set
(node->comment node)))))))
(let* ((dst (make-glo (var-name var)))
(src (gen-node node
ret-var-set
(make-reason-need dst))))
(put-copy 2 src dst #f ret-var-set (node->comment node)))))
(define (call-pattern node)
(let ((nb-parms (length (prc-parms node)))
(nb-opts (length (prc-opts node)))
(nb-keys (length (or (prc-keys node) '())))
(rest? (prc-rest? node)))
(make-pattern nb-parms nb-opts nb-keys rest?)))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;; 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,
;; poll = what is the maximum number of GVM instructions that can be
;; executed before the next poll instruction and has there been a poll
;; instruction executed 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 poll entry-bb)
(vector nb-slots slots regs closed poll 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-poll 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 poll '())
(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! poll (context-poll 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 poll 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-poll since-entry? delta)
(cons since-entry? ;; a path to here since the entry-point has a poll?
delta)) ;; upper bound on number of instructions since last poll
(define (poll-since-entry? x) (car x))
(define (poll-delta x) (cdr x))
(define (entry-poll)
(make-poll #f (- poll-period poll-head)))
(define (return-poll poll where)
(let ((delta (poll-delta poll)))
(make-poll (poll-since-entry? poll)
(if (eq? where 'internal) ;; return point of call to primitive
delta
(+ poll-head (max delta poll-tail))))))
(define (poll-merge poll other-poll)
(make-poll
(or (poll-since-entry? poll)
(poll-since-entry? other-poll))
(max (poll-delta poll)
(poll-delta other-poll))))
(define poll-period #f) ; Lmax
(set! poll-period 40000)
(define poll-head #f) ; E
(set! poll-head 200)
(define poll-tail #f) ; R
(set! poll-tail 200)
;; (entry-context proc closed-list) returns the context in existence
;; upon entry to the procedure `proc'. When the procedure is not
;; a closure, closed-list = #f.
(define (entry-context proc closed-list)
(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 (length parms) (not (not closed-list))))
(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)
(drop 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)
(drop 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)))))
;;;;;;;;;;;;;;;;;;
'(pp (list '********2 fs (map (lambda (x) (and x (var-name x))) slots-list) (map (lambda (x) (and x (var-name x))) regs-list) (and closed-list (map var-name closed-list))))
(make-context fs
slots-list
regs-list
(or closed-list '())
(entry-poll)
#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 (and (eq? new ret-var) ; only keep one copy of return address
(or (memq ret-var regs)
(memq ret-var slots)))
(put-v (var->opnd ret-var) empty-var))
(put-v opnd new))
(define (flush-regs)
(set! regs '()))
(define (push-slot)
(set! slots (cons empty-var slots))
(set! nb-slots (+ nb-slots 1)))
(define (adjust-slots new-nb-slots live comment)
(if (< new-nb-slots nb-slots)
(shrink-slots2 new-nb-slots)
(extend-slots2 new-nb-slots live comment)))
(define (shrink-slots2 new-nb-slots)
(set! slots (drop slots (- nb-slots new-nb-slots)))
(set! nb-slots new-nb-slots))
(define (extend-slots2 new-nb-slots live comment)
(let loop ()
(if (< nb-slots new-nb-slots)
(begin
(push-slot)
(zzzbb-put-non-branch! *bb* "IN extend-slots2"
(make-copy #f
(make-stk nb-slots)
(current-frame live)
comment))
(loop)))))
(define (extend-slots new-nb-slots live comment)
(if (< new-nb-slots nb-slots)
(compiler-internal-error
"extend-slots, invalid argument"))
(extend-slots2 new-nb-slots live comment))
(define (shrink-slots new-nb-slots)
(if (or (< new-nb-slots 0)
(> new-nb-slots nb-slots))
(compiler-internal-error
"shrink-slots, invalid argument"))
(shrink-slots2 new-nb-slots))
(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 (varset-intersects? live (list->varset closed))
(varset-adjoin live closure-env-var)
live))
(define (live-reg-var? reg-var live-v)
(and (varset-member? reg-var live-v)
(not (memq reg-var slots))))
(define (live-slot-var? slot-var live-v)
(varset-member? slot-var live-v))
(define (dead-reg/stk? opnd live)
(cond ((reg? opnd)
(let ((var (reg->var regs (reg-num opnd))))
(or (not var)
(not (live-reg-var? var (live-vars live))))))
((stk? opnd)
(let ((var (stk->var slots (stk-num opnd))))
(or (not var)
(not (live-slot-var? var (live-vars live))))))
(else
#f)))
(define (live-slots live)
(let ((live-v (live-vars live)))
(let loop ((s '()) (l slots) (i nb-slots))
(cond ((null? l)
s)
((live-slot-var? (car l) live-v)
(loop (cons i s) (cdr l) (- i 1)))
(else
(loop s (cdr l) (- i 1)))))))
(define (dead-slots live)
(let ((live-v (live-vars live)))
(let loop ((s '()) (l slots) (i nb-slots))
(cond ((null? l)
s)
((not (live-slot-var? (car l) live-v))
(loop (cons i s) (cdr l) (- i 1)))
(else
(loop s (cdr l) (- i 1)))))))
(define (live-regs live)
(let ((live-v (live-vars live)))
(let loop ((s '()) (l regs) (i 0))
(cond ((null? l)
(reverse s))
((live-reg-var? (car l) live-v)
(loop (cons i s) (cdr l) (+ i 1)))
(else
(loop s (cdr l) (+ i 1)))))))
(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 ((live-v (live-vars live)))
(if (null? regs)
(make-reg 1)
(let ((reg0 (car regs))
(rest (cdr regs)))
(let loop ((rest rest) (i 1))
(if (null? rest)
(if (< i target.nb-regs)
(make-reg i)
(if (live-reg-var? reg0 live-v)
#f
(make-reg 0)))
(if (live-reg-var? (car rest) live-v)
(loop (cdr rest) (+ i 1))
(make-reg i))))))))
(define (highest-dead-reg live)
(let ((live-v (live-vars live)))
(cond ((or (null? regs) (not (live-reg-var? (car regs) live-v)))
(make-reg 0))
((< (length regs) target.nb-regs)
(make-reg (- target.nb-regs 1)))
(else
(let loop ((rest (reverse (cdr regs))) (i (- target.nb-regs 1)))
(if (null? rest)
#f
(if (live-reg-var? (car rest) live-v)
(loop (cdr rest) (- i 1))
(make-reg i))))))))
(define (highest lst) ; return highest number in a list
(if (null? lst) #f (apply max lst)))
(define (lowest lst) ; return lowest number in a list
(if (null? lst) #f (apply min lst)))
(define (var->opnd var)
(let ((x (var-constant var)))
(if x
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))
(begin
;;*************
;;(display "================")(newline)
;;(display "regs : ")(pp (map (lambda (x) (if (var? x) (var-name x) x)) regs))
;;(display "slots : ")(pp (map (lambda (x) (if (var? x) (var-name x) x)) slots))
;;(display "closed: ")(pp (map (lambda (x) (if (var? x) (var-name x) x)) closed))
(compiler-internal-error
"var->opnd, variable is not accessible:" (var-name var)))))))))))))
(define (node->comment node)
(let ((x (make-comment)))
(comment-put! x 'node node)
x))
(define (sort-variables lst)
(sort-list lst
(lambda (x y)
(string<? (symbol->string (var-name x))
(symbol->string (var-name y))))))
;;;----------------------------------------------------------------------------
(define (add-constant-var var opnd)
(var-constant-set! var opnd))
(define (let-constant-var var opnd thunk)
(let ((temp (var-constant var)))
(var-constant-set! var opnd)
(thunk)
(var-constant-set! var temp)))
(define (constant-var? var)
(var-constant var))
(define (not-constant-var? var)
(not (constant-var? var)))
(define (add-known-proc proc-info)
(set! known-procs
(cons (cons (proc-info-lbl1 proc-info) proc-info) known-procs)))
;;;----------------------------------------------------------------------------
;;;; generate code for a procedure
(define (gen-proc proc-info info-port)
(let ((proc (proc-info-proc proc-info)))
(trace-indent info-port)
(if info-port
(if (prc-name proc)
(write (string->canonical-symbol (prc-name proc)) info-port)
(write "unknown" info-port)))
(set! *bb* (proc-info-bb proc-info))
(let ((lbl (bb-lbl-num *bb*)))
(restore-context (proc-info-context proc-info))
(gen-node (prc-body proc)
(varset-union (proc-body-live-varset proc)
ret-var-set)
(make-reason-tail)))))
(define (proc-body-live-varset proc)
(let* ((body (prc-body proc))
(env (node-env body)))
(if (optimize-dead-local-variables? env)
(varset-empty)
(list->varset (prc-parms proc)))))
(define (schedule-gen-proc proc closed-list)
;; closed-list = #f when proc is not a closure
(let* ((lbl1 (bbs-new-lbl! *bbs*)) ; arg check entry point
(lbl2 (bbs-new-lbl! *bbs*)) ; no arg check entry point
(context-lbl1 (entry-context proc closed-list))
(context-lbl2 context-lbl1)
(frame-lbl1 (context->frame
context-lbl1
(varset-union (bound-free-variables (prc-body proc))
(varset-union (proc-body-live-varset proc)
ret-var-set))))
(frame-lbl2 frame-lbl1)
(closed? (not (not closed-list)))
(bb1 (make-bb
(make-label-entry
lbl1
(length (prc-parms proc))
(map make-obj (prc-opts proc))
(and (prc-keys proc)
(map (lambda (x)
(cons (car x) (make-obj (cdr x))))
(prc-keys proc)))
(prc-rest? proc)
closed?
frame-lbl1
(node->comment proc))
*bbs*))
(bb2 (make-bb
(make-label-simple
lbl2
frame-lbl2
(node->comment proc))
*bbs*))
(proc-info (make-proc-info proc lbl1 lbl2 bb2 context-lbl2
(target.label-info
(length (prc-parms proc))
closed?))))
(context-entry-bb-set! context-lbl1 bb1)
(bb-put-branch! bb1
(make-jump (make-lbl lbl2) #f #f #f frame-lbl2 (node->comment proc)))
(set! proc-queue (cons proc-info proc-queue))
proc-info))
(define (make-proc-info proc lbl1 lbl2 bb context pcontext)
(vector proc lbl1 lbl2 bb context pcontext))
(define (proc-info-proc x) (vector-ref x 0))
(define (proc-info-lbl1 x) (vector-ref x 1))
(define (proc-info-lbl2 x) (vector-ref x 2))
(define (proc-info-bb x) (vector-ref x 3))
(define (proc-info-context x) (vector-ref x 4))
(define (proc-info-pcontext x) (vector-ref x 5))
;;;----------------------------------------------------------------------------
;; There are four reasons for generating an expression:
;; expression in tail position
(define (make-reason-tail)
'tail)
(define (reason-tail? r)
(eq? r 'tail))
;; expression is evaluated for side effect
(define (make-reason-side)
'side)
(define (reason-side? r)
(eq? r 'side))
;; expression's value is needed
(define (make-reason-need hint-loc)
(vector hint-loc))
(define (reason-need? r)
(and (vector? r) (= (vector-length r) 1)))
(define (reason-need-hint-loc r)
(vector-ref r 0))
;; expression is used as a predicate in a conditional branch
(define (make-reason-pred true-live false-live)
(vector true-live false-live))
(define (reason-pred? r)
(and (vector? r) (= (vector-length r) 2)))
(define (reason-pred-true-live r)
(vector-ref r 0))
(define (reason-pred-false-live r)
(vector-ref r 1))
(define (reason-pred-invert r)
(make-reason-pred
(reason-pred-false-live r)
(reason-pred-true-live r)))
(define (make-branchpoints true-context true-bb false-context false-bb)
(vector true-context true-bb false-context false-bb))
(define (branchpoints-true-context bp)
(vector-ref bp 0))
(define (branchpoints-true-bb bp)
(vector-ref bp 1))
(define (branchpoints-false-context bp)
(vector-ref bp 2))
(define (branchpoints-false-bb bp)
(vector-ref bp 3))
(define (branchpoints-invert bp)
(make-branchpoints
(branchpoints-false-context bp)
(branchpoints-false-bb bp)
(branchpoints-true-context bp)
(branchpoints-true-bb bp)))
;;;----------------------------------------------------------------------------
;;;; generate code for an expression
(define (gen-node node live reason)
#;
(begin
(display "------------------ gen-node: ")
(newline)
(pp (parse-tree->expression node))
(display "live: ")
(pp (map var-name (varset->list live)))
(display "regs : ")
(pp (map (lambda (x) (if (var? x) (var-name x) x)) regs))
(display "slots : ")
(pp (map (lambda (x) (if (var? x) (var-name x) x)) slots))
(display "closed: ")
(pp (map (lambda (x) (if (var? x) (var-name x) x)) closed))
(display "reason: ")
(pp (cond ((reason-tail? reason) 'tail)
((reason-need? reason) 'need)
((reason-side? reason) 'side)
((reason-pred? reason) 'pred)
(else '???))))
(cond ((cst? node)
(gen-return node live reason (make-obj (cst-val node))))
((ref? node)
(gen-return
node
live
reason
(if (reason-side? reason)
(make-obj void-object)
(let ((proc (global-proc-obj node)))
(if proc
(make-obj proc)
(var->opnd (ref-var node)))))))
((set? node)
(let* ((var (set-var node))
(dst (make-glo (var-name var)))
(src (gen-node (set-val node)
(varset-adjoin live var)
(make-reason-need dst))))
(put-copy 3 src dst #f live (node->comment node))
(gen-return node live reason (make-obj void-object))))
((def? node)
(compiler-internal-error
"gen-node, 'def' node not at root of parse tree"))
((tst? node)
(gen-tst/switch node live reason))
((conj? node)
(gen-conj/disj node live reason))
((disj? node)
(gen-conj/disj node live reason))
((prc? node)
(let* ((closed (not-constant-closed-vars node))
(closed-list (sort-variables (varset->list closed)))
(closed? (or (not (null? closed-list))
(generative-lambda? (node-env node))))
(proc-info (schedule-gen-proc node (and closed? closed-list)))
(proc-lbl (make-lbl (proc-info-lbl1 proc-info))))
(let ((opnd
(if (not closed?)
(begin
(add-known-proc proc-info)
proc-lbl)
(begin
(shrink-slots
(stk-num
(highest-live-slot
(varset-union closed live))))
(push-slot)
(let ((slot (make-stk nb-slots))
(var (make-temp-var 'closure)))
(put-var slot var)
(zzzbb-put-non-branch! *bb* "IN gen-node"
(make-close
(list (make-closure-parms
slot
(lbl-num proc-lbl)
(map var->opnd closed-list)))
(current-frame (varset-adjoin live var))
(node->comment node)))
slot)))))
(gen-return node live reason opnd))))
((app? node)
(gen-call node live reason))
((fut? node)
(gen-fut node live reason))
(else
(compiler-internal-error
"gen-node, unknown parse tree node type:" node))))
(define (gen-return node live reason opnd)
(cond ((reason-tail? reason)
(let ((var (make-temp-var 'result)))
(put-copy 4 opnd
target.proc-result
var
ret-var-set
(node->comment node))
(let ((ret-opnd (var->opnd ret-var)))
(seal-bb (intrs-enabled? (node-env node)) 'return)
(shrink-slots 0)
(bb-put-branch! *bb*
(make-jump ret-opnd
#f
#f
#f
(current-frame (varset-singleton var))
(node->comment node))))))
((reason-pred? reason)
(if (obj? opnd)
(let* ((false?
(false-object? (obj-val opnd)))
(dummy-lbl
(bbs-new-lbl! *bbs*))
(dummy-bb
(make-bb
(make-label-simple
dummy-lbl
(current-frame
(if false?
(reason-pred-false-live reason)
(reason-pred-true-live reason)))
(node->comment node))
*bbs*))
(context
(current-context)))
(if false?
(make-branchpoints context dummy-bb context *bb*)
(make-branchpoints context *bb* context dummy-bb)))
(branchpoints-invert
(gen-conditional node
live
(reason-pred-invert reason)
**not-proc-obj
(list opnd)))))
(else ; (or (reason-need? reason) (reason-side? reason))
opnd)))
(define (gen-conditional node live reason test opnds)
(let* ((true-lbl
(bbs-new-lbl! *bbs*))
(false-lbl
(bbs-new-lbl! *bbs*))
(true-bb
(make-bb
(make-label-simple
true-lbl
(current-frame (reason-pred-true-live reason))
(node->comment node))
*bbs*))
(false-bb
(make-bb
(make-label-simple
false-lbl
(current-frame (reason-pred-false-live reason))
(node->comment node))
*bbs*)))
(bb-put-branch! *bb*
(make-ifjump
test
opnds
true-lbl
false-lbl
#f
(current-frame live)
(node->comment node)))
(let ((context (current-context)))
(make-branchpoints context true-bb context false-bb))))
(define (not-constant-closed-vars val)
(list->varset
(keep not-constant-var? (varset->list (bound-free-variables val)))))
;;;----------------------------------------------------------------------------
;;;; generate code for a conditional
(define transform-to-case? #f)
(set! transform-to-case? #t)
(define min-cases-for-switch #f)
(set! min-cases-for-switch 4)
(define (gen-tst/switch node live reason)
(if transform-to-case?
(detect-case
node
(lambda (case-var branches nb-cases)
(if (and (>= nb-cases min-cases-for-switch)
(reason-tail? reason));;TODO: also optimize when not in tail pos
(gen-switch node live reason case-var branches)
(gen-tst node live reason))))
(gen-tst node live reason)))
(define (gen-switch node live reason case-var branches)
(let* ((rev-branches
(reverse branches))
(rev-branch-nodes
(map car rev-branches))
(rev-branch-lbls
(map (lambda (b) (bbs-new-lbl! *bbs*)) rev-branches))
(default-branch-lbl
(car rev-branch-lbls))
(opnd
(var->opnd case-var))
(all-live
(varset-union-multi
(cons live
(map bound-free-variables rev-branch-nodes))))
(frame
(current-frame all-live)))
(bb-put-branch! *bb*
(make-switch
opnd
(let loop ((branches (cdr rev-branches))
(branch-lbls (cdr rev-branch-lbls))
(cases '()))
(if (null? branches)
cases
(let* ((branch (car branches))
(lbl (car branch-lbls))
(objs (cdr branch)))
(loop (cdr branches)
(cdr branch-lbls)
(append (map (lambda (obj)
(make-switch-case obj lbl))
objs)
cases)))))
default-branch-lbl
#f
frame
(node->comment node)))
(let ((context (current-context)))
(for-each
(lambda (branch-node branch-lbl)
(restore-context context)
(set! *bb* (make-bb (make-label-simple
branch-lbl
frame
(node->comment node))
*bbs*))
(gen-node branch-node live reason))
rev-branch-nodes
rev-branch-lbls))))
(define (detect-case node cont)
(define case-var #f)
(define (try-ref-cst arg1 arg2)
(and (ref? arg1)
(cst? arg2)
(let ((var (ref-var arg1))
(val (cst-val arg2)))
(and (bound? var)
(target.switch-testable? val)
(begin
(if (not case-var)
(set! case-var var))
(and (eq? case-var var)
(list val)))))))
(define (extract-cases pre cs)
(cond ((disj? pre)
(let ((cs2 (extract-cases (disj-pre pre) cs)))
(and cs2
(extract-cases (disj-alt pre) cs2))))
((app? pre)
(let ((proc (app->specialized-proc pre))
(args (app-args pre)))
(and (eq? proc **eq?-proc-obj)
(= (length args) 2)
(let* ((arg1 (car args))
(arg2 (cadr args))
(x (or (try-ref-cst arg1 arg2)
(try-ref-cst arg2 arg1))))
(and x
(let ((val (car x)))
(if (memq val cs) ;; avoid repeated eq? cases
cs
(cons val cs))))))))
(else
#f)))
(define (extract-case node cont)
(if (tst? node)
(let ((pre (tst-pre node))
(con (tst-con node))
(alt (tst-alt node)))
(let ((cs (extract-cases pre '())))
(if cs
(extract-case
alt
(lambda (branches nb-cases)
(cont (cons (cons con cs) branches)
(+ nb-cases (length cs)))))
(cont (list (cons node #f)) 0))))
(cont (list (cons node #f)) 0)))
(extract-case node
(lambda (branches nb-cases)
(cont case-var branches nb-cases))))
(define (gen-tst node live reason)
(let ((pre (tst-pre node))
(con (tst-con node))
(alt (tst-alt node)))
(let* ((con-fv
(bound-free-variables con))
(con-live
(varset-union live con-fv))
(alt-fv
(bound-free-variables alt))
(alt-live
(varset-union live alt-fv))
(after-pre-live
(varset-union con-fv alt-live))
(bp
(gen-node
pre
after-pre-live
(make-reason-pred
con-live
alt-live)))
(true-context
(branchpoints-true-context bp))
(true-bb
(branchpoints-true-bb bp))
(false-context
(branchpoints-false-context bp))
(false-bb
(branchpoints-false-bb bp)))
(cond ((reason-tail? reason)
(restore-context true-context)
(set! *bb* true-bb)
(gen-node con live reason)
(restore-context false-context)
(set! *bb* false-bb)
(gen-node alt live reason))
((reason-pred? reason)
(restore-context true-context)
(set! *bb* true-bb)
(let* ((con-bp
(gen-node con live reason))
(con-true-context
(branchpoints-true-context con-bp))
(con-true-bb
(branchpoints-true-bb con-bp))
(con-false-context
(branchpoints-false-context con-bp))
(con-false-bb
(branchpoints-false-bb con-bp)))
(restore-context false-context)
(set! *bb* false-bb)
(let* ((alt-bp
(gen-node alt live reason))
(alt-true-context
(branchpoints-true-context alt-bp))
(alt-true-bb
(branchpoints-true-bb alt-bp))
(alt-false-context
(branchpoints-false-context alt-bp))
(alt-false-bb
(branchpoints-false-bb alt-bp)))
(join-execution-paths
node
(reason-pred-true-live reason)
(list (cons con-true-context con-true-bb)
(cons alt-true-context alt-true-bb)))
(let ((result-true-context (current-context))
(result-true-bb *bb*))
(join-execution-paths
node
(reason-pred-false-live reason)
(list (cons con-false-context con-false-bb)
(cons alt-false-context alt-false-bb)))
(let ((result-false-context (current-context))
(result-false-bb *bb*))
(make-branchpoints
result-true-context
result-true-bb
result-false-context
result-false-bb))))))
(else ; (or (reason-need? reason) (reason-side? reason))
(restore-context true-context)
(set! *bb* true-bb)
(let* ((con-alt-reason
(if (reason-side? reason)
reason
(make-reason-need #f)))
(con-opnd
(gen-node con live con-alt-reason))
(loc
(cond ((reason-side? reason)
target.proc-result)
((reg? con-opnd)
con-opnd)
(else
(or (let ((hint-loc
(reason-need-hint-loc reason)))
(and hint-loc
(reg? hint-loc)
hint-loc))
(lowest-dead-reg live)
target.proc-result))))
(result-var
(make-temp-var 'result)))
(if (not (reason-side? con-alt-reason))
(save-opnd-to-reg con-opnd
loc
result-var
live
(node->comment con)))
(let ((con-context (current-context))
(con-bb *bb*))
(restore-context false-context)
(set! *bb* false-bb)
(let ((alt-opnd (gen-node alt live con-alt-reason)))
(if (not (reason-side? con-alt-reason))
(save-opnd-to-reg alt-opnd
loc
result-var
live
(node->comment alt)))
(let ((alt-context (current-context))
(alt-bb *bb*))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
#;
(let ()
(##namespace ("" with-output-to-string pp))
(pp (list (parse-tree->expression node)
LIVE:
(map var-name (varset->list live))
(list
RT:
(map (lambda (x) (if (var? x) (var-name x) x)) (context-regs true-context))
ST:
(map (lambda (x) (if (var? x) (var-name x) x)) (context-slots true-context)))
(list
R1:
(map (lambda (x) (if (var? x) (var-name x) x)) (context-regs con-context))
S1:
(map (lambda (x) (if (var? x) (var-name x) x)) (context-slots con-context)))
(list
RF:
(map (lambda (x) (if (var? x) (var-name x) x)) (context-regs false-context))
SF:
(map (lambda (x) (if (var? x) (var-name x) x)) (context-slots false-context)))
(list
R2:
(map (lambda (x) (if (var? x) (var-name x) x)) (context-regs alt-context))
S2:
(map (lambda (x) (if (var? x) (var-name x) x)) (context-slots alt-context))))))
(join-execution-paths
node
(if (reason-side? con-alt-reason)
live
(varset-adjoin live result-var))
(list (cons con-context con-bb)
(cons alt-context alt-bb)))
loc)))))))))
(define (join-execution-paths node live context-bb-list)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
#;
(define (order context-bb1 context-bb2)
; order the contexts so that the first is the one with the most
; live variables in registers.
(define (nb-live-vars lst)
(let ((live-v (live-vars live)))
(let loop ((lst lst)
(vars (varset-empty)))
(if (pair? lst)
(let ((v (car lst)))
(if (and v (varset-member? v live-v))
(loop (cdr lst)
(varset-adjoin vars v))
(loop (cdr lst)
vars)))
(length (varset->list vars))))))
(let* ((context1 (car context-bb1))
(context2 (car context-bb2))
(nb-live1 (nb-live-vars (context-regs context1)))
(nb-live2 (nb-live-vars (context-regs context2))))
(>= nb-live1 nb-live2)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (order context-bb1 context-bb2)
(let* ((context1 (car context-bb1))
(context2 (car context-bb2))
(nb-slots1 (context-nb-slots context1))
(nb-slots2 (context-nb-slots context2)))
(> nb-slots1 nb-slots2)))
(let ((ordered-context-bb-vector
(list->vector
(sort-list context-bb-list order))))
(define (join-range start end)
(if (= start end)
(vector-ref ordered-context-bb-vector start)
(let* ((mid (quotient (+ start end) 2))
(context-bb1 (join-range start mid))
(context-bb2 (join-range mid end)))
(join-execution-paths-aux
node
live
(car context-bb1)
(cdr context-bb1)
(car context-bb2)
(cdr context-bb2))
(cons (current-context)
*bb*))))
(join2 node
live
(car (vector-ref ordered-context-bb-vector 0))
(cdr (vector-ref ordered-context-bb-vector 0))
(car (vector-ref ordered-context-bb-vector 1))
(cdr (vector-ref ordered-context-bb-vector 1)))))
(define (join2 node live context1 bb1 context2 bb2)
; order the contexts so that the first is the one with the most
; live variables in registers.
(define (nb-live-vars lst)
(let ((live-v (live-vars live)))
(let loop ((lst lst)
(vars (varset-empty)))
(if (pair? lst)
(let ((v (car lst)))
(if (and v (varset-member? v live-v))
(loop (cdr lst)
(varset-adjoin vars v))
(loop (cdr lst)
vars)))
(length (varset->list vars))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(if (> (context-nb-slots context1)
(context-nb-slots context2))
;; (if (>= (nb-live-vars (context-regs context1))
;; (nb-live-vars (context-regs context2)))
(join-execution-paths-aux2 node live context1 bb1 context2 bb2)
(join-execution-paths-aux2 node live context2 bb2 context1 bb1))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
#;
(if (> (context-nb-slots context1)
(context-nb-slots context2))
(join-execution-paths-aux node live context1 bb1 context2 bb2)
(join-execution-paths-aux node live context2 bb2 context1 bb1)))
(define (join-execution-paths-aux node live context1 bb1 context2 bb2)
(restore-context context2)
(set! *bb* bb2)
(seal-bb (intrs-enabled? (node-env node)) 'internal)
(let ((join-lbl (bbs-new-lbl! *bbs*)))
(bb-put-branch! *bb*
(make-jump (make-lbl join-lbl)
#f
#f
#f
(current-frame live)
(node->comment node)))
(let ((context2* (current-context)))
(restore-context context1)
(set! *bb* bb1)
(merge-contexts-and-seal-bb
context2*
live
(intrs-enabled? (node-env node))
'internal
(node->comment node))
(bb-put-branch! *bb*
(make-jump (make-lbl join-lbl)
#f
#f
#f
(current-frame live)
(node->comment node)))
(set! *bb* (make-bb
(make-label-simple
join-lbl
(current-frame live)
(node->comment node))
*bbs*)))))
(define (join-execution-paths-aux2 node live context1 bb1 context2 bb2)
(let ((live-v (live-vars live)))
(define (common lst1 lst2 common-vars)
(let loop ((lst1 lst1)
(lst2 lst2)
(common-vars common-vars))
(if (and (pair? lst1) (pair? lst2))
(let* ((v1 (car lst1))
(v2 (car lst2))
(r1 (cdr lst1))
(r2 (cdr lst2)))
(if (and (not (eq? v1 empty-var))
(not (eq? v2 empty-var))
(eq? v1 v2)
(varset-member? v1 live-v))
(loop r1
r2
(varset-adjoin common-vars v1))
(loop r1
r2
common-vars)))
common-vars)))
(define (displace lst1 lst2 n vars-in-new-context cont)
(let loop ((lst1 lst1)
(lst2 lst2)
(vars-in-new-context vars-in-new-context)
(rev-lst '())
(i 0))
(if (< i n)
(let* ((v1 (if (pair? lst1) (car lst1) empty-var))
(v2 (if (pair? lst2) (car lst2) empty-var))
(r1 (if (pair? lst1) (cdr lst1) '()))
(r2 (if (pair? lst2) (cdr lst2) '())))
(if (and (not (eq? v1 empty-var))
(not (eq? v2 empty-var))
(eq? v1 v2)
(varset-member? v1 live-v))
(loop r1
r2
vars-in-new-context ; v1 is already in vars-in-new-context
(cons v1 rev-lst)
(+ i 1))
(let* ((var1
(and (not (eq? v1 empty-var))
(varset-member? v1 live-v)
(not (varset-member? v1 vars-in-new-context))
v1))
(var2
(and (not (eq? v2 empty-var))
(varset-member? v2 live-v)
(not (varset-member? v2 vars-in-new-context))
v2)))
(cond (var1
(loop r1
r2
(varset-adjoin vars-in-new-context var1)
(cons var1 rev-lst)
(+ i 1)))
(var2
(loop r1
r2
(varset-adjoin vars-in-new-context var2)
(cons var2 rev-lst)
(+ i 1)))
(else
(loop r1
r2
vars-in-new-context
(cons empty-var rev-lst)
(+ i 1)))))))
(cont vars-in-new-context
rev-lst))))
(define (unused-slots slots)
(if (and (pair? slots)
(eq? (car slots) empty-var))
(+ 1 (unused-slots (cdr slots)))
0))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
#;
(let ()
(##namespace ("" pp))
(pp (list
'CONTEXT1
(list
R:
(map (lambda (x) (if (var? x) (var-name x) x)) (context-regs context1))
S:
(map (lambda (x) (if (var? x) (var-name x) x)) (context-slots context1))))))
#;
(let ()
(##namespace ("" pp))
(pp (list
'CONTEXT2
(list
R:
(map (lambda (x) (if (var? x) (var-name x) x)) (context-regs context2))
S:
(map (lambda (x) (if (var? x) (var-name x) x)) (context-slots context2))))))
(let* ((regs1
(context-regs context1))
(rev-slots1
(reverse (context-slots context1)))
(regs2
(context-regs context2))
(rev-slots2
(reverse (context-slots context2)))
(common-vars
(common
rev-slots1
rev-slots2
(common
regs1
regs2
(varset-empty))))
(min-nb-slots
(min (context-nb-slots context1)
(context-nb-slots context2)))
(max-nb-slots
(max (context-nb-slots context1)
(context-nb-slots context2))))
(displace
regs1
regs2
target.nb-regs
common-vars
(lambda (vars-in-new-context rev-new-regs)
(let ((new-regs (reverse rev-new-regs)))
(displace
rev-slots1
rev-slots2
max-nb-slots
vars-in-new-context
(lambda (vars-in-new-context new-slots)
(let* ((new-regs
(reverse rev-new-regs))
(new-nb-slots
(max min-nb-slots
(- max-nb-slots
(unused-slots new-slots))))
(new-context
(make-context new-nb-slots
(drop new-slots
(- max-nb-slots new-nb-slots))
new-regs
(context-closed context1)
(poll-merge
(context-poll context1)
(context-poll context2))
(context-entry-bb context1)))
(new-frame
(context->frame new-context live))
(join-lbl
(bbs-new-lbl! *bbs*)))
(define (join context bb)
(restore-context context)
(set! *bb* bb)
(let* ((nb-locs (+ 1 (+ target.nb-regs max-nb-slots)))
(from (make-vector nb-locs #f))
(to (make-vector nb-locs #f)))
(define (from-to i j)
(vector-set! from i j)
(vector-set! to j i))
(define (location var)
(or (pos-in-list var regs)
(let ((n (pos-in-list var slots)))
(if n
(+ target.nb-regs (- nb-slots (+ n 1)))
(compiler-internal-error
"join-execution-paths-aux2, unknown location")))))
(define (find-loc kind start end)
(let loop ((i start))
(if (< i end)
(if (eq? kind (vector-ref to i))
i
(loop (+ i 1)))
#f)))
(let loop1 ((lst new-regs)
(i 0))
(if (pair? lst)
(let ((new-v (car lst)))
(if (not (eq? new-v empty-var))
(from-to
i
(if (eq? new-v (reg->var regs i))
i
(location new-v))))
(loop1 (cdr lst)
(+ i 1)))))
(let loop2 ((lst (reverse new-slots))
(i 0))
(if (pair? lst)
(let ((new-v (car lst)))
(if (not (eq? new-v empty-var))
(from-to
(+ target.nb-regs i)
(if (eq? new-v (stk->var regs (+ i 1)))
(+ target.nb-regs i)
(location new-v))))
(loop2 (cdr lst)
(+ i 1)))))
(let* ((chains
(let loop3 ((i 0) (chains '()))
(define (build-chain i)
(if i
(let ((next (vector-ref from i)))
(vector-set! from i #f)
(vector-set! to i 'chain)
(cons i (build-chain next)))
'()))
(if (< i nb-locs)
(loop3 (+ i 1)
(if (and (vector-ref from i)
(not (vector-ref to i)))
(cons (build-chain i)
chains)
chains))
chains)))
(cycles
(let loop4 ((i 0) (cycles '()))
(define (build-cycle i)
(cons i
(let ((next (vector-ref from i)))
(vector-set! from i #f)
(vector-set! to i 'cycle)
(if (vector-ref from next)
(build-cycle next)
'()))))
(if (< i nb-locs)
(loop4 (+ i 1)
(if (and (vector-ref from i)
(not (= (vector-ref from i)
i)))
(cons (build-cycle i)
cycles)
cycles))
cycles)))
(temp
(if (null? cycles)
#f
(or (find-loc 'chain 0 target.nb-regs)
(find-loc #f 0 target.nb-regs)
(find-loc 'chain target.nb-regs nb-locs)
(find-loc #f target.nb-regs nb-locs))))
(output '()));;;;;;;;;;;;;;;;;;;;
(define (loc->opnd loc)
(if (< loc target.nb-regs)
(make-reg loc)
(make-stk (+ 1 (- loc target.nb-regs)))))
(define (copy src dst)
(let ((s (loc->opnd src))
(d (loc->opnd dst))
(comment (node->comment node)))
(if (and (stk? d) (> (stk-num d) nb-slots))
(begin
(extend-slots (- (stk-num d) 1) live comment)
(push-slot)))
(put-var d (get-var s))
(set! output (cons (list dst '<- src) output))
(zzzbb-put-non-branch! *bb* "IN join-execution-paths-aux2"
(make-copy s
d
(current-frame live)
comment))))
(define (do-cycles)
(for-each
(lambda (cycle)
(let ((dst1 (car cycle)))
(copy dst1 temp)
(let loop ((dst dst1)
(rest (cdr cycle)))
(if (pair? rest)
(let ((src (car rest)))
(copy src dst)
(loop src (cdr rest)))
(copy temp dst)))))
cycles)
(set! temp #f))
(define (do-chains)
(for-each
(lambda (chain)
(let ((dst1 (car chain)))
(let loop ((dst dst1)
(rest (cdr chain)))
(if (eqv? dst temp)
(do-cycles))
(if (pair? rest)
(let ((src (car rest)))
(copy src dst)
(loop src (cdr rest)))))))
chains))
(do-chains)
(if temp (do-cycles))
(adjust-slots new-nb-slots
live
(node->comment node))
(seal-bb (intrs-enabled? (node-env node)) 'internal)
(bb-put-branch! *bb*
(make-jump (make-lbl join-lbl)
#f
#f
#f
new-frame
(node->comment node)))
(cons (current-context) *bb*))))
(let* ((c1 (join context1 bb1))
(c2 (join context2 bb2)))
(restore-context new-context)
(set! *bb* (make-bb
(make-label-simple
join-lbl
new-frame
(node->comment node))
*bbs*))
;;;;;;;;;;;;;;;;;;;;;;;;;
#;
(let ()
(##namespace ("" pp))
(pp (list
'EXIT
(list
R:
(map (lambda (x) (if (var? x) (var-name x) x)) regs)
S:
(map (lambda (x) (if (var? x) (var-name x) x)) slots)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;
'
(let* ((context1 (car c1))
(bb1 (cdr c1))
(context2 (car c2))
(bb2 (cdr c2)))
(if (> (context-nb-slots context1)
(context-nb-slots context2))
(join-execution-paths-aux node live context1 bb1 context2 bb2)
(join-execution-paths-aux node live context2 bb2 context1 bb1)))))))))))))
;; '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 poll? where comment)
;(display "*************")(newline);*************
;(display "1 regs : ")(pp (map (lambda (x) (if (var? x) (var-name x) x)) regs))
;(display "1 slots : ")(pp (map (lambda (x) (if (var? x) (var-name x) x)) slots))
;(display "2 regs : ")(pp (map (lambda (x) (if (var? x) (var-name x) x)) (context-regs other-context)))
;(display "2 slots : ")(pp (map (lambda (x) (if (var? x) (var-name x) x)) (context-slots other-context)))
(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-poll (context-poll other-context))
(other-entry-bb (context-entry-bb other-context)))
(let loop1 ((i (- target.nb-regs 1)))
;(display "r regs : ")(pp (map (lambda (x) (if (var? x) (var-name x) x)) regs));*************
;(display "r slots : ")(pp (map (lambda (x) (if (var? x) (var-name x) x)) slots))
(if (>= i 0)
(let ((other-var (reg->var other-regs i)) ; #f if no var
(var (reg->var regs i))) ; #f if no var
(if (and other-var
(not (eq? var other-var)) ; if var not there and must keep
(varset-member? other-var live-v)) ; other-var somewhere
(let ((r (make-reg i)))
(put-var r empty-var)
(if (and var
(varset-member? var live-v) ; register's value is needed
(not (memq var regs)) ; and not in any other
(not (memq var slots))) ; register or stack slot
(let ((top (make-stk (+ nb-slots 1)))) ; save on top of stack
(put-copy 5 r top var live-v comment)))
(put-copy 6 (var->opnd other-var) r other-var live-v comment)))
(loop1 (- i 1)))))
(let loop2 ((i 1))
;(display "s regs : ")(pp (map (lambda (x) (if (var? x) (var-name x) x)) regs));*************
;(display "s slots : ")(pp (map (lambda (x) (if (var? x) (var-name x) x)) slots))
(if (<= i other-nb-slots)
(let ((other-var (stk->var other-slots i)) ; #f if no var
(var (stk->var slots i))) ; #f if no var
(if (and other-var
(not (eq? var other-var)) ; if var not there and must keep
(varset-member? other-var live-v)) ; other-var somewhere
(let ((s (make-stk i)))
(if (<= i nb-slots) (put-var s empty-var))
;(display "S regs : ")(pp (map (lambda (x) (if (var? x) (var-name x) x)) regs));*************
;(display "S slots : ")(pp (map (lambda (x) (if (var? x) (var-name x) x)) slots))
(if (and var
(varset-member? var live-v) ; slot's value is needed
(not (memq var regs)) ; and not in any other
(not (memq var slots))) ; register or stack slot
(let ((top (make-stk (+ nb-slots 1)))) ; save on top of stack
(put-copy 7 s top var live-v comment)))
;(display "Z regs : ")(pp (map (lambda (x) (if (var? x) (var-name x) x)) regs));*************
;(display "Z slots : ")(pp (map (lambda (x) (if (var? x) (var-name x) x)) slots))
(put-copy 8 (var->opnd other-var) s other-var live-v comment))
(if (> i nb-slots)
(let ((top (make-stk (+ nb-slots 1))))
(put-copy 9 (make-obj void-object)
top
empty-var
live-v
comment))))
(loop2 (+ i 1)))))
; It is OK to shrink because other-nb-slots <= nb-slots
(shrink-slots other-nb-slots)
(let loop3 ((i (- target.nb-regs 1)))
(if (>= i 0)
(let ((other-var (reg->var other-regs i)) ; #f if no var
(var (reg->var regs i))) ; #f if no var
(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)) ; #f if no var
(var (stk->var slots i))) ; #f if no var
(if (not (eq? var other-var))
(put-var (make-stk i) empty-var))
(loop4 (+ i 1)))))
(seal-bb poll? where)
(set! poll (poll-merge poll other-poll))
;(display "3 regs : ")(pp (map (lambda (x) (if (var? x) (var-name x) x)) regs));*************
;(display "3 slots : ")(pp (map (lambda (x) (if (var? x) (var-name x) x)) slots))
(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 poll? where)
(define (poll-at split-point)
(let loop ((i 0)
(lst1 (bb-non-branch-instrs *bb*))
(lst2 '()))
(if (and (pair? lst1)
(or (< i split-point)
(let* ((instr
(car lst1))
(node
(comment-get (gvm-instr-comment instr) 'node))
(cant-poll-here?
(not (intrs-enabled? (node-env node)))))
;; extend poll interval to outside code that
;; is with interrupts disabled
cant-poll-here?)))
(loop (+ i 1)
(cdr lst1)
(cons (car lst1) lst2))
(let* ((label-instr
(bb-label-instr *bb*))
(non-branch-instrs1
(reverse lst2))
(non-branch-instrs2
lst1)
(last-instr
(car (last-pair (cons label-instr non-branch-instrs1))))
(frame
(gvm-instr-frame last-instr))
(new-lbl
(bbs-new-lbl! *bbs*)))
(bb-non-branch-instrs-set! *bb* non-branch-instrs1)
(bb-put-branch! *bb*
(make-jump (make-lbl new-lbl)
#f
#t
#f
frame
(gvm-instr-comment last-instr)))
(set! *bb* (make-bb (make-label-simple
new-lbl
frame
(gvm-instr-comment last-instr))
*bbs*))
(bb-non-branch-instrs-set! *bb* non-branch-instrs2)
(set! poll (make-poll #t 0))))))
(define (poll-at-end)
(poll-at (length (bb-non-branch-instrs *bb*))))
(define (impose-polling-constraints)
(let ((n (+ (length (bb-non-branch-instrs *bb*)) 1))
(delta (poll-delta poll)))
(if (> (+ delta n) poll-period)
(begin
(poll-at (max (- poll-period delta) 0))
(impose-polling-constraints)))))
(if poll? (impose-polling-constraints))
(let* ((n (+ (length (bb-non-branch-instrs *bb*)) 1))
(delta (+ (poll-delta poll) n))
(since-entry? (poll-since-entry? poll)))
(if (and poll?
(case where
((call)
(> delta (- poll-period poll-head)))
((tail-call)
(> delta poll-tail))
((return)
(and since-entry? (> delta (+ poll-head poll-tail))))
((internal)
#f)
(else
(compiler-internal-error "seal-bb, unknown 'where':" where))))
(poll-at-end)
(set! poll (make-poll since-entry? delta)))))
(define (reg->var regs i)
(cond ((null? regs)
#f)
((> i 0)
(reg->var (cdr regs) (- i 1)))
(else
(car regs))))
(define (stk->var slots i)
(let ((j (- (length slots) i)))
(if (< j 0)
#f
(list-ref slots j))))
;;;----------------------------------------------------------------------------
;;
;; generate code for a conjunction or disjunction
(define (gen-conj/disj node live reason)
(let ((is-conj? (conj? node)))
(define (gen-node* node live reason)
(if is-conj?
(gen-node node live reason)
(branchpoints-invert
(gen-node node live (reason-pred-invert reason)))))
(define (gen-conj/disj-pred pre alt live reason)
(let* ((alt-fv
(bound-free-variables alt))
(alt-live
(varset-union live alt-fv))
(bp
(gen-node*
pre
alt-live
(make-reason-pred
alt-live
(reason-pred-false-live reason))))
(true-context
(branchpoints-true-context bp))
(true-bb
(branchpoints-true-bb bp))
(false-context
(branchpoints-false-context bp))
(false-bb
(branchpoints-false-bb bp)))
(restore-context true-context)
(set! *bb* true-bb)
(let* ((alt-bp
(gen-node* alt live reason))
(alt-true-context
(branchpoints-true-context alt-bp))
(alt-true-bb
(branchpoints-true-bb alt-bp))
(alt-false-context
(branchpoints-false-context alt-bp))
(alt-false-bb
(branchpoints-false-bb alt-bp)))
(join-execution-paths
node
(reason-pred-false-live reason)
(list (cons false-context false-bb)
(cons alt-false-context alt-false-bb)))
(make-branchpoints
alt-true-context
alt-true-bb
(current-context)
*bb*))))
(define (gen-conj/disj-value pre alt live reason)
(let ((result-var (make-temp-var 'result)))
(define (gen-node-value* node live reason)
(if is-conj?
(gen-node-value node live reason)
(branchpoints-invert
(gen-node-value node live (reason-pred-invert reason)))))
(define (gen-node-value node live reason)
(save-opnd-to-reg (gen-node node
live
(make-reason-need
target.proc-result))
target.proc-result
result-var
live
(node->comment node))
(seal-bb (intrs-enabled? (node-env node)) 'internal)
(let* ((true-lbl
(bbs-new-lbl! *bbs*))
(false-lbl
(bbs-new-lbl! *bbs*))
(true-bb
(make-bb
(make-label-simple
true-lbl
(current-frame (reason-pred-true-live reason))
(node->comment node))
*bbs*))
(false-bb
(make-bb
(make-label-simple
false-lbl
(current-frame (reason-pred-false-live reason))
(node->comment node))
*bbs*)))
(bb-put-branch! *bb*
(make-ifjump
**not-proc-obj
(list target.proc-result)
false-lbl
true-lbl
#f
(current-frame (varset-adjoin live result-var))
(node->comment node)))
(let ((context (current-context)))
(make-branchpoints context true-bb context false-bb))))
(let* ((bool-pre?
(boolean-value? pre))
(alt-fv
(bound-free-variables alt))
(alt-live
(varset-union live alt-fv))
(bp
(if bool-pre?
(gen-node*
pre
alt-live
(make-reason-pred
alt-live
live))
(gen-node-value*
pre
alt-live
(make-reason-pred
alt-live
(varset-adjoin live result-var)))))
(true-context
(branchpoints-true-context bp))
(true-bb
(branchpoints-true-bb bp))
(false-context
(branchpoints-false-context bp))
(false-bb
(branchpoints-false-bb bp)))
(restore-context true-context)
(set! *bb* true-bb)
(let ((alt-opnd (gen-node alt live reason)))
(if (and (not (reason-tail? reason))
(not (reason-side? reason)))
(save-opnd-to-reg alt-opnd
target.proc-result
result-var
live
(node->comment alt)))
(let ((alt-context (current-context))
(alt-bb *bb*))
(restore-context false-context)
(set! *bb* false-bb)
(if (and bool-pre?
(not (reason-side? reason)))
(save-opnd-to-reg (make-obj (if is-conj? false-object #t))
target.proc-result
result-var
live
(node->comment node)))
(if (reason-tail? reason)
(gen-return node live reason target.proc-result)
(begin
(join-execution-paths
node
(if (reason-side? reason)
live
(varset-adjoin live result-var))
(list (cons (current-context) *bb*)
(cons alt-context alt-bb)))
target.proc-result)))))))
(if (reason-pred? reason)
(if is-conj?
(gen-conj/disj-pred
(conj-pre node)
(conj-alt node)
live
reason)
(branchpoints-invert
(gen-conj/disj-pred
(disj-pre node)
(disj-alt node)
live
(reason-pred-invert reason))))
(if is-conj?
(gen-conj/disj-value
(conj-pre node)
(conj-alt node)
live
reason)
(gen-conj/disj-value
(disj-pre node)
(disj-alt node)
live
reason)))))
;;;----------------------------------------------------------------------------
;;
;; generate code for a procedure call
(define (gen-call node live reason)
(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'
(prc-req-and-opt-parms-only? oper)
(= (length (prc-parms oper)) nb-args))
(gen-let oper args live reason)
(let ((proc (app->specialized-proc node)))
(if (and proc
(or ((proc-obj-inlinable? proc) (node-env node))
(and (reason-pred? reason)
((proc-obj-testable? proc) (node-env node)))))
(if (and (reason-pred? reason)
(eq? proc **not-proc-obj))
(branchpoints-invert
(gen-node (car args)
live
(reason-pred-invert reason)))
(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
(make-reason-need #f))
(make-temp-var pos)
needed
(node->comment arg))))
(set-cdr! (assq arg vars) var)
(loop (cdr l) (varset-adjoin liv var)))
(if (and (reason-pred? reason)
((proc-obj-testable? proc) (node-env node)))
(let ((args (map var->opnd (map cdr vars))))
(gen-conditional node live reason proc args))
(let ((loc
(if (reason-side? reason)
target.proc-result
(or (and (reason-need? reason)
(let ((hint-loc
(reason-need-hint-loc reason)))
(and hint-loc
(dead-reg/stk? hint-loc live)
hint-loc)))
(lowest-dead-reg live)
(lowest-dead-slot live)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
#;
(let ()
(##namespace ("" with-output-to-string pp))
(pp (list (parse-tree->expression node)
(map var-name (varset->list live))
(with-output-to-string "" (lambda () (write-gvm-opnd loc (current-output-port))))
(with-output-to-string "" (lambda () (write-gvm-opnd (lowest-dead-reg live) (current-output-port))))
regs:
(map (lambda (x) (if (var? x) (var-name x) x)) regs)
slots:
(map (lambda (x) (if (var? x) (var-name x) x)) slots)
)))
(if (and (not (reason-side? reason))
(stk? loc)
(> (stk-num loc) nb-slots))
(begin
(extend-slots (- (stk-num loc) 1)
live
(node->comment node))
(push-slot)))
(let* ((args (map var->opnd (map cdr vars)))
(var (make-temp-var 'result)))
(if (not (reason-side? reason))
(put-var loc var))
(zzzbb-put-non-branch! *bb* "IN gen-call"
(make-apply
proc
args
(if (reason-side? reason) #f loc)
(current-frame
(if (reason-side? reason)
live
(varset-adjoin live var)))
(node->comment node)))
(gen-return node live reason loc))))))))
(let* ((reason2
(if (and (reason-tail? reason)
(not (proper-tail-calls? (node-env node))))
(make-reason-need target.proc-result)
reason))
(local-proc-info
(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-info (cdr x))
(proc (proc-info-proc proc-info)))
(and (prc-req-and-opt-parms-only? proc)
(= (length (prc-parms proc))
nb-args)
proc-info))))))))
(jstate
(if local-proc-info
(proc-info->jump-state local-proc-info args)
(args->jump-state args)))
(in-stk
(jump-state-in-stk jstate))
(in-reg
(jump-state-in-reg jstate))
(eval-order
(arg-eval-order
(if (or local-proc-info proc) #f oper)
in-reg))
(live-after
(if (reason-tail? reason2)
(varset-empty)
live))
(live-vars-at-each-reg
(compute-live-vars-at-each-expr
live-after
(map car eval-order)
(make-reason-tail)))
(return-lbl
(if (reason-tail? reason2) #f (bbs-new-lbl! *bbs*)))
(live-vars-at-each-slot
(compute-live-vars-at-each-expr
(car live-vars-at-each-reg)
in-stk
reason2))
(where
(if (reason-tail? reason2)
'tail-call
(if proc 'internal 'call))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
#;
(let ()
(##namespace ("" with-output-to-string pp))
(pp (list (parse-tree->expression node)
LIVE1:
(map var-name (varset->list live))
(list
R:
(map (lambda (x) (if (var? x) (var-name x) x)) regs)
S: nb-slots
(map (lambda (x) (if (var? x) (var-name x) x)) slots)))))
; save regs on stack if they contain values needed after the call
(save-regs-to-stk (live-regs live-after)
(car live-vars-at-each-slot)
(node->comment node))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
#;
(let ()
(##namespace ("" with-output-to-string pp))
(pp (list (parse-tree->expression node)
LIVE2:
(map var-name (varset->list live))
(list
R:
(map (lambda (x) (if (var? x) (var-name x) x)) regs)
S: nb-slots
(map (lambda (x) (if (var? x) (var-name x) x)) slots)))))
(let* ((top-live-slot
(stk-num (highest-live-slot live-after)))
(frame-start
(if (reason-tail? reason2)
top-live-slot
(let ((frame-reserve
(frame-constraints-reserve
target.frame-constraints))
(frame-align
(frame-constraints-align
target.frame-constraints)))
(* (quotient (+ (+ top-live-slot frame-reserve)
(- frame-align 1))
frame-align)
frame-align)))))
(let loop1 ((l
in-stk)
(liv
live-after)
(live-vars-at-next-slots
(cdr live-vars-at-each-slot))
(i
(+ frame-start 1)))
(if (not (null? l))
; ==== FIRST: evaluate arguments that go onto stack
(let ((arg (car l))
(slot (make-stk i))
(needed (varset-union liv
(car live-vars-at-next-slots))))
(if arg
(if (and (ref? arg)
(<= i nb-slots)
(eq? (ref-var arg) (get-var slot)))
(loop1 (cdr l)
(varset-adjoin liv (ref-var arg))
(cdr live-vars-at-next-slots)
(+ i 1))
(let ((var (if (and (eq? arg 'return)
(reason-tail? reason2))
ret-var
(make-temp-var (- frame-start i)))))
(save-opnd-to-stk (if (eq? arg 'return)
(if (reason-tail? reason2)
(var->opnd ret-var)
(make-lbl return-lbl))
(gen-node arg
needed
(make-reason-need
slot)))
slot
var
needed
(node->comment
(if (eq? arg 'return)
node
arg)))
(loop1 (cdr l)
(varset-adjoin liv var)
(cdr live-vars-at-next-slots)
(+ i 1))))
(begin
(if (> i nb-slots)
(put-copy 10 (make-obj void-object)
slot
empty-var
liv
(node->comment node)))
(loop1 (cdr l)
liv
(cdr live-vars-at-next-slots)
(+ i 1)))))
(let ((reg-map (make-stretchable-vector #f)))
(let loop2 ((l
eval-order)
(liv
liv)
(live-vars-at-next-regs
(cdr live-vars-at-each-reg))
(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
(varset-union liv (car live-vars-at-next-regs)))
(var (if (and (eq? arg 'return)
(reason-tail? reason2))
ret-var
(make-temp-var pos)))
(opnd (if (eq? arg 'return)
(if (reason-tail? reason2)
(var->opnd ret-var)
(make-lbl return-lbl))
(gen-node arg
needed
(make-reason-need
(if (eq? pos 'operator)
#f
(make-reg pos)))))))
(if (eq? pos 'operator)
; operator
(if (and (ref? arg)
(not (or (obj? opnd) (lbl? opnd))))
(loop2 (cdr l)
(varset-adjoin liv (ref-var arg))
(cdr live-vars-at-next-regs)
(ref-var arg))
(begin
(save-arg opnd
var
needed
(node->comment
(if (eq? arg 'return)
node
arg)))
(loop2 (cdr l)
(varset-adjoin liv var)
(cdr live-vars-at-next-regs)
var)))
; return address or argument
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
#;
(begin
(save-val opnd
var
needed
(node->comment
(if (eq? arg 'return)
node
arg)))
(stretchable-vector-set! reg-map pos var)
(loop2 (cdr l)
(varset-adjoin liv var)
(cdr live-vars-at-next-regs)
oper-var))
(let ((reg (make-reg pos)))
(if (all-args-trivial? (cdr l))
(save-opnd-to-reg opnd
reg
var
needed
(node->comment
(if (eq? arg 'return)
node
arg)))
(save-in-slot 111 opnd
var
needed
(node->comment
(if (eq? arg 'return)
node
arg))))
(stretchable-vector-set! reg-map pos var)
(loop2 (cdr l)
(varset-adjoin liv var)
(cdr live-vars-at-next-regs)
oper-var))
))
(let loop3 ((i (- target.nb-regs 1)))
(if (>= i 0)
; ==== THIRD: reload spilled registers
(let ((var (stretchable-vector-ref reg-map i)))
(if var
(let ((var-i (reg->var regs i))) ; #f if no var
(if (or (not var-i) (not (eq? var-i var)))
(save-opnd-to-reg (var->opnd var)
(make-reg i)
var
liv
(node->comment node)))))
(loop3 (- i 1)))
; ==== FOURTH: jump to procedure
(let ((opnd
(cond (local-proc-info
(make-lbl
(proc-info-lbl2 local-proc-info)))
(proc
(make-obj proc))
(else
(var->opnd oper-var)))))
(adjust-slots
(+ frame-start (length in-stk))
liv
(node->comment node))
(if (not (reason-tail? reason2))
(let ((frame-reserve
(frame-constraints-reserve
target.frame-constraints)))
(let loop4 ((i (- frame-reserve 1)))
(if (>= i 0)
(begin
(put-var (make-stk (- frame-start i))
empty-var)
(loop4 (- i 1)))))))
(seal-bb (intrs-enabled? (node-env node)) where)
(if (and (not (intrs-enabled? (node-env node)))
(not (reason-tail? reason2))
(warnings? (node-env node)))
(compiler-user-warning
(source-locat (node-source node))
"Nontail call with interrupts disabled"))
(bb-put-branch! *bb*
(make-jump
opnd
(if local-proc-info #f nb-args)
#f
(safe? (node-env node))
(current-frame liv)
(node->comment node)))
; ==== FIFTH: put return label if there is one
(let ((result-var (make-temp-var 'result)))
(shrink-slots frame-start)
(flush-regs)
(put-var target.proc-result result-var)
(if (reason-tail? reason2)
target.proc-result
(begin
(set! poll (return-poll poll where))
(set! *bb*
(make-bb
(make-label-return
return-lbl
(current-frame
(varset-adjoin live result-var))
(node->comment node))
*bbs*))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
#;
(let ()
(##namespace ("" with-output-to-string pp))
(pp (list (parse-tree->expression node)
LIVE:
(map var-name (varset->list live))
(list
R:
(map (lambda (x) (if (var? x) (var-name x) x)) regs)
S:
(map (lambda (x) (if (var? x) (var-name x) x)) slots)))))
(gen-return node live reason 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
(varset-adjoin needed (get-var x))
needed)))
(define (save-opnd opnd live comment)
(let ((dest (or ;(highest-dead-reg live) ; it is better to not use registers
(lowest-dead-slot live))))
(put-copy 12 opnd dest (get-var opnd) live comment)))
(define (save-regs-to-stk regs live comment)
(for-each (lambda (i)
(let ((slot (lowest-dead-slot live))
(opnd (make-reg i)))
(put-copy 13 opnd slot (get-var opnd) live comment)))
regs))
(define (save-opnd-to-reg opnd reg var live comment)
(let ((reg-var (reg->var regs (reg-num reg))))
(if (and reg-var
(live-reg-var? reg-var (live-vars live)))
(save-opnd reg (opnd-needed opnd live) comment))
(put-copy 14 opnd reg var live comment)))
(define (save-opnd-to-stk opnd stk var live comment)
(if (memq (stk-num stk) (live-slots live))
(save-opnd stk (opnd-needed opnd live) comment))
(put-copy 15 opnd stk var live comment))
(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 (app? node)
(let ((proc (app->specialized-proc node)))
(and proc ((proc-obj-inlinable? proc) (node-env node))))
(every-trivial? (app-args node)))))
(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 (app->specialized-proc node)))
(if proc
(eq? (type-name (proc-obj-type proc)) 'boolean)
#f))
#f))
(define (pcontext->jump-state pcontext args)
(let ((pcontext pcontext))
(define (empty-node-list n)
(if (> n 0)
(cons #f (empty-node-list (- n 1)))
'()))
(let* ((fs (pcontext-fs pcontext))
(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)
(drop regs-list i)
(compiler-internal-error
"jump-state, reg out of range"))))
((stk? loc)
(let ((i (stk-num loc)))
(if (<= i fs)
(drop slots-list (- i 1))
(compiler-internal-error
"jump-state, stk out of range"))))
(else
(compiler-internal-error
"jump-state, loc other than reg or stk")))))
(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 pcontext)))
(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)))))
(make-jump-state slots-list regs-list))))
(define (args->jump-state args)
(pcontext->jump-state (target.jump-info (length args)) args))
(define (proc-info->jump-state proc-info args)
(let* ((proc (proc-info-proc proc-info))
(context (proc-info-context proc-info))
(parms (prc-parms proc)))
'(pp (list '********9 (map var-name parms)
(context-nb-slots context)
(map (lambda (x) (and x (var-name x))) (context-slots context))
(map (lambda (x) (and x (var-name x))) (context-regs context))))
(pcontext->jump-state (proc-info-pcontext proc-info) args)))
(define (make-jump-state in-stk in-reg) (vector in-stk in-reg))
(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)
(varset-empty)
(bound-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 loop ((l (varset->list (free-v node))) (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 (varset->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)))))))
(for-each (lambda (x)
(for-each add-to-bin! (varset->list (free-v (car x)))))
l)
(if (> (length l) 10) ; if many arguments just use left to right order
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 (remq best-arg args) (cons best-arg ordered-args)))))))))
(define (compute-live-vars-at-each-expr live exprs reason)
(if (null? exprs)
(list live)
(let* ((live-vars-at-next-exprs
(compute-live-vars-at-each-expr live (cdr exprs) reason))
(live-after
(car live-vars-at-next-exprs)))
(cond ((not (car exprs))
(cons live-after
live-vars-at-next-exprs))
((eq? (car exprs) 'return)
(cons (if (reason-tail? reason)
(varset-adjoin live-after ret-var)
live-after)
live-vars-at-next-exprs))
(else
(cons (varset-union live-after (bound-free-variables (car exprs)))
live-vars-at-next-exprs))))))
;;;----------------------------------------------------------------------------
;;
;; generate code for a 'let' or 'letrec'
(define (gen-let proc vals live reason)
(let* ((live (varset-union live (proc-body-live-varset proc)))
(vars (prc-parms proc))
(node (prc-body proc))
(var-val-map (pair-up vars vals))
(var-set (list->varset vars))
(all-live
(varset-union-multi
(cons live
(cons (bound-free-variables node)
(map bound-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)
(varset-difference (not-constant-closed-vars (var->val var))
const-proc-vars))
(define (no-closed-vars? var const-proc-vars)
(varset-empty? (closed-vars var const-proc-vars)))
(define (closed-vars? var const-proc-vars)
(not (no-closed-vars? var const-proc-vars)))
(define (optional-closure? var)
(or (ptset-every? oper-pos? (var-refs var))
(not (generative-lambda? (node-env (var->val var))))))
(define (compute-const-proc-vars proc-vars)
(let loop1 ((const-proc-vars proc-vars))
(let ((new-const-proc-vars
(list->varset
(keep (lambda (x) (no-closed-vars? x const-proc-vars))
(varset->list const-proc-vars)))))
(if (= (varset-size new-const-proc-vars)
(varset-size const-proc-vars))
const-proc-vars
(loop1 new-const-proc-vars)))))
(let* ((proc-vars-list
(keep proc-var? (varset->list var-set)))
(proc-vars
(list->varset proc-vars-list))
(proc-vars-with-optional-closure-list
(keep optional-closure? proc-vars-list))
(proc-vars-with-optional-closure
(list->varset proc-vars-with-optional-closure-list))
(const-proc-vars
(compute-const-proc-vars proc-vars-with-optional-closure))
(clo-vars
(varset-difference proc-vars const-proc-vars))
(clo-vars-list
(varset->list clo-vars)))
(for-each
(lambda (proc-var)
(let* ((proc-info (schedule-gen-proc (var->val proc-var) #f))
(proc-lbl (make-lbl (proc-info-lbl1 proc-info))))
(add-known-proc proc-info)
(add-constant-var proc-var proc-lbl)))
(varset->list const-proc-vars))
(let ((non-clo-vars-list
(keep (lambda (var)
(and (not (varset-member? var const-proc-vars))
(not (varset-member? var clo-vars))))
(varset->list var-set)))
(liv
(varset-union-multi
(cons live
(cons (bound-free-variables node)
(map (lambda (x)
(closed-vars x const-proc-vars))
clo-vars-list))))))
(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 (make-reason-side))
(save-val (gen-node val
needed
(make-reason-need #f ;;;;;;;;;;;is this good?
#; target.proc-result))
var
needed
(node->comment val)))
(loop2 (cdr vars*)))))
(if (pair? clo-vars-list)
(begin
(shrink-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))))))
(zzzbb-put-non-branch! *bb* "IN gen-let"
(make-close
(map (lambda (var)
(let* ((closed-list
(sort-variables
(varset->list
(closed-vars var const-proc-vars))))
(proc-info
(schedule-gen-proc (var->val var) closed-list)))
(make-closure-parms
(var->opnd var)
(proc-info-lbl1 proc-info)
(map var->opnd closed-list))))
clo-vars-list)
(current-frame liv)
(node->comment node)))))
(gen-node node live reason)))))
(define (save-arg opnd var live comment)
(if (glo? opnd)
(add-constant-var var opnd)
(save-val opnd var live comment)))
(define (save-val opnd var live comment)
(cond ((or (obj? opnd) (lbl? opnd))
(add-constant-var var opnd))
((and (reg? opnd)
(let ((opnd-var (reg->var regs (reg-num opnd))))
(or (not opnd-var)
(not (live-reg-var? opnd-var (live-vars live))))))
(put-var opnd var))
((and (stk? opnd)
(not (memq (stk-num opnd) (live-slots live))))
(put-var opnd var))
(else
(save-in-slot 222 opnd var live comment))))
(define (save-in-slot n opnd var live comment);;;;;;;;;;;;;;;;;;;;;;;;;
(let ((slot (lowest-dead-slot live)))
(put-copy n opnd slot var live comment)))
(define (save-var opnd var live comment)
(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 17 opnd dest var live comment)
var))))
(define (put-copy n opnd loc var live comment);;;;;;;;;;;;;;;;;;;;;;;
(if (and (stk? loc) (> (stk-num loc) nb-slots))
(begin
(extend-slots (- (stk-num loc) 1) live comment)
(push-slot)))
(if var (put-var loc var))
(if (not (eq? opnd loc))
(zzzbb-put-non-branch! *bb* (string-append "IN put-copy " (number->string n))
(make-copy opnd
loc
(current-frame (if var (varset-adjoin live var) live))
comment))))
(define (var-useless? var)
(and (ptset-empty? (var-refs var))
(ptset-empty? (var-sets var))))
(define (vals-live-vars live vals)
(if (null? vals)
live
(vals-live-vars (varset-union live (bound-free-variables (car vals)))
(cdr vals))))
;;;----------------------------------------------------------------------------
;;
;; generate code for a future
(define (gen-fut node live reason)
(let* ((val (fut-val node))
(clo-vars (not-constant-closed-vars val))
(clo-vars-list (varset->list clo-vars))
(ret-var* (make-temp-var 0))
(live-after live)
(live-starting-task (varset-adjoin (varset-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-to-stk (live-regs live-after)
live-starting-task
(node->comment node))
(let* ((top-live-slot
(stk-num (highest-live-slot live-after)))
(frame-start
(let ((frame-reserve
(frame-constraints-reserve target.frame-constraints))
(frame-align
(frame-constraints-align target.frame-constraints)))
(* (+ (quotient (+ (+ top-live-slot frame-reserve)
(- frame-align 1))
frame-align)
1) ;; reserve space for a break frame
frame-align))))
; move return address to where task expects it
(save-opnd-to-reg (make-lbl return-lbl)
target.task-return
ret-var*
(varset-remove live-starting-task ret-var*)
(node->comment node))
; save variables that the task needs (that are not in regs)
(let loop1 ((l clo-vars-list) (i 0))
(if (null? l)
(adjust-slots
(+ frame-start i)
live-starting-task
(node->comment node))
(let ((var (car l))
(rest (cdr l)))
(if (memq var regs)
(loop1 rest i)
(let ((live-v
(varset-union live-starting-task
(live-vars (list->varset rest)))))
(let loop2 ((j (- target.nb-regs 1)))
(if (>= j 0)
(if (or (>= j (length regs))
(not (varset-member? (list-ref regs j)
live-v)))
(let ((reg (make-reg j)))
(put-copy 19 (var->opnd var)
reg
var
live-v
(node->comment node))
(loop1 rest i))
(loop2 (- j 1)))
(let ((slot (make-stk (+ frame-start (+ i 1))))
(needed (list->varset rest)))
(if (and (or (> (stk-num slot) nb-slots)
(not (memq (list-ref slots (- nb-slots (stk-num slot))) regs)))
(memq (stk-num slot) (live-slots needed)))
(save-opnd slot
live-v
(node->comment node)))
(put-copy 20 (var->opnd var)
slot