Split compiler into separate modules.
Created one module one per pass, plus utilities functions, primitives, and output. Changed extension to ".scm" for compatibility with hg syntax highlighting backend.
This commit is contained in:
parent
786258f144
commit
4b96515362
|
|
@ -0,0 +1,10 @@
|
|||
#! /usr/bin/mzscheme
|
||||
#lang scheme/base
|
||||
|
||||
(require (file "libcompiler/compiler.scm"))
|
||||
(require (file "libcompiler/writer.scm"))
|
||||
|
||||
(write-rla-value (compile-function `(lambda argv ,(read))))
|
||||
(write-char #\Newline)
|
||||
|
||||
; vim:set sw=2 expandtab:
|
||||
1319
compiler.ss
1319
compiler.ss
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,22 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require (file "simplifier.scm"))
|
||||
(require (file "optimizer.scm"))
|
||||
(require (file "mapper.scm"))
|
||||
|
||||
(provide reduce-function
|
||||
compile-function)
|
||||
|
||||
(define optimize? (make-parameter #t))
|
||||
(define box-free-variables? (make-parameter #f))
|
||||
|
||||
(define (compile-function lambda-form)
|
||||
(map-variables (reduce-function lambda-form)))
|
||||
|
||||
(define (reduce-function lambda-form)
|
||||
((compose (if (optimize?) optimize-function values)
|
||||
(if (box-free-variables?) promote-free-variables values)
|
||||
simplify-function)
|
||||
lambda-form))
|
||||
|
||||
; vim:set sw=2 expandtab:
|
||||
|
|
@ -0,0 +1,46 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require scheme/list)
|
||||
(require (file "utilities.scm"))
|
||||
(require (file "primitives.scm"))
|
||||
|
||||
(provide map-variables)
|
||||
|
||||
(define (map-variables lambda/template-form)
|
||||
(let ([bind (fourth lambda/template-form)]
|
||||
[g-vars '()]
|
||||
[unused-g-vars global-variables]
|
||||
[i-vars '()])
|
||||
(define (add-g-var value)
|
||||
(let ([value (if (and (pair? value) (eq? (first value) 'quote))
|
||||
(second value)
|
||||
value)])
|
||||
(let/cc return
|
||||
(for ([g-var (in-list global-variables)]
|
||||
[val (in-list g-vars)])
|
||||
(when (eq? value val) (return g-var)))
|
||||
(let ([g-var (first unused-g-vars)])
|
||||
(set! unused-g-vars (cdr unused-g-vars))
|
||||
(set! g-vars (append g-vars (list value)))
|
||||
g-var))))
|
||||
|
||||
(for ([free-var (in-list (filter frame/instance-variable? (free-variables bind)))]
|
||||
[inst-var (in-list instance-variables)])
|
||||
(set! i-vars (append i-vars (list free-var)))
|
||||
(set! bind (subst-var free-var inst-var bind)))
|
||||
|
||||
(for ([bound-var (in-list (second bind))]
|
||||
[frame-var (in-list frame-variables)])
|
||||
(set! bind (subst-var bound-var frame-var bind)))
|
||||
|
||||
(set! bind (map-form bind
|
||||
#:lambda (lambda (recurse op inner-g-vars i-vars bind)
|
||||
`(%make-lambda ,((compose add-g-var map-variables)
|
||||
`(%template ,inner-g-vars ,i-vars ,bind))))
|
||||
#:variable (lambda (recurse kind form)
|
||||
(if (machine-variable? form) form (add-g-var form)))
|
||||
#:literal (lambda (recurse kind form)
|
||||
(if (eq? form '%nil) form (add-g-var form)))))
|
||||
|
||||
`(,(if (null? i-vars) '%lambda '%template) ,g-vars ,i-vars
|
||||
,bind)))
|
||||
|
|
@ -0,0 +1,136 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require scheme/list)
|
||||
(require (file "utilities.scm"))
|
||||
|
||||
(provide reduce-variables
|
||||
reduce-set!
|
||||
propogate-set!
|
||||
optimize-function)
|
||||
|
||||
(define (optimize-function simple-lambda-form)
|
||||
((compose reduce-variables
|
||||
reduce-set!
|
||||
propogate-set!)
|
||||
simple-lambda-form))
|
||||
|
||||
; Don't bind variables which aren't referenced.
|
||||
(define (reduce-variables form)
|
||||
(define (bind-fn recurse op vars . subforms)
|
||||
(let* ([reduced-forms (map recurse subforms)]
|
||||
[ref-vars (remove-duplicates (append-map free-variables reduced-forms))])
|
||||
(define (referenced? var) (and (memq var ref-vars) #t))
|
||||
`(%bind ,(filter referenced? vars)
|
||||
,@reduced-forms)))
|
||||
(map-form form #:bind bind-fn))
|
||||
|
||||
; Don't set variables which won't be accessed later.
|
||||
(define (reduce-set! form)
|
||||
(define (bind-fn recurse op vars . subforms)
|
||||
(define (prepend-if-used subform after)
|
||||
(if (and (pair? subform)
|
||||
(eq? (first subform) '%set!)
|
||||
(or (memq (second subform) vars)
|
||||
; Top-level (free) variables are presumed to be
|
||||
; constant. The alternative was to assume them
|
||||
; to be boxes, which has its own complications.
|
||||
(error "Setting unbound var:" subform))
|
||||
(not (value-used? (second subform) after)))
|
||||
after
|
||||
(cons subform after)))
|
||||
`(%bind ,vars
|
||||
,@(foldr prepend-if-used '() (map recurse subforms))))
|
||||
(narrow-binds
|
||||
(map-form form #:bind bind-fn)))
|
||||
|
||||
(define (propogate-value variable value invalidates? forms)
|
||||
(if (null? forms)
|
||||
forms
|
||||
(let* ([form (car forms)]
|
||||
[after (cdr forms)]
|
||||
[new-form (case (first form)
|
||||
[(%set!) (if (eq? (third form) variable)
|
||||
`(%set! ,(second form) ,value)
|
||||
form)]
|
||||
[else form])])
|
||||
(if (or (and (eq? (first (car forms)) '%set!)
|
||||
(eq? (second (car forms)) variable))
|
||||
(invalidates? new-form))
|
||||
(cons new-form after)
|
||||
(cons new-form (propogate-value variable value invalidates? after))))))
|
||||
|
||||
; Simple values (literals, variables) can replace arguments as well as %set! values.
|
||||
(define (propogate-simple-value variable value invalidates? forms)
|
||||
(if (null? forms)
|
||||
forms
|
||||
(let* ([form (car forms)]
|
||||
[after (cdr forms)]
|
||||
[new-form (case (first form)
|
||||
[(%set!)
|
||||
(let ([set-value (if (eq? (third form) variable) value (third form))])
|
||||
(if (simple-value? set-value)
|
||||
`(%set! ,(second form) ,set-value)
|
||||
`(%set! ,(second form)
|
||||
(,(first set-value)
|
||||
,@(subst variable value (cdr set-value))))))]
|
||||
[else `(,(first form) ,@(subst variable value (cdr form)))])])
|
||||
(if (or (and (eq? (first (car forms)) '%set!)
|
||||
(eq? (second (car forms)) variable))
|
||||
(invalidates? new-form))
|
||||
(cons new-form after)
|
||||
(cons new-form (propogate-simple-value variable value invalidates? after))))))
|
||||
|
||||
; When value of var2 is known, change (%set! var1 var2) to (%set! var1 value).
|
||||
; Known values are:
|
||||
; literals, always
|
||||
; var, until (%set! var ...)
|
||||
; (%unbox var), until (%set-box! var ...) or (%set! var)
|
||||
; (%car var), until (%set-car! var) or (%set! var)
|
||||
; (%cdr var), until (%set-cdr! var) or (%set! var)
|
||||
(define (propogate-set! form)
|
||||
(define (bind-fn recurse op vars . subforms)
|
||||
(define (prepend subform after)
|
||||
(if (eq? (first subform) '%set!)
|
||||
(let ([var (second subform)]
|
||||
[value (third subform)])
|
||||
(cons
|
||||
subform
|
||||
(cond
|
||||
[(simple-value? value)
|
||||
(propogate-simple-value var value
|
||||
(lambda (form)
|
||||
(and (eq? (first form) '%set!)
|
||||
(eq? (second form) value)))
|
||||
after)]
|
||||
[(eq? (first value) '%unbox)
|
||||
(let ([box-var (second value)])
|
||||
(propogate-value var value
|
||||
(lambda (form)
|
||||
(or (and (eq? (first form) '%set!)
|
||||
(eq? (second form) box-var))
|
||||
(and (eq? (first form) '%set-box!)
|
||||
(eq? (second form) box-var))))
|
||||
after))]
|
||||
[(eq? (first value) '%car)
|
||||
(let ([pair-var (second value)])
|
||||
(propogate-value var value
|
||||
(lambda (form)
|
||||
(or (and (eq? (first form) '%set!)
|
||||
(eq? (second form) pair-var))
|
||||
(and (eq? (first form) '%set-car!)
|
||||
(eq? (second form) pair-var))))
|
||||
after))]
|
||||
[(eq? (first value) '%cdr)
|
||||
(let ([pair-var (second value)])
|
||||
(propogate-value var value
|
||||
(lambda (form)
|
||||
(or (and (eq? (first form) '%set!)
|
||||
(eq? (second form) pair-var))
|
||||
(and (eq? (first form) '%set-cdr!)
|
||||
(eq? (second form) pair-var))))
|
||||
after))]
|
||||
[else after])))
|
||||
(cons subform after)))
|
||||
`(%bind ,vars
|
||||
,@(foldr prepend '() (map recurse subforms))))
|
||||
(map-form form #:bind bind-fn))
|
||||
|
|
@ -0,0 +1,181 @@
|
|||
#lang scheme/base
|
||||
|
||||
(provide unary-value-primitives
|
||||
binary-value-primitives
|
||||
unary-statement-primitives
|
||||
binary-statement-primitives
|
||||
ternary-statement-primitives
|
||||
value-primitives
|
||||
statement-primitives
|
||||
all-primitives
|
||||
global-variables
|
||||
instance-variables
|
||||
frame-variables
|
||||
special-variables
|
||||
global-variable?
|
||||
instance-variable?
|
||||
frame-variable?
|
||||
special-variable?
|
||||
frame/instance-variable?
|
||||
machine-variable?)
|
||||
|
||||
(define unary-value-primitives
|
||||
'((%unbox #x02 unbox)
|
||||
(%car #x03 car)
|
||||
(%cdr #x04 cdr)
|
||||
(%boolean? #x08 boolean?)
|
||||
(%fixnum? #x09 fixnum?)
|
||||
(%box? #x0a box?)
|
||||
(%pair? #x0b pair?)
|
||||
(%vector? #x0c vector?)
|
||||
(%byte-string? #x0d byte-string?)
|
||||
(%struct? #x0e struct?)
|
||||
(%float? #x0f float?)
|
||||
(%builtin? #x10 builtin?)
|
||||
(%make-box #x18 make-box)
|
||||
(%make-struct #x19 make-struct)
|
||||
(%make-float #x1a make-float)
|
||||
(%make-lambda #x1b make-lambda)
|
||||
(%not #x20 not)
|
||||
(%bit-not #x21 bit-not)
|
||||
(%fix- #x22 fix-)
|
||||
(%float- #x23 float-)
|
||||
(%vector-size #x28 vector-size)
|
||||
(%byte-string-size #x29 byte-string-size)
|
||||
(%struct-nslots #x2a struct-nslots)
|
||||
(%struct-type #x2b struct-type)
|
||||
(%acos #x30 acos)
|
||||
(%asin #x31 asin)
|
||||
(%atan #x32 atan)
|
||||
(%cos #x33 cos)
|
||||
(%sin #x34 sin)
|
||||
(%tan #x35 tan)
|
||||
(%cosh #x36 cosh)
|
||||
(%sinh #x37 sinh)
|
||||
(%tanh #x38 tanh)
|
||||
(%exp #x39 exp)
|
||||
(%frexp #x3a frexp)
|
||||
(%log #x3b log)
|
||||
(%log10 #x3c log10)
|
||||
(%modf #x3d modf)
|
||||
(%sqrt #x3e sqrt)
|
||||
(%ceil #x3f ceil)
|
||||
(%fabs #x40 fabs)
|
||||
(%floor #x41 floor)
|
||||
(%erf #x50 erf)
|
||||
(%erfc #x51 erfc)
|
||||
(%j0 #x52 j0)
|
||||
(%j1 #x53 j1)
|
||||
(%lgamma #x54 lgamma)
|
||||
(%y0 #x55 y0)
|
||||
(%y1 #x56 y1)
|
||||
(%asinh #x57 asinh)
|
||||
(%acosh #x58 acosh)
|
||||
(%atanh #x59 atanh)
|
||||
(%cbrt #x5a cbrt)
|
||||
(%logb #x5b logb)
|
||||
(%expm1 #x5c expm1)
|
||||
(%ilogb #x5d ilogb)
|
||||
(%log1p #x5e log1p)
|
||||
(%normal? #x70 normal?)
|
||||
(%finite? #x71 finite?)
|
||||
(%subnormal? #x72 subnormal?)
|
||||
(%infinite? #x73 infinite?)
|
||||
(%nan? #x74 nan?)))
|
||||
|
||||
(define binary-value-primitives
|
||||
'((%eq? #x01 eq?)
|
||||
(%cons #x02 cons)
|
||||
(%make-vector #x03 make-vector)
|
||||
(%make-byte-string #x04 make-byte-string)
|
||||
(%vector-ref #x05 vector-ref)
|
||||
(%byte-string-ref #x06 byte-string-ref)
|
||||
(%struct-ref #x07 struct-ref)
|
||||
(%fix+ #x08 fix+)
|
||||
(%fix- #x09 fix-)
|
||||
(%fix* #x0a fix*)
|
||||
(%fix/ #x0b fix/)
|
||||
(%fix% #x0c fix%)
|
||||
(%fix< #x0d fix<)
|
||||
(%fix>= #x0e fix>=)
|
||||
(%bit-and #x10 bit-and)
|
||||
(%bit-or #x11 bit-or)
|
||||
(%bit-xor #x12 bit-xor)
|
||||
(%fix<< #x14 fix<<)
|
||||
(%fix>> #x15 fix>>)
|
||||
(%fix>>> #x16 fix>>>)
|
||||
(%float+ #x18 float+)
|
||||
(%float- #x19 float-)
|
||||
(%float* #x1a float*)
|
||||
(%float/ #x1b float/)
|
||||
(%float= #x1c float=)
|
||||
(%float< #x1d float<)
|
||||
(%float>= #x1e float>=)
|
||||
(%atan2 #x20 atan2)
|
||||
(%pow #x21 pow)
|
||||
(%ldexp #x22 ldexp)
|
||||
(%fmod #x23 fmod)
|
||||
(%hypot #x24 hypot)
|
||||
(%jn #x25 jn)
|
||||
(%yn #x26 yn)
|
||||
(%nextafter #x27 nextafter)
|
||||
(%remainder #x28 remainder)
|
||||
(%scalb #x29 scalb)))
|
||||
|
||||
(define unary-statement-primitives
|
||||
'((%goto-end-if #x40 #f)
|
||||
(%goto-end-unless #x41 #f)))
|
||||
|
||||
(define binary-statement-primitives
|
||||
'((%set-box! #x50 set-box!)
|
||||
(%set-car! #x51 set-car!)
|
||||
(%set-cdr! #x52 set-cdr!)))
|
||||
|
||||
(define ternary-statement-primitives
|
||||
'((%vector-set! #x60 vector-set!)
|
||||
(%byte-string-set! #x61 byte-string-set!)
|
||||
(%struct-set! #x62 struct-set!)))
|
||||
|
||||
(define value-primitives
|
||||
(append unary-value-primitives
|
||||
binary-value-primitives
|
||||
(list '(%if #f #f))))
|
||||
|
||||
(define statement-primitives
|
||||
(append unary-statement-primitives
|
||||
binary-statement-primitives
|
||||
ternary-statement-primitives))
|
||||
|
||||
(define all-primitives
|
||||
(append value-primitives statement-primitives))
|
||||
|
||||
(define global-variables
|
||||
(for/list ([i (in-range 1 64)])
|
||||
(string->uninterned-symbol (string-append "%g" (number->string i)))))
|
||||
|
||||
(define instance-variables
|
||||
(for/list ([i (in-range 0 64)])
|
||||
(string->uninterned-symbol (string-append "%i" (number->string i)))))
|
||||
|
||||
(define frame-variables
|
||||
(for/list ([i (in-range 0 120)])
|
||||
(string->uninterned-symbol (string-append "%f" (number->string i)))))
|
||||
|
||||
(define special-variables
|
||||
'(%nil %self %argv %ctx %k))
|
||||
|
||||
(define (global-variable? var) (and (memq var global-variables) #t))
|
||||
(define (instance-variable? var) (and (memq var instance-variables) #t))
|
||||
(define (frame-variable? var) (and (memq var frame-variables) #t))
|
||||
(define (special-variable? var) (and (memq var special-variables) #t))
|
||||
|
||||
(define (frame/instance-variable? var)
|
||||
(or (frame-variable? var)
|
||||
(instance-variable? var)))
|
||||
|
||||
(define (machine-variable? var)
|
||||
(or (special-variable? var)
|
||||
(frame/instance-variable? var)
|
||||
(global-variable? var)))
|
||||
|
||||
; vim:set sw=2 expandtab:
|
||||
|
|
@ -0,0 +1,493 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require scheme/list)
|
||||
(require (file "utilities.scm"))
|
||||
(require (file "primitives.scm"))
|
||||
|
||||
(provide simplify-function
|
||||
promote-free-variables)
|
||||
|
||||
(define (simplify-function lambda-form)
|
||||
((compose promote-shared-variables
|
||||
simplify-lambda)
|
||||
lambda-form))
|
||||
|
||||
(define (simplify-form form)
|
||||
(define (same-form recurse . form) form)
|
||||
(map-form form
|
||||
#:bind same-form
|
||||
#:lambda same-form
|
||||
#:set same-form
|
||||
#:primitive same-form
|
||||
#:simple (lambda (recurse kind form) form)
|
||||
#:literal (lambda (recurse kind form)
|
||||
(if (and (pair? form)
|
||||
(eq? (first form) 'quote)
|
||||
(eq? (second form) '()))
|
||||
'%nil
|
||||
form))
|
||||
#:other (lambda (recurse op . others)
|
||||
(case op
|
||||
[(let) (simplify-let form)]
|
||||
[(let*) (simplify-let* form)]
|
||||
[(letrec) (simplify-letrec form)]
|
||||
[(if) (simplify-if form)]
|
||||
[(lambda) (simplify-lambda form)]
|
||||
[(begin) (simplify-form `(let () ,@(cdr form)))]
|
||||
[(set!) (simplify-set! form)]
|
||||
[(let/cc) (simplify-form
|
||||
`(call/cc (lambda (,(second form)) ,@(cddr form))))]
|
||||
[(fix>) (simplify-form
|
||||
(let ([a (gensym)] [b (gensym)])
|
||||
`(let ([,a ,(second form)]
|
||||
[,b ,(third form)])
|
||||
(fix< ,b ,a))))]
|
||||
[(fix<=) (simplify-form
|
||||
(let ([a (gensym)] [b (gensym)])
|
||||
`(let ([,a ,(second form)]
|
||||
[,b ,(third form)])
|
||||
(fix>= ,b ,a))))]
|
||||
[(values) (simplify-primitive '%values (cdr form))]
|
||||
[(call/cc) (simplify-primitive '%call/cc (cdr form))]
|
||||
[else
|
||||
(let ([primitive (memf (lambda (x) (eq? (third x) (first form)))
|
||||
all-primitives)])
|
||||
(if primitive
|
||||
(simplify-primitive (first (first primitive))
|
||||
(cdr form))
|
||||
(simplify-funcall form)))]))))
|
||||
|
||||
(define (simplify-set! form)
|
||||
(let ([variable (second form)]
|
||||
[value-form (simplify-form (third form))])
|
||||
(if (and (pair? value-form) (eq? (first value-form) '%bind))
|
||||
(if (memq variable (second value-form))
|
||||
(let ([tmp (gensym)])
|
||||
`(%bind (,tmp)
|
||||
; guaranteed not to cause unbounded recursion: tmp is unique
|
||||
,(simplify-set! `(set! ,tmp ,value-form))
|
||||
(%set! ,variable ,tmp)))
|
||||
`(%bind ,(second value-form)
|
||||
,@(foldr (lambda (subform after)
|
||||
(cond
|
||||
[(pair? after) (cons subform after)]
|
||||
[(and (pair? subform) (eq? (first subform) '%values))
|
||||
; Requires at least one value; ignores extras.
|
||||
(if (null? (cdr subform))
|
||||
(error "Attempted to set variable to void in:" form)
|
||||
`((%set! ,variable ,(second subform))))]
|
||||
[(value-form? subform)
|
||||
(list (simplify-set! `(set! ,variable ,subform)))]
|
||||
[else (error "Attempted to set variable to void in:" form)]))
|
||||
'()
|
||||
(cddr value-form))))
|
||||
`(%set! ,variable ,value-form))))
|
||||
|
||||
(define (simplify-primitive simple-op value-forms)
|
||||
(define (value->binding value-form)
|
||||
(let ([simple-value-form (simplify-form value-form)])
|
||||
(if (simple-value? simple-value-form)
|
||||
(list simple-value-form #f)
|
||||
(let ([tmp (gensym)])
|
||||
(list tmp (simplify-set! `(set! ,tmp ,simple-value-form)))))))
|
||||
|
||||
(define bindings (map value->binding value-forms))
|
||||
|
||||
(simplify-form
|
||||
`(let ,(map first (filter second bindings))
|
||||
,@(filter-map second bindings)
|
||||
(,simple-op ,@(map first bindings)))))
|
||||
|
||||
; (let ([var expr]...) bodyexpr...) ; first eval exprs, then assign bindings in parallel
|
||||
; => (%bind (tmp...)
|
||||
; (%set! tmp ,(simplify-form expr))...
|
||||
; (%bind (var...)
|
||||
; (%set! var tmp)...
|
||||
; bodyexpr...))
|
||||
|
||||
(define (simplify-let form)
|
||||
(define (simplify-binding binding)
|
||||
(if (pair? binding)
|
||||
(list (first binding) (simplify-form (second binding)))
|
||||
(list binding)))
|
||||
(define bindings (map simplify-binding (second form)))
|
||||
(define bodyexprs (cddr form))
|
||||
|
||||
(define (has-value? binding) (pair? (cdr binding)))
|
||||
(define vars (map first bindings))
|
||||
(define (bound-var? var) (and (memq var vars) #t))
|
||||
|
||||
; If the value of any binding refers to one of the variable names being bound...
|
||||
(if (ormap (lambda (value) (ormap bound-var? (free-variables value)))
|
||||
(map second (filter has-value? bindings)))
|
||||
; ...then bind the values to temps first, before binding the real names.
|
||||
(let ([temp-bindings (map (lambda (binding)
|
||||
(let ([tmp (gensym)])
|
||||
(list tmp
|
||||
(simplify-form `(set! ,tmp ,(second binding)))
|
||||
`(%set! ,(first binding) ,tmp))))
|
||||
(filter has-value? bindings))])
|
||||
`(%bind ,(map first temp-bindings)
|
||||
,@(map second temp-bindings)
|
||||
(%bind ,vars
|
||||
,@(map third temp-bindings)
|
||||
,@(map simplify-form bodyexprs))))
|
||||
; Otherwise, just bind the real names directly.
|
||||
`(%bind ,vars
|
||||
,@(map (lambda (binding)
|
||||
(simplify-set! `(set! ,@binding)))
|
||||
(filter has-value? bindings))
|
||||
,@(map simplify-form bodyexprs))))
|
||||
|
||||
; (let* ...) ; eval exprs & bind variables serially
|
||||
; => (let ([var-0 expr-0])
|
||||
; (let ([var-1 expr-1])
|
||||
; (...
|
||||
; bodyexprs...)))
|
||||
|
||||
(define (simplify-let* form)
|
||||
(define bindings (second form))
|
||||
(define bodyexprs (cddr form))
|
||||
(define (add-binding bind bodyexpr)
|
||||
`(let (,bind) ,bodyexpr))
|
||||
(simplify-form (foldr add-binding `(begin ,@bodyexprs) bindings)))
|
||||
|
||||
; (letrec ...) ; init bindings to undefined, then assign values in series
|
||||
; => (let (var...)
|
||||
; (set! var expr)...
|
||||
; bodyexprs)
|
||||
|
||||
(define (simplify-letrec form)
|
||||
(define bindings (second form))
|
||||
(define bodyexprs (cddr form))
|
||||
(simplify-form
|
||||
`(let (,@(map (lambda (x) (if (pair? x) (first x) x)) bindings))
|
||||
,@(append-map
|
||||
(lambda (x)
|
||||
(if (pair? x)
|
||||
`((set! ,(first x) ,(second x)))
|
||||
'()))
|
||||
bindings)
|
||||
,@bodyexprs)))
|
||||
|
||||
(define (simplify-if form)
|
||||
(define-values (cond-expr true-expr false-expr)
|
||||
(apply values (cdr form)))
|
||||
(let ([true-form (simplify-form true-expr)]
|
||||
[false-form (simplify-form false-expr)]
|
||||
[cond-val (gensym)])
|
||||
(simplify-form
|
||||
(if (and (simple-value? true-form)
|
||||
(simple-value? false-form))
|
||||
`(let ([,cond-val ,cond-expr])
|
||||
(%if ,cond-val ,true-form ,false-form))
|
||||
(let ([next-fn (gensym)]
|
||||
[true-fn (gensym)]
|
||||
[false-fn (gensym)])
|
||||
`(let ([,cond-val ,cond-expr]
|
||||
[,true-fn (lambda () ,true-form)]
|
||||
[,false-fn (lambda () ,false-form)])
|
||||
(let ([,next-fn (%if ,cond-val ,true-fn ,false-fn)])
|
||||
(%apply ,next-fn %nil))))))))
|
||||
|
||||
; (lambda (required... [optional default-expr]... . rest) bodyexpr...)
|
||||
; => (lambda argv
|
||||
; (let ([argv-temp argv])
|
||||
; (let ([required-0 (car argv-temp)])
|
||||
; (set! argv-temp (cdr argv-temp)))
|
||||
; (let ([required-1 (car argv-temp)])
|
||||
; (set! argv-temp (cdr argv-temp)))
|
||||
; (...
|
||||
; (let (optional-0)
|
||||
; (if (eq? argv-temp %nil)
|
||||
; (set! optional-0 default-expr-0)
|
||||
; (set! optional-0 (car argv-temp)))
|
||||
; (set! argv-temp (cdr argv-temp))
|
||||
; (let (optional-1)
|
||||
; (if (eq? argv-temp %nil)
|
||||
; (set! optional-1 default-expr-1)
|
||||
; (set! optional-1 (car argv-temp)))
|
||||
; (set! argv-temp (cdr argv-temp))
|
||||
; (...
|
||||
; (let ([rest argv-temp])
|
||||
; bodyexpr...)...)))...)))
|
||||
|
||||
(define (split-arglist arglist)
|
||||
(define (split-optional arglist)
|
||||
(if (pair? arglist)
|
||||
(let-values ([(opt rst) (split-optional (cdr arglist))])
|
||||
(values (cons (car arglist) opt) rst))
|
||||
(values '() arglist)))
|
||||
(cond
|
||||
[(null? arglist) (values '() '() #f)]
|
||||
[(not (pair? arglist)) (values '() '() arglist)]
|
||||
[(pair? (car arglist)) (let-values ([(opt rst) (split-optional arglist)])
|
||||
(values '() opt rst))]
|
||||
[else (let-values ([(req opt rst) (split-arglist (cdr arglist))])
|
||||
(values (cons (car arglist) req) opt rst))]))
|
||||
|
||||
(define (add-return ctx k nested-bind)
|
||||
(define flat-bind (flatten-binds nested-bind))
|
||||
(define argv (gensym))
|
||||
`(%bind (,@(second flat-bind) ,argv)
|
||||
,@(foldr (lambda (subform after)
|
||||
(cond
|
||||
[(pair? after)
|
||||
(cons subform after)]
|
||||
[(simple-value? subform)
|
||||
`((%set! ,argv (%cons ,subform %nil))
|
||||
(%tail-call ,k ,argv #f #f))]
|
||||
[(eq? (first subform) '%apply)
|
||||
`((%tail-call ,(second subform) ,(third subform) ,ctx ,k))]
|
||||
[(eq? (first subform) '%call/cc)
|
||||
`((%set! ,argv (%cons %k %nil))
|
||||
(%tail-call ,(second subform) ,argv ,ctx %k))]
|
||||
[(eq? (first subform) '%values)
|
||||
`((%set! ,argv %nil)
|
||||
,@(map (lambda (sv) `(%set! ,argv (%cons ,sv ,argv)))
|
||||
(reverse (cdr subform)))
|
||||
(%tail-call ,k ,argv #f #f))]
|
||||
[(value-form? subform)
|
||||
`((%set! ,argv ,subform)
|
||||
(%set! ,argv (%cons ,argv %nil))
|
||||
(%tail-call ,k ,argv #f #f))]
|
||||
[(eq? (first subform) '%tail-call)
|
||||
`(,subform)]
|
||||
[else
|
||||
`(,subform
|
||||
(%tail-call ,k %nil #f #f))]))
|
||||
'()
|
||||
(cddr flat-bind))))
|
||||
|
||||
; <= (%bind (var...)
|
||||
; @before
|
||||
; (%apply x y)
|
||||
; @after))
|
||||
; => (%bind (var... k)
|
||||
; @before
|
||||
; (%set! k (lambda _ @after))
|
||||
; (%tail-call x y ctx k)))
|
||||
|
||||
; <= (%bind (var...)
|
||||
; @before
|
||||
; (%set! v (%apply x y))
|
||||
; @after))
|
||||
; => (%bind (var... k)
|
||||
; @before
|
||||
; (%set! k (lambda (x)
|
||||
; (%set! v x)
|
||||
; @after))
|
||||
; (%tail-call x y ctx k)))
|
||||
|
||||
; <= (%bind (var...)
|
||||
; @before
|
||||
; (call/cc l)
|
||||
; @after)
|
||||
; => (%bind (var... k k2)
|
||||
; @before
|
||||
; (%set! k (lambda _ @after))
|
||||
; (%set! k-argv (%cons k %nil))
|
||||
; (%tail-call l k-argv ctx k))
|
||||
|
||||
(define (transform-to-cps ctx nested-bind)
|
||||
(define flat-bind (flatten-binds nested-bind))
|
||||
(define (cps-prepend subform after)
|
||||
(cond
|
||||
; (%set! v (%apply x y))
|
||||
[(and (pair? subform)
|
||||
(eq? (first subform) '%set!)
|
||||
(pair? (third subform))
|
||||
(eq? (first (third subform)) '%apply))
|
||||
(let ([k (gensym)]
|
||||
[x (gensym)])
|
||||
`((%bind (,k ,x)
|
||||
(%set! ,k ,(simplify-form
|
||||
`(lambda (,x . ,(gensym))
|
||||
(%set! ,(second subform) ,x)
|
||||
,@after)))
|
||||
(%tail-call ,(second (third subform))
|
||||
,(third (third subform))
|
||||
,ctx
|
||||
,k))))]
|
||||
; (%apply x y)
|
||||
[(and (pair? subform)
|
||||
(eq? (first subform) '%apply))
|
||||
(let ([k (gensym)])
|
||||
`((%bind (,k)
|
||||
(%set! ,k ,(simplify-form
|
||||
`(lambda ,(gensym)
|
||||
,@after)))
|
||||
(%tail-call ,(second subform)
|
||||
,(third subform)
|
||||
,ctx
|
||||
,k))))]
|
||||
; (%set! v (%call/cc x))
|
||||
[(and (pair? subform)
|
||||
(eq? (first subform) '%set!)
|
||||
(pair? (third subform))
|
||||
(eq? (first (third subform)) '%call/cc))
|
||||
(let ([k (gensym)]
|
||||
[k-argv (gensym)]
|
||||
[x (gensym)])
|
||||
`((%bind (,k ,k-argv)
|
||||
(%set! ,k ,(simplify-form
|
||||
`(lambda (,x . ,(gensym))
|
||||
(%set! ,(second subform) ,x)
|
||||
,@after)))
|
||||
(%set! ,k-argv (%cons ,k %nil))
|
||||
(%tail-call ,(second (third subform))
|
||||
,k-argv
|
||||
,ctx
|
||||
,k))))]
|
||||
; (%call/cc x)
|
||||
[(and (pair? subform)
|
||||
(eq? (first subform) '%call/cc))
|
||||
(let ([k (gensym)]
|
||||
[k-argv (gensym)])
|
||||
`((%bind (,k ,k-argv)
|
||||
(%set! ,k ,(simplify-form
|
||||
`(lambda ,(gensym)
|
||||
,@after)))
|
||||
(%set! ,k-argv (%cons ,k %nil))
|
||||
(%tail-call ,(second subform)
|
||||
,k-argv
|
||||
,ctx
|
||||
,k))))]
|
||||
; keep all other forms with side-effects as-is
|
||||
[(statement-form? subform)
|
||||
(cons subform after)]
|
||||
; discard any form without side-effects
|
||||
[else after]))
|
||||
(flatten-binds
|
||||
`(%bind ,(second flat-bind)
|
||||
,@(foldr cps-prepend '() (cddr flat-bind)))))
|
||||
|
||||
(define (simplify-lambda form)
|
||||
(define arglist (car (cdr form)))
|
||||
(define bodyexprs (cdr (cdr form)))
|
||||
|
||||
(define-values (requireds optionals rest) (split-arglist arglist))
|
||||
(define argv (gensym))
|
||||
(define ctx (gensym))
|
||||
(define k (gensym))
|
||||
|
||||
(define (add-req req inner) `(let ([,req (car ,argv)])
|
||||
(set! ,argv (cdr ,argv))
|
||||
,inner))
|
||||
(define (add-opt opt-list inner) `(let (,(car opt-list))
|
||||
(if (pair? ,argv)
|
||||
(begin
|
||||
(set! ,(first opt-list) (car ,argv))
|
||||
(set! ,argv (cdr ,argv)))
|
||||
(set! ,(first opt-list) ,(second opt-list)))
|
||||
,inner))
|
||||
(define rest+bodyexprs (if rest `(let ([,rest ,argv]) ,@bodyexprs)
|
||||
`(begin ,@bodyexprs)))
|
||||
(narrow-binds
|
||||
`(%lambda () ()
|
||||
,((compose (lambda (bind) (transform-to-cps ctx bind))
|
||||
(lambda (bind) (add-return ctx k bind)))
|
||||
(simplify-form
|
||||
`(let ([,argv %argv]
|
||||
[,ctx %ctx]
|
||||
[,k %k])
|
||||
,(foldr add-req
|
||||
(foldr add-opt
|
||||
rest+bodyexprs
|
||||
optionals)
|
||||
requireds)))))))
|
||||
|
||||
; (fn-expr arg-expr...)
|
||||
; => (let ([fn-var fn-expr] arg-var... argv)
|
||||
; (set! fn-var fn-expr)
|
||||
; (set! arg-var arg-expr)...
|
||||
; (set! argv %nil)
|
||||
; (set! argv (cons arg-var argv))... [reversed]
|
||||
; (%apply fn-var argv))
|
||||
|
||||
(define (simplify-funcall form)
|
||||
(define fn-expr (car form))
|
||||
(define arg-exprs (cdr form))
|
||||
(define fn-var (gensym))
|
||||
(define arg-vars (map (lambda (x) (gensym)) arg-exprs))
|
||||
(define argv (gensym))
|
||||
(simplify-form
|
||||
`(let (,fn-var ,@arg-vars ,argv)
|
||||
(set! ,fn-var ,fn-expr)
|
||||
,@(map (lambda (x y) `(set! ,x ,y)) arg-vars arg-exprs)
|
||||
(%set! ,argv %nil)
|
||||
,@(reverse (map (lambda (x) `(%set! ,argv (%cons ,x ,argv))) arg-vars))
|
||||
(%apply ,fn-var ,argv))))
|
||||
|
||||
(define (promote-to-box variable form)
|
||||
(map-form form
|
||||
#:bind (lambda (recurse op vars . subforms)
|
||||
(flatten-binds
|
||||
`(%bind ,(subst variable variable vars)
|
||||
,@(if (memq variable vars)
|
||||
`((%set! ,variable (%make-box %undef)))
|
||||
'())
|
||||
,@(map recurse subforms))))
|
||||
#:set (lambda (recurse op var value)
|
||||
(let ([new-value (recurse value)])
|
||||
(if (eq? var variable)
|
||||
(if (simple-value? new-value)
|
||||
`(%set-box! ,variable ,new-value)
|
||||
(let ([tmp (gensym)])
|
||||
`(%bind (,tmp)
|
||||
,(simplify-set! `(set! ,tmp ,new-value))
|
||||
(%set-box! ,variable ,tmp))))
|
||||
(simplify-set! `(set! ,var ,new-value)))))
|
||||
#:primitive (lambda (recurse op . simple-values)
|
||||
(let ([new-args (map recurse simple-values)])
|
||||
;; if any new-arg is not simple, must bind to a temp first
|
||||
(let ([temps (map (lambda (x)
|
||||
(if (simple-value? x)
|
||||
(list x #f)
|
||||
(let ([tmp (gensym)])
|
||||
(list tmp `(%set! ,tmp ,x)))))
|
||||
new-args)])
|
||||
(if (ormap second temps)
|
||||
`(%bind ,(map first (filter second temps))
|
||||
,@(filter-map second temps)
|
||||
(,op ,@(map first temps)))
|
||||
`(,op ,@new-args)))))
|
||||
#:variable (lambda (recurse op var)
|
||||
(if (eq? var variable) `(%unbox ,variable) var))))
|
||||
|
||||
; form needs to be flattened (%bind ...)
|
||||
(define (is-shared-var? var bind)
|
||||
(define captured-input? (ormap (lambda (f) (form-captures-input? f var)) (cddr bind)))
|
||||
(define captured-output? (ormap (lambda (f) (form-captures-output? f var)) (cddr bind)))
|
||||
(define (set-after-first-use?)
|
||||
(let/cc return
|
||||
(foldr (lambda (subform set-after?)
|
||||
(if (or set-after? (form-sets? subform var captured-output?))
|
||||
(if (form-uses? subform var captured-input?)
|
||||
(return #t)
|
||||
#t)
|
||||
#f))
|
||||
#f
|
||||
(cddr bind))
|
||||
#f))
|
||||
(and (not (special-variable? var))
|
||||
(or captured-input?
|
||||
captured-output?)
|
||||
(set-after-first-use?)))
|
||||
|
||||
(define (promote-shared-variables simple-lambda-form)
|
||||
(define bind (fourth simple-lambda-form))
|
||||
`(%lambda ,(second simple-lambda-form) ,(third simple-lambda-form)
|
||||
,(foldl (lambda (var frm)
|
||||
(if (is-shared-var? var frm)
|
||||
(promote-to-box var frm)
|
||||
frm))
|
||||
bind
|
||||
(second bind))))
|
||||
|
||||
(define (promote-free-variables simple-lambda-form)
|
||||
(define bind (fourth simple-lambda-form))
|
||||
`(%lambda ,(second simple-lambda-form) ,(third simple-lambda-form)
|
||||
,(foldl promote-to-box bind (free-variables bind))))
|
||||
|
||||
; vim:set sw=2 expandtab:
|
||||
|
|
@ -0,0 +1,339 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require scheme/list)
|
||||
(require scheme/pretty)
|
||||
(require (file "primitives.scm"))
|
||||
|
||||
(provide trace
|
||||
subst
|
||||
find
|
||||
variable-value?
|
||||
literal-value?
|
||||
simple-value?
|
||||
value-form?
|
||||
statement-form?
|
||||
primitive-form?
|
||||
pure-form?
|
||||
bind-form?
|
||||
map-form
|
||||
search-form
|
||||
form-sets?
|
||||
form-uses?
|
||||
form-captures?
|
||||
form-captures-input?
|
||||
form-captures-output?
|
||||
narrow-binds
|
||||
subst-var
|
||||
flatten-binds
|
||||
free-variables
|
||||
free-input-variables
|
||||
free-output-variables
|
||||
value-used?)
|
||||
|
||||
(define (trace fn . args)
|
||||
(let ([x (apply fn args)])
|
||||
(pretty-print (list fn x))
|
||||
x))
|
||||
|
||||
(define (subst old new lst)
|
||||
(foldr (lambda (x rst)
|
||||
(cons (if (eq? x old)
|
||||
new
|
||||
x)
|
||||
rst))
|
||||
'()
|
||||
lst))
|
||||
|
||||
(define (find x lst)
|
||||
(let/cc return
|
||||
(for ([i (in-naturals 0)]
|
||||
[y (in-list lst)])
|
||||
(when (eq? y x) (return i)))
|
||||
#f))
|
||||
|
||||
(define (variable-value? form)
|
||||
(and (symbol? form)
|
||||
(not (eq? form '%undef))))
|
||||
|
||||
(define (literal-value? form)
|
||||
(and (not (variable-value? form))
|
||||
(or (not (pair? form))
|
||||
(eq? (first form) 'quote)
|
||||
(eq? (first form) '%template))))
|
||||
|
||||
(define (simple-value? form)
|
||||
(or (variable-value? form)
|
||||
(literal-value? form)))
|
||||
|
||||
; A value-form is any simple form which can appear on the right-hand side of a (set! ...).
|
||||
; If there are any side-effect they occur before the variable is updated.
|
||||
(define (value-form? form)
|
||||
(define complex-values '(%bind %apply %call/cc %values))
|
||||
(or (simple-value? form)
|
||||
(memq (first form) complex-values)
|
||||
(memq (first form) (map first value-primitives))))
|
||||
|
||||
; A statement-form is any simple form which has, or may have, side-effects.
|
||||
(define (statement-form? form)
|
||||
(define complex-statements '(%set! %apply %call/cc %tail-call))
|
||||
(and (not (simple-value? form))
|
||||
(or (memq (first form) complex-statements)
|
||||
(memq (first form) (map first statement-primitives)))))
|
||||
|
||||
(define (primitive-form? form)
|
||||
(and (pair? form) (memq (first form) (map first all-primitives))))
|
||||
|
||||
; A pure form is any form known to be free of side-effects.
|
||||
(define (pure-form? form)
|
||||
(and (value-form? form)
|
||||
(not (statement-form? form))))
|
||||
|
||||
(define (bind-form? form)
|
||||
(and (pair? form) (eq? (first form) '%bind)))
|
||||
|
||||
(define (map-form form
|
||||
#:bind [bind-fn (lambda (recurse op vars . subforms)
|
||||
`(,op ,vars ,@(map recurse subforms)))]
|
||||
#:lambda [lambda-fn (lambda (recurse op g-vars i-vars bind)
|
||||
`(,op ,g-vars ,i-vars ,(recurse bind)))]
|
||||
#:set [set-fn (lambda (recurse op var value)
|
||||
`(,op ,var ,(recurse value)))]
|
||||
|
||||
#:primitive [primitive-fn (lambda (recurse op . simple-values)
|
||||
`(,op ,@(map recurse simple-values)))]
|
||||
#:values [values-fn primitive-fn]
|
||||
#:call [call-fn primitive-fn]
|
||||
#:apply [apply-fn call-fn]
|
||||
#:call/cc [call/cc-fn call-fn]
|
||||
#:tail-call [tail-call-fn call-fn]
|
||||
|
||||
#:simple [simple-fn (lambda (recurse kind form) form)]
|
||||
#:variable [variable-fn simple-fn]
|
||||
#:literal [literal-fn simple-fn]
|
||||
|
||||
#:other [other-fn (lambda (recurse . form)
|
||||
(error "Unsimplified form:" form))])
|
||||
(define (recurse subform)
|
||||
(map-form subform
|
||||
#:bind bind-fn
|
||||
#:lambda lambda-fn
|
||||
#:set set-fn
|
||||
#:primitive primitive-fn
|
||||
#:values values-fn
|
||||
#:call call-fn
|
||||
#:apply apply-fn
|
||||
#:call/cc call/cc-fn
|
||||
#:tail-call tail-call-fn
|
||||
#:simple simple-fn
|
||||
#:variable variable-fn
|
||||
#:literal literal-fn
|
||||
#:other other-fn))
|
||||
|
||||
(cond
|
||||
[(variable-value? form) (variable-fn recurse 'variable form)]
|
||||
[(literal-value? form) (literal-fn recurse 'literal form)]
|
||||
[else
|
||||
(let ([handler (case (first form)
|
||||
[(%bind) bind-fn]
|
||||
[(%lambda) lambda-fn]
|
||||
[(%set!) set-fn]
|
||||
[(%values) values-fn]
|
||||
[(%apply) apply-fn]
|
||||
[(%call/cc) call/cc-fn]
|
||||
[(%tail-call) tail-call-fn]
|
||||
[else (if (primitive-form? form)
|
||||
primitive-fn
|
||||
other-fn)])])
|
||||
(apply handler recurse form))]))
|
||||
|
||||
; Like map-form, but intended for boolean results. (Just different defaults.)
|
||||
(define (search-form form
|
||||
#:merge-with [merge-fn ormap]
|
||||
#:base-value [base-value #f]
|
||||
#:bind [bind-fn (lambda (recurse op vars . subforms)
|
||||
(merge-fn recurse subforms))]
|
||||
#:lambda [lambda-fn (lambda (recurse op g-vars i-vars bind)
|
||||
(recurse bind))]
|
||||
#:set [set-fn (lambda (recurse op var value)
|
||||
(recurse value))]
|
||||
|
||||
#:primitive [primitive-fn (lambda (recurse op . simple-values)
|
||||
(merge-fn recurse simple-values))]
|
||||
#:values [values-fn primitive-fn]
|
||||
#:call [call-fn primitive-fn]
|
||||
#:apply [apply-fn call-fn]
|
||||
#:call/cc [call/cc-fn call-fn]
|
||||
#:tail-call [tail-call-fn call-fn]
|
||||
|
||||
#:simple [simple-fn (lambda (recurse kind form) base-value)]
|
||||
#:variable [variable-fn simple-fn]
|
||||
#:literal [literal-fn simple-fn]
|
||||
|
||||
#:other [other-fn (lambda (recurse . form)
|
||||
(error "Unsimplified form:" form))])
|
||||
(map-form form
|
||||
#:bind bind-fn
|
||||
#:lambda lambda-fn
|
||||
#:set set-fn
|
||||
#:primitive primitive-fn
|
||||
#:values values-fn
|
||||
#:call call-fn
|
||||
#:apply apply-fn
|
||||
#:call/cc call/cc-fn
|
||||
#:tail-call tail-call-fn
|
||||
#:simple simple-fn
|
||||
#:variable variable-fn
|
||||
#:literal literal-fn
|
||||
#:other other-fn))
|
||||
|
||||
(define (form-sets? form variable [call-may-set? #t])
|
||||
(search-form form
|
||||
#:bind (lambda (recurse op vars . subforms)
|
||||
(and (not (memq variable vars))
|
||||
(ormap recurse subforms)))
|
||||
#:lambda (lambda _ #f)
|
||||
#:set (lambda (recurse op var complex-value)
|
||||
(eq? var variable))
|
||||
#:call (lambda _ call-may-set?)))
|
||||
|
||||
(define (form-uses? form variable [call-may-use? #t] [descend? #t])
|
||||
(search-form form
|
||||
#:bind (lambda (recurse op vars . subforms)
|
||||
(and (not (memq variable vars))
|
||||
(ormap recurse subforms)))
|
||||
#:lambda (lambda (recurse op g-vars i-vars bind)
|
||||
(and descend? (recurse bind)))
|
||||
#:call (lambda (recurse op . simple-values)
|
||||
(or call-may-use? (ormap recurse simple-values)))
|
||||
#:variable (lambda (recurse op var) (eq? var variable))))
|
||||
|
||||
(define (form-captures? form variable [input? #t] [output? #t])
|
||||
(search-form form
|
||||
#:bind (lambda (recurse op vars . subforms)
|
||||
(and (not (memq variable vars))
|
||||
(ormap recurse subforms)))
|
||||
#:lambda (lambda (recurse op g-vars i-vars bind)
|
||||
(and (memq variable (free-variables bind input? output?)) #t))))
|
||||
|
||||
(define (form-captures-input? form var)
|
||||
(form-captures? form var #t #f))
|
||||
|
||||
(define (form-captures-output? form var)
|
||||
(form-captures? form var #f #t))
|
||||
|
||||
(define (value-used? variable forms)
|
||||
(cond
|
||||
[(null? forms) #f]
|
||||
[(form-uses? (first forms) variable #f #t) #t]
|
||||
[(form-sets? (first forms) variable #f) #f]
|
||||
[else (value-used? variable (cdr forms))]))
|
||||
|
||||
(define (subst-var old-var new-var form)
|
||||
(map-form form
|
||||
#:bind (lambda (recurse op vars . subforms)
|
||||
`(%bind ,(subst old-var new-var vars) ,@(map recurse subforms)))
|
||||
#:set (lambda (recurse op var value)
|
||||
`(,op ,(if (eq? var old-var) new-var var) ,(recurse value)))
|
||||
#:variable (lambda (recurse op var)
|
||||
(if (eq? var old-var) new-var var))))
|
||||
|
||||
(define (narrow-binds simple-lambda-form)
|
||||
(define bind (fourth simple-lambda-form))
|
||||
|
||||
(define (at-top-level? var)
|
||||
(or (ormap (lambda (x) (form-sets? x var #f)) (cddr bind))
|
||||
(ormap (lambda (x) (form-uses? x var #f #f)) (cddr bind))))
|
||||
|
||||
(define (captured-twice? var)
|
||||
(let/cc return
|
||||
(foldl (lambda (subform once?)
|
||||
(if (form-captures? subform var)
|
||||
(if once? (return #t) #t)
|
||||
once?))
|
||||
(at-top-level? var)
|
||||
(cddr bind))
|
||||
#f))
|
||||
|
||||
(define extra-binds
|
||||
(filter-not captured-twice?
|
||||
(filter-not at-top-level?
|
||||
(second bind))))
|
||||
|
||||
`(%lambda ,(second simple-lambda-form) ,(third simple-lambda-form)
|
||||
(%bind ,(remove* extra-binds (second bind))
|
||||
,@(map (lambda (subform)
|
||||
(if (and (pair? subform)
|
||||
(eq? (first subform) '%set!)
|
||||
(pair? (third subform))
|
||||
(eq? (first (third subform)) '%lambda))
|
||||
(let* ([dest (second subform)]
|
||||
[value (third subform)]
|
||||
[g-vars (second value)]
|
||||
[i-vars (third value)])
|
||||
`(%set! ,dest ,(foldl (lambda (var temp-value)
|
||||
(define temp-bind (fourth temp-value))
|
||||
(if (form-captures? temp-value var)
|
||||
(narrow-binds
|
||||
`(%lambda ,g-vars ,i-vars
|
||||
(%bind (,@(second temp-bind) ,var)
|
||||
,@(cddr temp-bind))))
|
||||
temp-value))
|
||||
value
|
||||
extra-binds)))
|
||||
subform))
|
||||
(cddr bind)))))
|
||||
|
||||
(define (flatten-binds form)
|
||||
(define (make-bindings-unique bind rename-vars)
|
||||
(define (needs-rename? var) (memq var rename-vars))
|
||||
(define (make-binding-unique var bind)
|
||||
(let* ([prefix (string-append (symbol->string var) "->g")]
|
||||
[unique-var (gensym prefix)])
|
||||
(subst-var var unique-var bind)))
|
||||
(foldr make-binding-unique bind (filter needs-rename? (second bind))))
|
||||
|
||||
(map-form form
|
||||
#:bind (lambda (recurse op bound-vars . original-subforms)
|
||||
(define rename-vars
|
||||
(remove-duplicates
|
||||
(append (free-variables `(,op ,bound-vars ,@original-subforms))
|
||||
bound-vars)))
|
||||
(define (form->list subform)
|
||||
(if (bind-form? subform)
|
||||
(let ([unique-form (make-bindings-unique
|
||||
(recurse subform)
|
||||
rename-vars)])
|
||||
(set! bound-vars (append (second unique-form) bound-vars))
|
||||
(cddr unique-form))
|
||||
(list subform)))
|
||||
(let ([subforms (append-map form->list original-subforms)])
|
||||
`(%bind ,bound-vars ,@subforms)))
|
||||
#:lambda (lambda (recurse . form) form)))
|
||||
|
||||
(define (free-variables form [input? #t] [output? #t])
|
||||
(map-form form
|
||||
#:bind (lambda (recurse op vars . subforms)
|
||||
(remove-duplicates (remove* vars (append-map recurse subforms))))
|
||||
#:lambda (lambda (recurse op g-vars i-vars bind)
|
||||
(recurse bind))
|
||||
#:set (lambda (recurse op var value)
|
||||
(let ([value-free (recurse value)])
|
||||
(if output?
|
||||
(cons var value-free)
|
||||
value-free)))
|
||||
#:primitive (lambda (recurse op . simple-values)
|
||||
(remove-duplicates (append-map recurse simple-values)))
|
||||
#:simple (lambda (recurse kind form)
|
||||
(if (and input?
|
||||
(variable-value? form)
|
||||
(not (memq form '(%nil %self %argv %ctx %k))))
|
||||
(list form)
|
||||
'()))))
|
||||
|
||||
(define (free-input-variables form)
|
||||
(free-variables form #t #f))
|
||||
|
||||
(define (free-output-variables form)
|
||||
(free-variables form #f #t))
|
||||
|
||||
; vim:set sw=2 expandtab:
|
||||
|
|
@ -0,0 +1,197 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require scheme/list)
|
||||
(require (file "utilities.scm"))
|
||||
(require (file "primitives.scm"))
|
||||
|
||||
(provide write-rla-value
|
||||
current-indent
|
||||
current-indent-step)
|
||||
|
||||
(define current-indent (make-parameter 0))
|
||||
(define current-indent-step (make-parameter 2))
|
||||
|
||||
(define hex-digits "0123456789abcdef")
|
||||
|
||||
(define (new-line port)
|
||||
(write-char #\Newline port)
|
||||
(for ([i (in-range 0 (current-indent))])
|
||||
(write-char #\Space port)))
|
||||
|
||||
(define (write-hex-char ord port)
|
||||
(write-string "\\x" port)
|
||||
(write-char (string-ref hex-digits (quotient ord 16)) port)
|
||||
(write-char (string-ref hex-digits (remainder ord 16)) port))
|
||||
|
||||
(define (write-hex-byte ord port)
|
||||
(write-string "0x" port)
|
||||
(write-char (string-ref hex-digits (quotient ord 16)) port)
|
||||
(write-char (string-ref hex-digits (remainder ord 16)) port))
|
||||
|
||||
(define (write-rla-string value port)
|
||||
(write-char #\" port)
|
||||
(for ([ch (in-string value)])
|
||||
(cond
|
||||
[(and (eq? ch #\"))
|
||||
(write-string "\\\"" port)]
|
||||
[(and (< (char->integer ch) 128) (char-graphic? ch))
|
||||
(write-char ch port)]
|
||||
[else
|
||||
(write-hex-char (char->integer ch) port)]))
|
||||
(write-char #\" port))
|
||||
|
||||
(define (write-instance-string inst-vars port)
|
||||
(write-char #\" port)
|
||||
(for ([var (in-list inst-vars)])
|
||||
(write-hex-char (variable->code var) port))
|
||||
(write-char #\" port))
|
||||
|
||||
(define (write-rla-bytecode+tail-call forms port)
|
||||
(define (write-tail-call tc-form)
|
||||
(new-line port) (write-hex-byte (variable->code (second tc-form)) port)
|
||||
(new-line port) (write-hex-byte (variable->code (third tc-form)) port)
|
||||
(new-line port) (write-hex-byte (variable->code (fourth tc-form)) port)
|
||||
(new-line port) (write-hex-byte (variable->code (fifth tc-form)) port))
|
||||
(let-values ([(line col pos) (port-next-location port)])
|
||||
(parameterize ([current-indent col])
|
||||
(write-char #\" port)
|
||||
(if (eq? (first (first forms)) '%tail-call)
|
||||
(begin
|
||||
(write-char #\" port)
|
||||
(write-tail-call (first forms)))
|
||||
(let iter ([forms forms])
|
||||
(map (lambda (x) (write-hex-char x port))
|
||||
(statement->code (car forms)))
|
||||
(if (eq? (first (second forms)) '%tail-call)
|
||||
(begin
|
||||
(write-string "\"; " port)
|
||||
(write (car forms) port)
|
||||
(write-tail-call (second forms)))
|
||||
(begin
|
||||
(write-string "\\; " port)
|
||||
(write (car forms) port)
|
||||
(new-line port)
|
||||
(write-char #\Space port)
|
||||
(iter (cdr forms)))))))))
|
||||
|
||||
(define (write-rla-function value port)
|
||||
(define template? (eq? (first value) '%template))
|
||||
(let-values ([(line col pos) (port-next-location port)])
|
||||
(parameterize ([current-indent col])
|
||||
(write-string "#S(" port)
|
||||
(if (eq? (first value) '%template)
|
||||
(write-string "#=\"template\"" port)
|
||||
(write-string "#=\"lambda\"" port))
|
||||
(parameterize ([current-indent (+ (current-indent-step) (current-indent))])
|
||||
(new-line port)
|
||||
(write-string "#(" port)
|
||||
(unless (null? (second value))
|
||||
(parameterize ([current-indent (+ (current-indent-step) (current-indent))])
|
||||
(for ([global (in-list (second value))])
|
||||
(new-line port)
|
||||
(write-rla-value global port)))
|
||||
(new-line port))
|
||||
(write-string ")" port)
|
||||
(new-line port)
|
||||
(if template?
|
||||
(write-instance-string (third value) port)
|
||||
(begin
|
||||
(write-string "#(" port)
|
||||
(unless (null? (third value))
|
||||
(parameterize ([current-indent (+ (current-indent-step) (current-indent))])
|
||||
(for ([instance (in-list (third value))])
|
||||
(new-line port)
|
||||
(write-rla-value instance port)))
|
||||
(new-line port))
|
||||
(write-string ")" port)))
|
||||
(new-line port)
|
||||
(write-rla-value (length (second (fourth value))) port)
|
||||
(new-line port)
|
||||
(write-rla-bytecode+tail-call (cddr (fourth value)) port))
|
||||
(new-line port))
|
||||
(write-string ")" port)))
|
||||
|
||||
(define (write-rla-value value [port (current-output-port)])
|
||||
(port-count-lines! port)
|
||||
(void
|
||||
(cond
|
||||
[(eq? value '%undef)
|
||||
(write-string "#=\"undefined\"" port)]
|
||||
[(symbol? value)
|
||||
(write-string "#=\"" port)
|
||||
(write-string (symbol->string value) port)
|
||||
(write-string "\"" port)]
|
||||
[(or (boolean? value) (number? value))
|
||||
(write value port)]
|
||||
[(string? value)
|
||||
(write-rla-string value port)]
|
||||
[(and (pair? value) (memq (first value) '(%lambda %template)))
|
||||
(write-rla-function value port)]
|
||||
[(vector? value)
|
||||
(write-string "#(" port)
|
||||
(unless (zero? (vector-length value))
|
||||
(write-rla-value (vector-ref value 0) port))
|
||||
(for ([i (in-range 1 (vector-length value))])
|
||||
(write-rla-value (vector-ref value i) port)
|
||||
(write-char #\Space port))
|
||||
(write-string ")" port)]
|
||||
[(pair? value)
|
||||
(write-string "(" port)
|
||||
(let iter ([lst value])
|
||||
(write-rla-value (car lst) port)
|
||||
(cond
|
||||
[(null? (cdr lst))
|
||||
(write-string ")" port)]
|
||||
[(pair? (cdr lst))
|
||||
(write-char #\Space port)
|
||||
(iter (cdr lst))]
|
||||
[else
|
||||
(write-string " . " port)
|
||||
(write-rla-value (cdr lst))
|
||||
(write-string ")" port)]))]
|
||||
[else (error "Don't know how to write Rosella syntax for:" value)])))
|
||||
|
||||
(define (variable->code var)
|
||||
(or (and (eq? var '%nil) #x00)
|
||||
(let ([index (find var global-variables)])
|
||||
(and index (+ #x01 index)))
|
||||
(let ([index (find var instance-variables)])
|
||||
(and index (+ #x40 index)))
|
||||
(let ([index (find var frame-variables)])
|
||||
(and index (+ #x80 index)))
|
||||
(let ([index (find var '(%self %argv %ctx %k))])
|
||||
(and index (+ #xfc index)))
|
||||
(error "No bytecode for variable:" var)))
|
||||
|
||||
(define (statement->code form)
|
||||
(if (eq? (first form) '%set!)
|
||||
(let ([out (variable->code (second form))]
|
||||
[value (third form)])
|
||||
(cond
|
||||
[(machine-variable? value)
|
||||
(list #x00 out #x01 (variable->code value))]
|
||||
[(eq? (length (cdr value)) 1)
|
||||
(list #x00 out (second (assoc (first value) unary-value-primitives))
|
||||
(variable->code (second value)))]
|
||||
[(eq? (length (cdr value)) 2)
|
||||
(list* (second (assoc (first value) binary-value-primitives))
|
||||
out (map variable->code (cdr value)))]
|
||||
[else
|
||||
(unless (and (eq? (first value) '%if)
|
||||
(eq? (length (cdr value)) 3))
|
||||
(error "Unsupported ternary form:" form))
|
||||
(list* out (map variable->code (cdr value)))]))
|
||||
(case (length (cdr form))
|
||||
[(1) (list (second (assoc (first form) unary-statement-primitives))
|
||||
(variable->code (second form))
|
||||
#x00
|
||||
#x00)]
|
||||
[(2) (list (second (assoc (first form) binary-statement-primitives))
|
||||
(variable->code (second form))
|
||||
(variable->code (third form))
|
||||
#x00)]
|
||||
[(3) (list (second (assoc (first form) ternary-statement-primitives))
|
||||
(variable->code (second form))
|
||||
(variable->code (third form))
|
||||
(variable->code (fourth form)))]
|
||||
[else (error "Unsupported form:" form)])))
|
||||
Loading…
Reference in New Issue