2006-11-23 19:44:29 -05:00
|
|
|
|
2006-11-23 19:48:14 -05:00
|
|
|
;;; 9.0: * calls (gensym <symbol>) instead of
|
|
|
|
;;; (gensym (symbol->string <symbol>)) in order to avoid incrementing
|
|
|
|
;;; gensym-count.
|
2006-11-23 19:44:29 -05:00
|
|
|
;;; 6.7: * open-coded top-level-value, car, cdr
|
|
|
|
;;; 6.2: * side-effects now modify the dirty-vector
|
|
|
|
;;; * added bwp-object?
|
|
|
|
;;; * added pointer-value
|
|
|
|
;;; * added tcbuckets
|
|
|
|
;;; 6.1: * added case-lambda, dropped lambda
|
|
|
|
;;; 6.0: * basic compiler
|
|
|
|
|
|
|
|
(let ()
|
|
|
|
|
|
|
|
(define-syntax cond-expand
|
|
|
|
(lambda (x)
|
|
|
|
(syntax-case x ()
|
|
|
|
[(_ test conseq altern)
|
|
|
|
(if (eval (syntax-object->datum #'test))
|
|
|
|
#'conseq
|
|
|
|
#'altern)])))
|
|
|
|
|
|
|
|
(cond-expand (eq? "" "")
|
|
|
|
(include "record-case.chez.ss")
|
|
|
|
(include "record-case.ss"))
|
|
|
|
|
|
|
|
|
|
|
|
(include "set-operations.ss")
|
|
|
|
|
|
|
|
|
|
|
|
(define open-coded-primitives
|
|
|
|
;;; these primitives, when found in operator position with the correct
|
|
|
|
;;; number of arguments, will be open-coded by the generator. If an
|
|
|
|
;;; incorrect number of args is detected, or if they appear in non-operator
|
|
|
|
;;; position, then they cannot be open-coded, and the pcb-primitives table
|
|
|
|
;;; is consulted for a reference of the pcb slot containing the primitive.
|
|
|
|
;;; If it's not found there, an error is signalled.
|
|
|
|
;;;
|
|
|
|
;;; prim-name args
|
|
|
|
'([$constant-ref 1 value]
|
|
|
|
[$constant-set! 2 effect]
|
|
|
|
[$pcb-ref 1 value]
|
|
|
|
[$pcb-set! 2 effect]
|
|
|
|
;;; type predicates
|
|
|
|
[fixnum? 1 pred]
|
|
|
|
[immediate? 1 pred]
|
|
|
|
[boolean? 1 pred]
|
|
|
|
[char? 1 pred]
|
|
|
|
[pair? 1 pred]
|
|
|
|
[symbol? 1 pred]
|
|
|
|
[vector? 1 pred]
|
|
|
|
[string? 1 pred]
|
|
|
|
[procedure? 1 pred]
|
|
|
|
[null? 1 pred]
|
|
|
|
[eof-object? 1 pred]
|
|
|
|
[bwp-object? 1 pred]
|
|
|
|
[$unbound-object? 1 pred]
|
|
|
|
[$forward-ptr? 1 pred]
|
|
|
|
[not 1 pred]
|
|
|
|
[pointer-value 1 value]
|
|
|
|
[eq? 2 pred]
|
|
|
|
;;; fixnum primitives
|
|
|
|
[$fxadd1 1 value]
|
|
|
|
[$fxsub1 1 value]
|
|
|
|
[$fx+ 2 value]
|
|
|
|
[$fx- 2 value]
|
|
|
|
[$fx* 2 value]
|
|
|
|
[$fxsll 2 value]
|
|
|
|
[$fxsra 2 value]
|
|
|
|
[$fxlogand 2 value]
|
|
|
|
[$fxlogor 2 value]
|
|
|
|
[$fxlogxor 2 value]
|
|
|
|
[$fxlognot 1 value]
|
|
|
|
[$fxquotient 2 value]
|
|
|
|
[$fxmodulo 2 value]
|
|
|
|
;;; fixnum predicates
|
|
|
|
[$fxzero? 1 pred]
|
|
|
|
[$fx= 2 pred]
|
|
|
|
[$fx< 2 pred]
|
|
|
|
[$fx<= 2 pred]
|
|
|
|
[$fx> 2 pred]
|
|
|
|
[$fx>= 2 pred]
|
|
|
|
;;; character predicates
|
|
|
|
[$char= 2 pred]
|
|
|
|
[$char< 2 pred]
|
|
|
|
[$char<= 2 pred]
|
|
|
|
[$char> 2 pred]
|
|
|
|
[$char>= 2 pred]
|
|
|
|
;;; character conversion
|
|
|
|
[$fixnum->char 1 value]
|
|
|
|
[$char->fixnum 1 value]
|
|
|
|
;;; lists/pairs
|
|
|
|
[cons 2 value]
|
|
|
|
[list* positive value]
|
|
|
|
[list any value]
|
|
|
|
[car 1 value]
|
|
|
|
[cdr 1 value]
|
|
|
|
[$car 1 value]
|
|
|
|
[$cdr 1 value]
|
|
|
|
[$set-car! 2 effect]
|
|
|
|
[$set-cdr! 2 effect]
|
|
|
|
;;; vectors
|
|
|
|
[$make-vector 1 value]
|
|
|
|
[vector any value]
|
|
|
|
[$vector-length 1 value]
|
|
|
|
[$vector-ref 2 value]
|
|
|
|
[$vector-set! 3 effect]
|
|
|
|
[$vector-memq 2 value]
|
|
|
|
;;; strings
|
|
|
|
[$make-string 1 value]
|
|
|
|
[$string any value]
|
|
|
|
[$string-length 1 value]
|
|
|
|
[$string-ref 2 value]
|
|
|
|
[$string-set! 3 effect]
|
|
|
|
;;; symbols
|
|
|
|
[$make-symbol 1 value]
|
|
|
|
[$symbol-value 1 value]
|
|
|
|
[$symbol-string 1 value]
|
|
|
|
[$symbol-unique-string 1 value]
|
|
|
|
[$set-symbol-value! 2 effect]
|
|
|
|
[$set-symbol-string! 2 effect]
|
|
|
|
[$set-symbol-unique-string! 2 effect]
|
|
|
|
[$symbol-plist 1 value]
|
|
|
|
[$set-symbol-plist! 2 effect]
|
|
|
|
[primitive-ref 1 value]
|
|
|
|
[primitive-set! 2 effect]
|
|
|
|
[top-level-value 1 value]
|
2006-11-23 19:48:14 -05:00
|
|
|
;;; ports
|
|
|
|
[port? 1 pred]
|
|
|
|
[input-port? 1 pred]
|
|
|
|
[output-port? 1 pred]
|
|
|
|
[$make-port/input 7 value]
|
|
|
|
[$make-port/output 7 value]
|
|
|
|
[$make-port/both 7 value]
|
|
|
|
[$port-handler 1 value]
|
|
|
|
[$port-input-buffer 1 value]
|
|
|
|
[$port-input-index 1 value]
|
|
|
|
[$port-input-size 1 value]
|
|
|
|
[$port-output-buffer 1 value]
|
|
|
|
[$port-output-index 1 value]
|
|
|
|
[$port-output-size 1 value]
|
|
|
|
[$set-port-input-index! 2 effect]
|
|
|
|
[$set-port-input-size! 2 effect]
|
|
|
|
[$set-port-output-index! 2 effect]
|
|
|
|
[$set-port-output-size! 2 effect]
|
2006-11-23 19:44:29 -05:00
|
|
|
;;; tcbuckets
|
|
|
|
[$make-tcbucket 4 value]
|
|
|
|
[$tcbucket-key 1 value]
|
|
|
|
[$tcbucket-val 1 value]
|
|
|
|
[$tcbucket-next 1 value]
|
2006-11-23 19:48:14 -05:00
|
|
|
[$tcbucket-dlink-next 1 value]
|
|
|
|
[$tcbucket-dlink-prev 1 value]
|
2006-11-23 19:44:29 -05:00
|
|
|
[$set-tcbucket-val! 2 effect]
|
|
|
|
[$set-tcbucket-next! 2 effect]
|
2006-11-23 19:48:14 -05:00
|
|
|
[$set-tcbucket-dlink-next! 2 effect]
|
|
|
|
[$set-tcbucket-dlink-prev! 2 effect]
|
2006-11-23 19:44:29 -05:00
|
|
|
[$set-tcbucket-tconc! 2 effect]
|
|
|
|
;;; misc
|
|
|
|
[eof-object 0 value]
|
|
|
|
[void 0 value]
|
|
|
|
[$exit 1 effect]
|
|
|
|
[$fp-at-base 0 pred]
|
|
|
|
[$current-frame 0 value]
|
|
|
|
[$seal-frame-and-call 1 tail]
|
|
|
|
[$frame->continuation 1 value]
|
|
|
|
;;;
|
|
|
|
;;; records
|
|
|
|
;;;
|
|
|
|
[$make-record 2 value]
|
|
|
|
[$record? 1 pred]
|
|
|
|
[$record/rtd? 2 pred]
|
|
|
|
[$record-rtd 1 value]
|
|
|
|
[$record-ref 2 value]
|
|
|
|
[$record-set! 3 effect]
|
|
|
|
[$record any value]
|
|
|
|
;;;
|
|
|
|
;;; asm
|
|
|
|
;;;
|
|
|
|
[$code? 1 pred]
|
|
|
|
[$code-size 1 value]
|
|
|
|
[$code-reloc-vector 1 value]
|
|
|
|
[$code-freevars 1 value]
|
|
|
|
[$code-ref 2 value]
|
|
|
|
[$code-set! 3 value]
|
|
|
|
[$code->closure 1 value]
|
|
|
|
;;;
|
|
|
|
[$make-call-with-values-procedure 0 value]
|
|
|
|
[$make-values-procedure 0 value]
|
|
|
|
[$install-underflow-handler 0 effect]
|
|
|
|
))
|
|
|
|
|
|
|
|
(define (primitive-context x)
|
|
|
|
(cond
|
|
|
|
[(assq x open-coded-primitives) => caddr]
|
|
|
|
[else (error 'primitive-context "unknown prim ~s" x)]))
|
|
|
|
|
|
|
|
(define (open-codeable? x)
|
|
|
|
(cond
|
|
|
|
[(assq x open-coded-primitives) #t]
|
|
|
|
[else #f]))
|
|
|
|
|
|
|
|
(define (open-coded-primitive-args x)
|
|
|
|
(cond
|
|
|
|
[(assq x open-coded-primitives) => cadr]
|
|
|
|
[else (error 'open-coded-primitive-args "invalid ~s" x)]))
|
|
|
|
|
|
|
|
;;; end of primitives table section
|
|
|
|
|
|
|
|
|
|
|
|
(define-record constant (value))
|
|
|
|
(define-record code-loc (label))
|
|
|
|
(define-record foreign-label (label))
|
|
|
|
(define-record var (name assigned))
|
|
|
|
(define-record cp-var (idx))
|
|
|
|
(define-record frame-var (idx))
|
|
|
|
(define-record new-frame (base-idx size body))
|
|
|
|
(define-record save-cp (loc))
|
|
|
|
(define-record eval-cp (check body))
|
|
|
|
(define-record return (value))
|
|
|
|
(define-record call-cp
|
|
|
|
(call-convention rp-convention base-idx arg-count live-mask))
|
|
|
|
(define-record tailcall-cp (convention arg-count))
|
|
|
|
(define-record primcall (op arg*))
|
|
|
|
(define-record primref (name))
|
|
|
|
(define-record conditional (test conseq altern))
|
|
|
|
(define-record bind (lhs* rhs* body))
|
|
|
|
(define-record recbind (lhs* rhs* body))
|
|
|
|
(define-record fix (lhs* rhs* body))
|
|
|
|
|
|
|
|
(define-record seq (e0 e1))
|
|
|
|
(define-record clambda-case (arg* proper body))
|
|
|
|
(define-record clambda (cases))
|
|
|
|
(define-record clambda-code (label cases free))
|
|
|
|
(define-record closure (code free*))
|
|
|
|
(define-record funcall (op rand*))
|
|
|
|
(define-record appcall (op rand*))
|
|
|
|
(define-record forcall (op rand*))
|
|
|
|
(define-record code-rec (arg* proper free* body))
|
|
|
|
(define-record codes (list body))
|
|
|
|
(define-record assign (lhs rhs))
|
|
|
|
|
|
|
|
(define (unique-var x)
|
2006-11-23 19:48:14 -05:00
|
|
|
(make-var (gensym x) #f))
|
2006-11-23 19:44:29 -05:00
|
|
|
|
|
|
|
|
|
|
|
(define (make-bind^ lhs* rhs* body)
|
|
|
|
(if (null? lhs*)
|
|
|
|
body
|
|
|
|
(make-bind lhs* rhs* body)))
|
|
|
|
|
|
|
|
(define (recordize x)
|
|
|
|
(define (gen-fml* fml*)
|
|
|
|
(cond
|
|
|
|
[(pair? fml*)
|
|
|
|
(cons (unique-var (car fml*))
|
|
|
|
(gen-fml* (cdr fml*)))]
|
|
|
|
[(symbol? fml*)
|
|
|
|
(unique-var fml*)]
|
|
|
|
[else '()]))
|
|
|
|
(define (properize fml*)
|
|
|
|
(cond
|
|
|
|
[(pair? fml*)
|
|
|
|
(cons (car fml*) (properize (cdr fml*)))]
|
|
|
|
[(null? fml*) '()]
|
|
|
|
[else (list fml*)]))
|
|
|
|
(define (extend-env fml* nfml* env)
|
|
|
|
(cons (cons fml* nfml*) env))
|
|
|
|
(define (quoted-sym x)
|
|
|
|
(if (and (list? x)
|
|
|
|
(fx= (length x) 2)
|
|
|
|
(eq? 'quote (car x))
|
|
|
|
(symbol? (cadr x)))
|
|
|
|
(cadr x)
|
|
|
|
(error 'quoted-sym "not a quoted symbol ~s" x)))
|
|
|
|
(define (quoted-string x)
|
|
|
|
(if (and (list? x)
|
|
|
|
(fx= (length x) 2)
|
|
|
|
(eq? 'quote (car x))
|
|
|
|
(string? (cadr x)))
|
|
|
|
(cadr x)
|
|
|
|
(error 'quoted-string "not a quoted string ~s" x)))
|
|
|
|
(define (lookup^ x lhs* rhs*)
|
|
|
|
(cond
|
|
|
|
[(pair? lhs*)
|
|
|
|
(if (eq? x (car lhs*))
|
|
|
|
(car rhs*)
|
|
|
|
(lookup^ x (cdr lhs*) (cdr rhs*)))]
|
|
|
|
[(eq? x lhs*) rhs*]
|
|
|
|
[else #f]))
|
|
|
|
(define (lookup x env)
|
|
|
|
(cond
|
|
|
|
[(pair? env)
|
|
|
|
(or (lookup^ x (caar env) (cdar env))
|
|
|
|
(lookup x (cdr env)))]
|
|
|
|
[else #f]))
|
|
|
|
(define (E x env)
|
|
|
|
(cond
|
|
|
|
[(pair? x)
|
|
|
|
(case (car x)
|
|
|
|
[(quote) (make-constant (cadr x))]
|
|
|
|
[(if)
|
|
|
|
(make-conditional
|
|
|
|
(E (cadr x) env)
|
|
|
|
(E (caddr x) env)
|
|
|
|
(E (cadddr x) env))]
|
|
|
|
[(set!)
|
|
|
|
(let ([lhs (cadr x)] [rhs (caddr x)])
|
|
|
|
(make-assign
|
|
|
|
(or (lookup lhs env)
|
|
|
|
(error 'recordize "invalid assignment ~s" x))
|
|
|
|
(E rhs env)))]
|
|
|
|
[(begin)
|
|
|
|
(let f ([a (cadr x)] [d (cddr x)])
|
|
|
|
(cond
|
|
|
|
[(null? d) (E a env)]
|
|
|
|
[else
|
|
|
|
(make-seq
|
|
|
|
(E a env)
|
|
|
|
(f (car d) (cdr d)))]))]
|
|
|
|
[(letrec)
|
|
|
|
(unless (fx= (length x) 3) (syntax-error x))
|
|
|
|
(let ([bind* (cadr x)] [body (caddr x)])
|
|
|
|
(let ([lhs* (map car bind*)]
|
|
|
|
[rhs* (map cadr bind*)])
|
|
|
|
(let ([nlhs* (gen-fml* lhs*)])
|
|
|
|
(let ([env (extend-env lhs* nlhs* env)])
|
|
|
|
(make-recbind nlhs*
|
|
|
|
(map (lambda (rhs) (E rhs env)) rhs*)
|
|
|
|
(E body env))))))]
|
|
|
|
[(letrec)
|
|
|
|
(unless (fx= (length x) 3) (syntax-error x))
|
|
|
|
(let ([bind* (cadr x)] [body (caddr x)])
|
|
|
|
(let ([lhs* (map car bind*)]
|
|
|
|
[rhs* (map cadr bind*)]
|
|
|
|
[v* (map (lambda (x) '(void)) bind*)]
|
|
|
|
[t* (map (lambda (x) (gensym)) bind*)])
|
|
|
|
(E `((case-lambda
|
|
|
|
[,lhs*
|
|
|
|
((case-lambda
|
|
|
|
[,t*
|
|
|
|
(begin ,@(map (lambda (x v) `(set! ,x ,v)) lhs* t*)
|
|
|
|
,body)])
|
|
|
|
,@rhs*)])
|
|
|
|
,@v*)
|
|
|
|
env)))]
|
|
|
|
[(case-lambda)
|
|
|
|
(let ([cls*
|
|
|
|
(map
|
|
|
|
(lambda (cls)
|
|
|
|
(let ([fml* (car cls)] [body (cadr cls)])
|
|
|
|
(let ([nfml* (gen-fml* fml*)])
|
|
|
|
(let ([body (E body (extend-env fml* nfml* env))])
|
|
|
|
(make-clambda-case
|
|
|
|
(properize nfml*)
|
|
|
|
(list? fml*)
|
|
|
|
body)))))
|
|
|
|
(cdr x))])
|
|
|
|
(make-clambda cls*))]
|
|
|
|
[(foreign-call)
|
|
|
|
(let ([name (quoted-string (cadr x))] [arg* (cddr x)])
|
|
|
|
(make-forcall name
|
|
|
|
(map (lambda (x) (E x env)) arg*)))]
|
|
|
|
[(|#primitive|)
|
|
|
|
(let ([var (cadr x)])
|
|
|
|
(make-primref var))]
|
|
|
|
;;; [(|#primitive|)
|
|
|
|
;;; (let ([var (cadr x)])
|
|
|
|
;;; (if (primitive? var)
|
|
|
|
;;; (make-primref var)
|
|
|
|
;;; (error 'recordize "invalid primitive ~s" var)))]
|
|
|
|
[(top-level-value)
|
|
|
|
(let ([var (quoted-sym (cadr x))])
|
|
|
|
(if (eq? (expand-mode) 'bootstrap)
|
|
|
|
(error 'compile "reference to ~s in bootstrap mode" var)
|
2006-11-23 19:48:14 -05:00
|
|
|
;(make-primref var)
|
2006-11-23 19:44:29 -05:00
|
|
|
(make-funcall
|
|
|
|
(make-primref 'top-level-value)
|
|
|
|
(list (make-constant var)))))]
|
|
|
|
;;; [(top-level-value)
|
|
|
|
;;; (let ([var (quoted-sym (cadr x))])
|
|
|
|
;;; (if (eq? (expand-mode) 'bootstrap)
|
|
|
|
;;; (if (primitive? var)
|
|
|
|
;;; (make-primref var)
|
|
|
|
;;; (error 'compile "invalid primitive ~s" var))
|
|
|
|
;;; (make-funcall
|
|
|
|
;;; (make-primref 'top-level-value)
|
|
|
|
;;; (list (make-constant var)))))]
|
|
|
|
[(set-top-level-value!)
|
|
|
|
(make-funcall (make-primref 'set-top-level-value!)
|
|
|
|
(map (lambda (x) (E x env)) (cdr x)))]
|
|
|
|
[(memv)
|
|
|
|
(make-funcall
|
|
|
|
(make-primref 'memq)
|
|
|
|
(map (lambda (x) (E x env)) (cdr x)))]
|
|
|
|
[($apply)
|
|
|
|
(let ([proc (cadr x)] [arg* (cddr x)])
|
|
|
|
(make-appcall
|
|
|
|
(E proc env)
|
|
|
|
(map (lambda (x) (E x env)) arg*)))]
|
|
|
|
[(void)
|
|
|
|
(make-constant (void))]
|
|
|
|
[else
|
|
|
|
(make-funcall
|
|
|
|
(E (car x) env)
|
|
|
|
(map (lambda (x) (E x env)) (cdr x)))])]
|
|
|
|
[(symbol? x)
|
|
|
|
(or (lookup x env)
|
|
|
|
(error 'recordize "invalid reference in ~s" x))]
|
|
|
|
[else (error 'recordize "invalid expression ~s" x)]))
|
|
|
|
(E x '()))
|
|
|
|
|
|
|
|
|
|
|
|
(define (unparse x)
|
|
|
|
(define (E-args proper x)
|
|
|
|
(if proper
|
|
|
|
(map E x)
|
|
|
|
(let f ([a (car x)] [d (cdr x)])
|
|
|
|
(cond
|
|
|
|
[(null? d) (E a)]
|
|
|
|
[else (cons (E a) (f (car d) (cdr d)))]))))
|
|
|
|
(define (E x)
|
|
|
|
(record-case x
|
|
|
|
[(constant c) `(quote ,c)]
|
|
|
|
[(code-loc x) `(code-loc ,x)]
|
|
|
|
[(var x) (string->symbol (format "v:~a" x))]
|
|
|
|
[(primref x) x]
|
|
|
|
[(conditional test conseq altern)
|
|
|
|
`(if ,(E test) ,(E conseq) ,(E altern))]
|
|
|
|
[(primcall op arg*) `(,op . ,(map E arg*))]
|
|
|
|
[(bind lhs* rhs* body)
|
|
|
|
`(let ,(map (lambda (lhs rhs) (list (E lhs) (E rhs))) lhs* rhs*)
|
|
|
|
,(E body))]
|
|
|
|
[(recbind lhs* rhs* body)
|
|
|
|
`(letrec ,(map (lambda (lhs rhs) (list (E lhs) (E rhs))) lhs* rhs*)
|
|
|
|
,(E body))]
|
|
|
|
[(fix lhs* rhs* body)
|
|
|
|
`(fix ,(map (lambda (lhs rhs) (list (E lhs) (E rhs))) lhs* rhs*)
|
|
|
|
,(E body))]
|
|
|
|
[(seq e0 e1) `(begin ,(E e0) ,(E e1))]
|
|
|
|
[(clambda-case args proper body)
|
|
|
|
`(clambda-case ,(E-args proper args) ,(E body))]
|
|
|
|
[(clambda cls*)
|
|
|
|
`(case-lambda . ,(map E cls*))]
|
|
|
|
[(clambda-code label clauses free)
|
|
|
|
`(code ,label . ,(map E clauses))]
|
|
|
|
[(closure code free*)
|
|
|
|
`(closure ,(E code) ,(map E free*))]
|
|
|
|
[(code-rec arg* proper free* body)
|
|
|
|
`(code-rec [arg: ,(E-args proper arg*)]
|
|
|
|
[free: ,(map E free*)]
|
|
|
|
,(E body))]
|
|
|
|
[(codes list body)
|
|
|
|
`(codes ,(map E list)
|
|
|
|
,(E body))]
|
|
|
|
[(funcall rator rand*) `(funcall ,(E rator) . ,(map E rand*))]
|
|
|
|
[(appcall rator rand*) `(appcall ,(E rator) . ,(map E rand*))]
|
|
|
|
[(forcall rator rand*) `(foreign-call ,rator . ,(map E rand*))]
|
|
|
|
[(assign lhs rhs) `(set! ,(E lhs) ,(E rhs))]
|
|
|
|
[(return x) `(return ,(E x))]
|
|
|
|
[(new-frame base-idx size body)
|
|
|
|
`(new-frame [base: ,base-idx]
|
|
|
|
[size: ,size]
|
|
|
|
,(E body))]
|
|
|
|
[(frame-var idx)
|
|
|
|
(string->symbol (format "fv.~a" idx))]
|
|
|
|
[(cp-var idx)
|
|
|
|
(string->symbol (format "cp.~a" idx))]
|
|
|
|
[(save-cp expr)
|
|
|
|
`(save-cp ,(E expr))]
|
|
|
|
[(eval-cp check body)
|
|
|
|
`(eval-cp ,check ,(E body))]
|
|
|
|
[(call-cp call-convention rp-convention base-idx arg-count live-mask)
|
|
|
|
`(call-cp [conv: ,call-convention]
|
|
|
|
[rpconv: ,rp-convention]
|
|
|
|
[base-idx: ,base-idx]
|
|
|
|
[arg-count: ,arg-count]
|
|
|
|
[live-mask: ,live-mask])]
|
|
|
|
[(foreign-label x) `(foreign-label ,x)]
|
|
|
|
[else (error 'unparse "invalid record ~s" x)]))
|
|
|
|
(E x))
|
|
|
|
|
|
|
|
(define (optimize-direct-calls x)
|
|
|
|
(define who 'optimize-direct-calls)
|
|
|
|
(define (make-conses ls)
|
|
|
|
(cond
|
|
|
|
[(null? ls) (make-constant '())]
|
|
|
|
[else
|
|
|
|
(make-primcall 'cons
|
|
|
|
(list (car ls) (make-conses (cdr ls))))]))
|
|
|
|
(define (properize lhs* rhs*)
|
|
|
|
(cond
|
|
|
|
[(null? lhs*) (error who "improper improper")]
|
|
|
|
[(null? (cdr lhs*))
|
|
|
|
(list (make-conses rhs*))]
|
|
|
|
[else (cons (car rhs*) (properize (cdr lhs*) (cdr rhs*)))]))
|
|
|
|
(define (inline-case cls rand*)
|
|
|
|
(record-case cls
|
|
|
|
[(clambda-case fml* proper body)
|
|
|
|
(if proper
|
|
|
|
(and (fx= (length fml*) (length rand*))
|
|
|
|
(make-bind fml* rand* body))
|
|
|
|
(and (fx<= (length fml*) (length rand*))
|
|
|
|
(make-bind fml* (properize fml* rand*) body)))]))
|
|
|
|
(define (try-inline cls* rand* default)
|
|
|
|
(cond
|
|
|
|
[(null? cls*) default]
|
|
|
|
[(inline-case (car cls*) rand*)]
|
|
|
|
[else (try-inline (cdr cls*) rand* default)]))
|
|
|
|
(define (inline rator rand*)
|
|
|
|
(record-case rator
|
|
|
|
[(clambda cls*)
|
|
|
|
(try-inline cls* rand*
|
|
|
|
(make-funcall rator rand*))]
|
|
|
|
[else (make-funcall rator rand*)]))
|
|
|
|
(define (Expr x)
|
|
|
|
(record-case x
|
|
|
|
[(constant) x]
|
|
|
|
[(var) x]
|
|
|
|
[(primref) x]
|
|
|
|
[(bind lhs* rhs* body)
|
|
|
|
(make-bind lhs* (map Expr rhs*) (Expr body))]
|
|
|
|
[(recbind lhs* rhs* body)
|
|
|
|
(make-recbind lhs* (map Expr rhs*) (Expr body))]
|
|
|
|
[(conditional test conseq altern)
|
|
|
|
(make-conditional
|
|
|
|
(Expr test)
|
|
|
|
(Expr conseq)
|
|
|
|
(Expr altern))]
|
|
|
|
[(seq e0 e1)
|
|
|
|
(make-seq (Expr e0) (Expr e1))]
|
|
|
|
[(clambda cls*)
|
|
|
|
(make-clambda
|
|
|
|
(map (lambda (x)
|
|
|
|
(record-case x
|
|
|
|
[(clambda-case fml* proper body)
|
|
|
|
(make-clambda-case fml* proper (Expr body))]))
|
|
|
|
cls*))]
|
|
|
|
[(primcall rator rand*)
|
|
|
|
(make-primcall rator (map Expr rand*))]
|
|
|
|
[(funcall rator rand*)
|
|
|
|
(inline (Expr rator) (map Expr rand*))]
|
|
|
|
[(appcall rator rand*)
|
|
|
|
(make-appcall (Expr rator) (map Expr rand*))]
|
|
|
|
[(forcall rator rand*)
|
|
|
|
(make-forcall rator (map Expr rand*))]
|
|
|
|
[(assign lhs rhs)
|
|
|
|
(make-assign lhs (Expr rhs))]
|
|
|
|
[else (error who "invalid expression ~s" (unparse x))]))
|
|
|
|
(Expr x))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(define lambda-both 0)
|
|
|
|
(define lambda-producer 0)
|
|
|
|
(define lambda-consumer 0)
|
|
|
|
(define lambda-none 0)
|
|
|
|
(define branching-producer 0)
|
|
|
|
|
|
|
|
|
|
|
|
(define (analyze-cwv x)
|
|
|
|
(define who 'analyze-cwv)
|
|
|
|
(define (lambda? x)
|
|
|
|
(record-case x
|
|
|
|
[(clambda) #t]
|
|
|
|
[else #f]))
|
|
|
|
(define (branching-producer? x)
|
|
|
|
(define (bt? x)
|
|
|
|
(record-case x
|
|
|
|
[(bind lhs* rhs* body) (bt? body)]
|
|
|
|
[(recbind lhs* rhs* body) (bt? body)]
|
|
|
|
[(conditional test conseq altern) #t]
|
|
|
|
[(seq e0 e1) (bt? e1)]
|
|
|
|
[else #f]))
|
|
|
|
(define (branching-clause? x)
|
|
|
|
(record-case x
|
|
|
|
[(clambda-case fml* proper body)
|
|
|
|
(bt? body)]))
|
|
|
|
(record-case x
|
|
|
|
[(clambda cls*)
|
|
|
|
(ormap branching-clause? cls*)]
|
|
|
|
[else #f]))
|
|
|
|
(define (analyze producer consumer)
|
|
|
|
(cond
|
|
|
|
[(and (lambda? producer) (lambda? consumer))
|
|
|
|
(set! lambda-both (fxadd1 lambda-both))]
|
|
|
|
[(lambda? producer)
|
|
|
|
(set! lambda-producer (fxadd1 lambda-producer))]
|
|
|
|
[(lambda? consumer)
|
|
|
|
(set! lambda-consumer (fxadd1 lambda-consumer))]
|
|
|
|
[else
|
|
|
|
(set! lambda-none (fxadd1 lambda-none))])
|
|
|
|
(when (branching-producer? producer)
|
|
|
|
(set! branching-producer (fxadd1 branching-producer)))
|
|
|
|
(printf "both=~s p=~s c=~s none=~s branching-prod=~s\n"
|
|
|
|
lambda-both lambda-producer lambda-consumer lambda-none
|
|
|
|
branching-producer))
|
|
|
|
(define (E x)
|
|
|
|
(record-case x
|
|
|
|
[(constant) (void)]
|
|
|
|
[(var) (void)]
|
|
|
|
[(primref) (void)]
|
|
|
|
[(bind lhs* rhs* body)
|
|
|
|
(for-each E rhs*) (E body)]
|
|
|
|
[(recbind lhs* rhs* body)
|
|
|
|
(for-each E rhs*) (E body)]
|
|
|
|
[(conditional test conseq altern)
|
|
|
|
(E test)
|
|
|
|
(E conseq)
|
|
|
|
(E altern)]
|
|
|
|
[(seq e0 e1) (E e0) (E e1)]
|
|
|
|
[(clambda cls*)
|
|
|
|
(for-each
|
|
|
|
(lambda (x)
|
|
|
|
(record-case x
|
|
|
|
[(clambda-case fml* proper body) (E body)]))
|
|
|
|
cls*)]
|
|
|
|
[(primcall rator rand*)
|
|
|
|
(for-each E rand*)
|
|
|
|
(when (and (eq? rator 'call-with-values) (fx= (length rand*) 2))
|
|
|
|
(analyze (car rand*) (cadr rand*)))]
|
|
|
|
[(funcall rator rand*)
|
|
|
|
(E rator) (for-each E rand*)
|
|
|
|
(when (and (record-case rator
|
|
|
|
[(primref op) (eq? op 'call-with-values)]
|
|
|
|
[else #f])
|
|
|
|
(fx= (length rand*) 2))
|
|
|
|
(analyze (car rand*) (cadr rand*)))]
|
|
|
|
[(appcall rator rand*)
|
|
|
|
(E rator) (for-each E rand*)]
|
|
|
|
[(forcall rator rand*)
|
|
|
|
(for-each E rand*)]
|
|
|
|
[(assign lhs rhs)
|
|
|
|
(E rhs)]
|
|
|
|
[else (error who "invalid expression ~s" (unparse x))]))
|
|
|
|
(E x))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(define (optimize-letrec x)
|
|
|
|
(define who 'optimize-letrec)
|
|
|
|
(define (extend-hash lhs* h ref)
|
|
|
|
(for-each (lambda (lhs) (put-hash-table! h lhs #t)) lhs*)
|
|
|
|
(lambda (x)
|
|
|
|
(unless (get-hash-table h x #f)
|
|
|
|
(put-hash-table! h x #t)
|
|
|
|
(ref x))))
|
|
|
|
(define (E* x* ref comp)
|
|
|
|
(cond
|
|
|
|
[(null? x*) '()]
|
|
|
|
[else
|
|
|
|
(cons (E (car x*) ref comp)
|
|
|
|
(E* (cdr x*) ref comp))]))
|
|
|
|
(define (do-rhs* i lhs* rhs* ref comp vref vcomp)
|
|
|
|
(cond
|
|
|
|
[(null? rhs*) '()]
|
|
|
|
[else
|
|
|
|
(let ([h (make-hash-table)])
|
|
|
|
(let ([ref
|
|
|
|
(lambda (x)
|
|
|
|
(unless (get-hash-table h x #f)
|
|
|
|
(put-hash-table! h x #t)
|
|
|
|
(ref x)
|
|
|
|
(when (memq x lhs*)
|
|
|
|
(vector-set! vref i #t))))]
|
|
|
|
[comp
|
|
|
|
(lambda ()
|
|
|
|
(vector-set! vcomp i #t)
|
|
|
|
(comp))])
|
|
|
|
(cons (E (car rhs*) ref comp)
|
|
|
|
(do-rhs* (fxadd1 i) lhs* (cdr rhs*) ref comp vref vcomp))))]))
|
|
|
|
(define (partition-rhs* i lhs* rhs* vref vcomp)
|
|
|
|
(cond
|
|
|
|
[(null? lhs*) (values '() '() '() '() '() '())]
|
|
|
|
[else
|
|
|
|
(let-values
|
|
|
|
([(slhs* srhs* llhs* lrhs* clhs* crhs*)
|
|
|
|
(partition-rhs* (fxadd1 i) (cdr lhs*) (cdr rhs*) vref vcomp)]
|
|
|
|
[(lhs rhs) (values (car lhs*) (car rhs*))])
|
|
|
|
(cond
|
|
|
|
[(var-assigned lhs)
|
|
|
|
(values slhs* srhs* llhs* lrhs* (cons lhs clhs*) (cons rhs crhs*))]
|
|
|
|
[(clambda? rhs)
|
|
|
|
(values slhs* srhs* (cons lhs llhs*) (cons rhs lrhs*) clhs* crhs*)]
|
|
|
|
[(or (vector-ref vref i) (vector-ref vcomp i))
|
|
|
|
(values slhs* srhs* llhs* lrhs* (cons lhs clhs*) (cons rhs crhs*))]
|
|
|
|
[else
|
|
|
|
(values (cons lhs slhs*) (cons rhs srhs*) llhs* lrhs* clhs* crhs*)]
|
|
|
|
))]))
|
|
|
|
(define (do-recbind lhs* rhs* body ref comp)
|
|
|
|
(let ([h (make-hash-table)]
|
|
|
|
[vref (make-vector (length lhs*) #f)]
|
|
|
|
[vcomp (make-vector (length lhs*) #f)])
|
|
|
|
(let* ([ref (extend-hash lhs* h ref)]
|
|
|
|
[body (E body ref comp)])
|
|
|
|
(let ([rhs* (do-rhs* 0 lhs* rhs* ref comp vref vcomp)])
|
|
|
|
(let-values ([(slhs* srhs* llhs* lrhs* clhs* crhs*)
|
|
|
|
(partition-rhs* 0 lhs* rhs* vref vcomp)])
|
|
|
|
(let ([v* (map (lambda (x) (make-primcall 'void '())) clhs*)]
|
|
|
|
[t* (map (lambda (x) (unique-var 'tmp)) clhs*)])
|
|
|
|
(make-bind slhs* srhs*
|
|
|
|
(make-bind clhs* v*
|
|
|
|
(make-fix llhs* lrhs*
|
|
|
|
(make-bind t* crhs*
|
|
|
|
(build-assign* clhs* t* body)))))))))))
|
|
|
|
(define (build-assign* lhs* rhs* body)
|
|
|
|
(cond
|
|
|
|
[(null? lhs*) body]
|
|
|
|
[else
|
|
|
|
(make-seq
|
|
|
|
(make-assign (car lhs*) (car rhs*))
|
|
|
|
(build-assign* (cdr lhs*) (cdr rhs*) body))]))
|
|
|
|
(define (E x ref comp)
|
|
|
|
(record-case x
|
|
|
|
[(constant) x]
|
|
|
|
[(var) (ref x) x]
|
|
|
|
[(assign lhs rhs)
|
|
|
|
(set-var-assigned! lhs #t)
|
|
|
|
(ref lhs)
|
|
|
|
(make-assign lhs (E rhs ref comp))]
|
|
|
|
[(primref) x]
|
|
|
|
[(bind lhs* rhs* body)
|
|
|
|
(let ([rhs* (E* rhs* ref comp)])
|
|
|
|
(let ([h (make-hash-table)])
|
|
|
|
(let ([body (E body (extend-hash lhs* h ref) comp)])
|
|
|
|
(make-bind lhs* rhs* body))))]
|
|
|
|
[(recbind lhs* rhs* body)
|
|
|
|
(if (null? lhs*)
|
|
|
|
(E body ref comp)
|
|
|
|
(do-recbind lhs* rhs* body ref comp))]
|
|
|
|
[(conditional e0 e1 e2)
|
|
|
|
(make-conditional (E e0 ref comp) (E e1 ref comp) (E e2 ref comp))]
|
|
|
|
[(seq e0 e1) (make-seq (E e0 ref comp) (E e1 ref comp))]
|
|
|
|
[(clambda cls*)
|
|
|
|
(make-clambda
|
|
|
|
(map (lambda (x)
|
|
|
|
(record-case x
|
|
|
|
[(clambda-case fml* proper body)
|
|
|
|
(let ([h (make-hash-table)])
|
|
|
|
(let ([body (E body (extend-hash fml* h ref) void)])
|
|
|
|
(make-clambda-case fml* proper body)))]))
|
|
|
|
cls*))]
|
|
|
|
[(primcall rator rand*)
|
|
|
|
(when (memq rator '(call/cc call/cf))
|
|
|
|
(comp))
|
|
|
|
(make-primcall rator (E* rand* ref comp))]
|
|
|
|
[(funcall rator rand*)
|
|
|
|
(let ([rator (E rator ref comp)] [rand* (E* rand* ref comp)])
|
|
|
|
(record-case rator
|
|
|
|
[(primref op)
|
|
|
|
(when (memq op '(call/cc call/cf))
|
|
|
|
(comp))]
|
|
|
|
[else
|
|
|
|
(comp)])
|
|
|
|
(make-funcall rator rand*))]
|
|
|
|
[(appcall rator rand*)
|
|
|
|
(let ([rator (E rator ref comp)] [rand* (E* rand* ref comp)])
|
|
|
|
(record-case rator
|
|
|
|
[(primref op)
|
|
|
|
(when (memq op '(call/cc call/cf))
|
|
|
|
(comp))]
|
|
|
|
[else
|
|
|
|
(comp)])
|
|
|
|
(make-appcall rator rand*))]
|
|
|
|
[(forcall rator rand*)
|
|
|
|
(make-forcall rator (E* rand* ref comp))]
|
|
|
|
[else (error who "invalid expression ~s" (unparse x))]))
|
|
|
|
(E x (lambda (x) (error who "free var ~s found" x))
|
|
|
|
void))
|
|
|
|
|
|
|
|
|
|
|
|
(define (remove-letrec x)
|
|
|
|
(define who 'remove-letrec)
|
|
|
|
(define (Expr x)
|
|
|
|
(record-case x
|
|
|
|
[(constant) x]
|
|
|
|
[(var) x]
|
|
|
|
[(primref) x]
|
|
|
|
[(bind lhs* rhs* body)
|
|
|
|
(make-bind lhs* (map Expr rhs*) (Expr body))]
|
|
|
|
[(recbind lhs* rhs* body)
|
|
|
|
(let ([t* (map (lambda (lhs) (unique-var 'tmp)) lhs*)]
|
|
|
|
[v* (map (lambda (lhs) (make-primcall 'void '())) lhs*)])
|
|
|
|
(make-bind lhs* v*
|
|
|
|
(make-bind t* (map Expr rhs*)
|
|
|
|
(let f ([lhs* lhs*] [t* t*])
|
|
|
|
(cond
|
|
|
|
[(null? lhs*) (Expr body)]
|
|
|
|
[else
|
|
|
|
(make-seq
|
|
|
|
(make-assign (car lhs*) (car t*))
|
|
|
|
(f (cdr lhs*) (cdr t*)))])))))]
|
|
|
|
;[(fix lhs* rhs* body)
|
|
|
|
; (Expr (make-recbind lhs* rhs* body))]
|
|
|
|
[(fix lhs* rhs* body)
|
|
|
|
(make-fix lhs* (map Expr rhs*) (Expr body))]
|
|
|
|
[(conditional test conseq altern)
|
|
|
|
(make-conditional
|
|
|
|
(Expr test)
|
|
|
|
(Expr conseq)
|
|
|
|
(Expr altern))]
|
|
|
|
[(seq e0 e1)
|
|
|
|
(make-seq (Expr e0) (Expr e1))]
|
|
|
|
[(clambda cls*)
|
|
|
|
(make-clambda
|
|
|
|
(map (lambda (x)
|
|
|
|
(record-case x
|
|
|
|
[(clambda-case fml* proper body)
|
|
|
|
(make-clambda-case fml* proper (Expr body))]))
|
|
|
|
cls*))]
|
|
|
|
[(primcall rator rand*)
|
|
|
|
(make-primcall rator (map Expr rand*))]
|
|
|
|
[(funcall rator rand*)
|
|
|
|
(make-funcall (Expr rator) (map Expr rand*))]
|
|
|
|
[(appcall rator rand*)
|
|
|
|
(make-appcall (Expr rator) (map Expr rand*))]
|
|
|
|
[(forcall rator rand*)
|
|
|
|
(make-forcall rator (map Expr rand*))]
|
|
|
|
[(assign lhs rhs)
|
|
|
|
(make-assign lhs (Expr rhs))]
|
|
|
|
[else (error who "invalid expression ~s" (unparse x))]))
|
|
|
|
(Expr x))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(define (uncover-assigned x)
|
|
|
|
(define who 'uncover-assigned)
|
|
|
|
(define (Expr* x*)
|
|
|
|
(for-each Expr x*))
|
|
|
|
(define (Expr x)
|
|
|
|
(record-case x
|
|
|
|
[(constant) (void)]
|
|
|
|
[(var) (void)]
|
|
|
|
[(primref) (void)]
|
|
|
|
[(bind lhs* rhs* body)
|
|
|
|
(begin (Expr body) (Expr* rhs*))]
|
|
|
|
[(recbind lhs* rhs* body)
|
|
|
|
(begin (Expr body) (Expr* rhs*))]
|
|
|
|
[(fix lhs* rhs* body)
|
|
|
|
(Expr* rhs*)
|
|
|
|
(Expr body)
|
|
|
|
(when (ormap var-assigned lhs*)
|
|
|
|
(error 'uncover-assigned "a fix lhs is assigned"))]
|
|
|
|
[(conditional test conseq altern)
|
|
|
|
(begin (Expr test) (Expr conseq) (Expr altern))]
|
|
|
|
[(seq e0 e1) (begin (Expr e0) (Expr e1))]
|
|
|
|
[(clambda cls*)
|
|
|
|
(for-each
|
|
|
|
(lambda (cls)
|
|
|
|
(Expr (clambda-case-body cls)))
|
|
|
|
cls*)]
|
|
|
|
[(primcall rator rand*) (Expr* rand*)]
|
|
|
|
[(funcall rator rand*)
|
|
|
|
(begin (Expr rator) (Expr* rand*))]
|
|
|
|
[(appcall rator rand*)
|
|
|
|
(begin (Expr rator) (Expr* rand*))]
|
|
|
|
[(forcall rator rand*) (Expr* rand*)]
|
|
|
|
[(assign lhs rhs)
|
|
|
|
(set-var-assigned! lhs #t)
|
|
|
|
(Expr rhs)]
|
|
|
|
[else (error who "invalid expression ~s" (unparse x))]))
|
|
|
|
(Expr x))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(define (rewrite-assignments x)
|
|
|
|
(define who 'rewrite-assignments)
|
|
|
|
(define (fix-lhs* lhs*)
|
|
|
|
(cond
|
|
|
|
[(null? lhs*) (values '() '() '())]
|
|
|
|
[else
|
|
|
|
(let ([x (car lhs*)])
|
|
|
|
(let-values ([(lhs* a-lhs* a-rhs*) (fix-lhs* (cdr lhs*))])
|
|
|
|
(cond
|
|
|
|
[(var-assigned x)
|
|
|
|
(let ([t (unique-var 'assignment-tmp)])
|
|
|
|
(values (cons t lhs*) (cons x a-lhs*) (cons t a-rhs*)))]
|
|
|
|
[else
|
|
|
|
(values (cons x lhs*) a-lhs* a-rhs*)])))]))
|
|
|
|
(define (bind-assigned lhs* rhs* body)
|
|
|
|
(cond
|
|
|
|
[(null? lhs*) body]
|
|
|
|
[else
|
|
|
|
(make-bind lhs*
|
|
|
|
(map (lambda (rhs) (make-primcall 'vector (list rhs))) rhs*)
|
|
|
|
body)]))
|
|
|
|
(define (Expr x)
|
|
|
|
(record-case x
|
|
|
|
[(constant) x]
|
|
|
|
[(var)
|
|
|
|
(cond
|
|
|
|
[(var-assigned x)
|
|
|
|
(make-primcall '$vector-ref (list x (make-constant 0)))]
|
|
|
|
[else x])]
|
|
|
|
[(primref) x]
|
|
|
|
[(bind lhs* rhs* body)
|
|
|
|
(let-values ([(lhs* a-lhs* a-rhs*) (fix-lhs* lhs*)])
|
|
|
|
(make-bind lhs* (map Expr rhs*)
|
|
|
|
(bind-assigned a-lhs* a-rhs* (Expr body))))]
|
|
|
|
[(fix lhs* rhs* body)
|
|
|
|
(make-fix lhs* (map Expr rhs*) (Expr body))]
|
|
|
|
[(conditional test conseq altern)
|
|
|
|
(make-conditional (Expr test) (Expr conseq) (Expr altern))]
|
|
|
|
[(seq e0 e1) (make-seq (Expr e0) (Expr e1))]
|
|
|
|
[(clambda cls*)
|
|
|
|
(make-clambda
|
|
|
|
(map (lambda (cls)
|
|
|
|
(record-case cls
|
|
|
|
[(clambda-case fml* proper body)
|
|
|
|
(let-values ([(fml* a-lhs* a-rhs*) (fix-lhs* fml*)])
|
|
|
|
(make-clambda-case fml* proper
|
|
|
|
(bind-assigned a-lhs* a-rhs* (Expr body))))]))
|
|
|
|
cls*))]
|
|
|
|
[(primcall op rand*)
|
|
|
|
(make-primcall op (map Expr rand*))]
|
|
|
|
[(forcall op rand*)
|
|
|
|
(make-forcall op (map Expr rand*))]
|
|
|
|
[(funcall rator rand*)
|
|
|
|
(make-funcall (Expr rator) (map Expr rand*))]
|
|
|
|
[(appcall rator rand*)
|
|
|
|
(make-appcall (Expr rator) (map Expr rand*))]
|
|
|
|
[(assign lhs rhs)
|
|
|
|
(unless (var-assigned lhs)
|
|
|
|
(error 'rewrite-assignments "not assigned ~s in ~s" lhs x))
|
|
|
|
(make-primcall '$vector-set! (list lhs (make-constant 0) (Expr rhs)))]
|
|
|
|
[else (error who "invalid expression ~s" (unparse x))]))
|
|
|
|
(Expr x))
|
|
|
|
|
|
|
|
|
|
|
|
(define (remove-assignments x)
|
|
|
|
(uncover-assigned x)
|
|
|
|
(rewrite-assignments x))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(define (convert-closures prog)
|
|
|
|
(define who 'convert-closures)
|
|
|
|
(define (Expr* x*)
|
|
|
|
(cond
|
|
|
|
[(null? x*) (values '() '())]
|
|
|
|
[else
|
|
|
|
(let-values ([(a a-free) (Expr (car x*))]
|
|
|
|
[(d d-free) (Expr* (cdr x*))])
|
|
|
|
(values (cons a d) (union a-free d-free)))]))
|
|
|
|
(define (do-clambda* x*)
|
|
|
|
(cond
|
|
|
|
[(null? x*) (values '() '())]
|
|
|
|
[else
|
|
|
|
(let-values ([(a a-free) (do-clambda (car x*))]
|
|
|
|
[(d d-free) (do-clambda* (cdr x*))])
|
|
|
|
(values (cons a d) (union a-free d-free)))]))
|
|
|
|
(define (do-clambda x)
|
|
|
|
(record-case x
|
|
|
|
[(clambda cls*)
|
|
|
|
(let-values ([(cls* free)
|
|
|
|
(let f ([cls* cls*])
|
|
|
|
(cond
|
|
|
|
[(null? cls*) (values '() '())]
|
|
|
|
[else
|
|
|
|
(record-case (car cls*)
|
|
|
|
[(clambda-case fml* proper body)
|
|
|
|
(let-values ([(body body-free) (Expr body)]
|
|
|
|
[(cls* cls*-free) (f (cdr cls*))])
|
|
|
|
(values
|
|
|
|
(cons (make-clambda-case fml* proper body)
|
|
|
|
cls*)
|
|
|
|
(union (difference body-free fml*)
|
|
|
|
cls*-free)))])]))])
|
|
|
|
(values (make-closure (make-clambda-code (gensym) cls* free) free)
|
|
|
|
free))]))
|
|
|
|
(define (Expr ex)
|
|
|
|
(record-case ex
|
|
|
|
[(constant) (values ex '())]
|
|
|
|
[(var) (values ex (singleton ex))]
|
|
|
|
[(primref) (values ex '())]
|
|
|
|
[(bind lhs* rhs* body)
|
|
|
|
(let-values ([(rhs* rhs-free) (Expr* rhs*)]
|
|
|
|
[(body body-free) (Expr body)])
|
|
|
|
(values (make-bind lhs* rhs* body)
|
|
|
|
(union rhs-free (difference body-free lhs*))))]
|
|
|
|
[(fix lhs* rhs* body)
|
|
|
|
(let-values ([(rhs* rfree) (do-clambda* rhs*)]
|
|
|
|
[(body bfree) (Expr body)])
|
|
|
|
(values (make-fix lhs* rhs* body)
|
|
|
|
(difference (union bfree rfree) lhs*)))]
|
|
|
|
[(conditional test conseq altern)
|
|
|
|
(let-values ([(test test-free) (Expr test)]
|
|
|
|
[(conseq conseq-free) (Expr conseq)]
|
|
|
|
[(altern altern-free) (Expr altern)])
|
|
|
|
(values (make-conditional test conseq altern)
|
|
|
|
(union test-free (union conseq-free altern-free))))]
|
|
|
|
[(seq e0 e1)
|
|
|
|
(let-values ([(e0 e0-free) (Expr e0)]
|
|
|
|
[(e1 e1-free) (Expr e1)])
|
|
|
|
(values (make-seq e0 e1) (union e0-free e1-free)))]
|
|
|
|
[(clambda)
|
|
|
|
(do-clambda ex)]
|
|
|
|
[(primcall op rand*)
|
|
|
|
(let-values ([(rand* rand*-free) (Expr* rand*)])
|
|
|
|
(values (make-primcall op rand*) rand*-free))]
|
|
|
|
[(forcall op rand*)
|
|
|
|
(let-values ([(rand* rand*-free) (Expr* rand*)])
|
|
|
|
(values (make-forcall op rand*) rand*-free))]
|
|
|
|
[(funcall rator rand*)
|
|
|
|
(let-values ([(rator rat-free) (Expr rator)]
|
|
|
|
[(rand* rand*-free) (Expr* rand*)])
|
|
|
|
(values (make-funcall rator rand*)
|
|
|
|
(union rat-free rand*-free)))]
|
|
|
|
[(appcall rator rand*)
|
|
|
|
(let-values ([(rator rat-free) (Expr rator)]
|
|
|
|
[(rand* rand*-free) (Expr* rand*)])
|
|
|
|
(values (make-appcall rator rand*)
|
|
|
|
(union rat-free rand*-free)))]
|
|
|
|
[else (error who "invalid expression ~s" (unparse ex))]))
|
|
|
|
(let-values ([(prog free) (Expr prog)])
|
|
|
|
(unless (null? free)
|
|
|
|
(error 'convert-closures "free vars ~s encountered in ~a"
|
|
|
|
free (unparse prog)))
|
|
|
|
prog))
|
|
|
|
|
|
|
|
|
|
|
|
(define (lift-codes x)
|
|
|
|
(define who 'lift-codes)
|
|
|
|
(define all-codes '())
|
|
|
|
(define (do-code x)
|
|
|
|
(record-case x
|
|
|
|
[(clambda-code label cls* free)
|
|
|
|
(let ([cls* (map
|
|
|
|
(lambda (x)
|
|
|
|
(record-case x
|
|
|
|
[(clambda-case fml* proper body)
|
|
|
|
(make-clambda-case fml* proper (E body))]))
|
|
|
|
cls*)])
|
|
|
|
(let ([g (make-code-loc label)])
|
|
|
|
(set! all-codes
|
|
|
|
(cons (make-clambda-code label cls* free) all-codes))
|
|
|
|
g))]))
|
|
|
|
(define (E x)
|
|
|
|
(record-case x
|
|
|
|
[(constant) x]
|
|
|
|
[(var) x]
|
|
|
|
[(primref) x]
|
|
|
|
[(bind lhs* rhs* body)
|
|
|
|
(make-bind lhs* (map E rhs*) (E body))]
|
|
|
|
[(fix lhs* rhs* body)
|
|
|
|
(make-fix lhs* (map E rhs*) (E body))]
|
|
|
|
[(conditional test conseq altern)
|
|
|
|
(make-conditional (E test) (E conseq) (E altern))]
|
|
|
|
[(seq e0 e1) (make-seq (E e0) (E e1))]
|
|
|
|
[(closure c free) (make-closure (do-code c) free)]
|
|
|
|
[(primcall op rand*) (make-primcall op (map E rand*))]
|
|
|
|
[(forcall op rand*) (make-forcall op (map E rand*))]
|
|
|
|
[(funcall rator rand*) (make-funcall (E rator) (map E rand*))]
|
|
|
|
[(appcall rator rand*) (make-appcall (E rator) (map E rand*))]
|
|
|
|
[else (error who "invalid expression ~s" (unparse x))]))
|
|
|
|
(let ([x (E x)])
|
|
|
|
(make-codes all-codes x)))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(define (syntactically-valid? op rand*)
|
|
|
|
(define (valid-arg-count? op rand*)
|
|
|
|
(let ([n (open-coded-primitive-args op)] [m (length rand*)])
|
|
|
|
(cond
|
|
|
|
[(eq? n 'any) #t]
|
|
|
|
[(eq? n 'positive) (fx> m 1)]
|
|
|
|
[(eq? n 'no-code)
|
|
|
|
(error 'syntactically-valid
|
|
|
|
"should not primcall non codable prim ~s" op)]
|
|
|
|
[(fixnum? n)
|
|
|
|
(cond
|
|
|
|
[(fx= n m) #t]
|
|
|
|
[else
|
|
|
|
(error 'compile
|
|
|
|
"Possible incorrect number of args in ~s"
|
|
|
|
(cons op (map unparse rand*)))
|
|
|
|
#f])]
|
|
|
|
[else (error 'do-primcall "BUG: what ~s" n)])))
|
|
|
|
(define (check op pred?)
|
|
|
|
(lambda (arg)
|
|
|
|
(record-case arg
|
|
|
|
[(constant c)
|
|
|
|
(cond
|
|
|
|
[(pred? c) #t]
|
|
|
|
[else
|
|
|
|
(error 'compile "Possible argument error to primitive ~s" op)
|
|
|
|
#f])]
|
|
|
|
[(primref)
|
|
|
|
(cond
|
|
|
|
[(pred? (lambda (x) x)) #t]
|
|
|
|
[else
|
|
|
|
(error 'compile "Possible argument error to primitive ~s" op)
|
|
|
|
#f])]
|
|
|
|
[else #t])))
|
|
|
|
(define (nonnegative-fixnum? n)
|
|
|
|
(and (fixnum? n) (fx>= n 0)))
|
|
|
|
(define (byte? n)
|
|
|
|
(and (fixnum? n) (fx<= 0 n) (fx<= n 127)))
|
|
|
|
(define (valid-arg-types? op rand*)
|
|
|
|
(case op
|
|
|
|
[(fixnum? immediate? boolean? char? vector? string? procedure?
|
|
|
|
null? pair? not cons eq? vector symbol? error eof-object eof-object?
|
|
|
|
void $unbound-object? $code? $forward-ptr? bwp-object?
|
2006-11-23 19:48:14 -05:00
|
|
|
pointer-value top-level-value car cdr list* list $record
|
|
|
|
port? input-port? output-port?
|
|
|
|
$make-port/input $make-port/output $make-port/both
|
|
|
|
$port-handler
|
|
|
|
$port-input-buffer $port-input-index $port-input-size
|
|
|
|
$port-output-buffer $port-output-index $port-output-size
|
|
|
|
$set-port-input-index! $set-port-input-size!
|
|
|
|
$set-port-output-index! $set-port-output-size! )
|
|