diff --git a/compiler.scm b/compiler.scm new file mode 100755 index 0000000..c6cfe56 --- /dev/null +++ b/compiler.scm @@ -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: diff --git a/compiler.ss b/compiler.ss deleted file mode 100755 index 24c0096..0000000 --- a/compiler.ss +++ /dev/null @@ -1,1319 +0,0 @@ -#! /usr/bin/mzscheme -#lang scheme - -(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 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 primitives - (append value-primitives statement-primitives)) - -(define (variable-value? form) - (and (symbol? form) - (not (eq? form '%undef)))) - -(define (special-variable? var) - (and (memq var '(%nil %self %argv %ctx %k)) #t)) - -(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 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 (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))) - primitives)]) - (if primitive - (simplify-primitive (first (first primitive)) - (cdr form)) - (simplify-funcall form)))])))) - -(define (form-sets? form variable [call-may-set? #t]) - (search-form (simplify-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 (simplify-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 (simplify-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 (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)))) - -(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))))))) - -(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 (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-vars 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-vars 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)))) - -; <= (%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))))) - -; (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 (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 (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)) - -; 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)) - -(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))])) - -; 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)) - -(define frame-vars - (for/list ([i (in-range 0 120)]) - (string->uninterned-symbol (string-append "%f" (number->string i))))) - -(define instance-vars - (for/list ([i (in-range 0 64)]) - (string->uninterned-symbol (string-append "%i" (number->string i))))) - -(define global-vars - (for/list ([i (in-range 1 64)]) - (string->uninterned-symbol (string-append "%g" (number->string i))))) - -(define (frame-var? var) (and (memq var frame-vars) #t)) -(define (instance-var? var) (and (memq var instance-vars) #t)) -(define (frame/instance-var? var) (or (frame-var? var) (instance-var? var))) - -(define (global-var? var) (and (memq var global-vars) #t)) - -(define (machine-var? var) - (or (special-variable? var) - (frame/instance-var? var) - (global-var? var))) - -(define (map-variables lambda/template-form) - (let ([bind (fourth lambda/template-form)] - [g-vars '()] - [unused-g-vars global-vars] - [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-vars)] - [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-var? (free-variables bind)))] - [inst-var (in-list instance-vars)]) - (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-vars)]) - (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-var? 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))) - -(define (variable->code var) - (or (and (eq? var '%nil) #x00) - (let ([index (find var global-vars)]) - (and index (+ #x01 index))) - (let ([index (find var instance-vars)]) - (and index (+ #x40 index))) - (let ([index (find var frame-vars)]) - (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-var? 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)]))) - -(define current-indent (make-parameter 0)) -(define indent-step 2) - -(define (write-rla-value value [port (current-output-port)]) - (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 (+ indent-step (current-indent))]) - (new-line port) - (write-string "#(" port) - (unless (null? (second value)) - (parameterize ([current-indent (+ 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 (+ 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))) - - (port-count-lines! port) - (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 (simplify-function lambda-form) - ((compose - ;promote-free-vars - promote-shared-vars - simplify-lambda - ) - lambda-form)) - -(define (optimize-function simple-lambda-form) - ((compose - reduce-variables - reduce-set! - propogate-set! - ) - simple-lambda-form)) - -(define (compile-function lambda-form) - ((compose - (lambda (x) (write-rla-value x) (write-char #\Newline)) -; pretty-print - map-variables - optimize-function - simplify-function - ) - lambda-form)) - -(compile-function `(lambda argv ,(read))) - -; vim:set sw=2 expandtab: diff --git a/libcompiler/compiler.scm b/libcompiler/compiler.scm new file mode 100644 index 0000000..7cf19f1 --- /dev/null +++ b/libcompiler/compiler.scm @@ -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: diff --git a/libcompiler/mapper.scm b/libcompiler/mapper.scm new file mode 100644 index 0000000..7059ff6 --- /dev/null +++ b/libcompiler/mapper.scm @@ -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))) diff --git a/libcompiler/optimizer.scm b/libcompiler/optimizer.scm new file mode 100644 index 0000000..d0e7e9a --- /dev/null +++ b/libcompiler/optimizer.scm @@ -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)) diff --git a/libcompiler/primitives.scm b/libcompiler/primitives.scm new file mode 100644 index 0000000..f17af46 --- /dev/null +++ b/libcompiler/primitives.scm @@ -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: diff --git a/libcompiler/simplifier.scm b/libcompiler/simplifier.scm new file mode 100644 index 0000000..42c8f9e --- /dev/null +++ b/libcompiler/simplifier.scm @@ -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: diff --git a/libcompiler/utilities.scm b/libcompiler/utilities.scm new file mode 100644 index 0000000..6a5de94 --- /dev/null +++ b/libcompiler/utilities.scm @@ -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: diff --git a/libcompiler/writer.scm b/libcompiler/writer.scm new file mode 100644 index 0000000..64dfbc8 --- /dev/null +++ b/libcompiler/writer.scm @@ -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)])))