1276 lines
51 KiB
Scheme
Executable File
1276 lines
51 KiB
Scheme
Executable File
#! /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)
|
|
(%car . #x03)
|
|
(%cdr . #x04)
|
|
(%boolean? . #x08)
|
|
(%fixnum? . #x09)
|
|
(%box? . #x0a)
|
|
(%pair? . #x0b)
|
|
(%vector? . #x0c)
|
|
(%byte-string? . #x0d)
|
|
(%struct? . #x0e)
|
|
(%float? . #x0f)
|
|
(%builtin? . #x10)
|
|
(%make-box . #x18)
|
|
(%make-struct . #x19)
|
|
(%make-float . #x1a)
|
|
(%make-lambda . #x1b)
|
|
(%not . #x20)
|
|
(%bit-not . #x21)
|
|
(%fix- . #x22)
|
|
(%float- . #x23)
|
|
(%vector-size . #x28)
|
|
(%byte-string-size . #x29)
|
|
(%struct-nslots . #x2a)
|
|
(%struct-type . #x2b)
|
|
; add floating-point ops...
|
|
))
|
|
|
|
(define binary-value-primitives
|
|
'((%eq? . #x01)
|
|
(%cons . #x02)
|
|
(%make-vector . #x03)
|
|
(%make-byte-string . #x04)
|
|
(%vector-ref . #x05)
|
|
(%byte-string-ref . #x06)
|
|
(%struct-ref . #x07)
|
|
(%fix+ . #x08)
|
|
(%fix- . #x09)
|
|
(%fix* . #x0a)
|
|
(%fix/ . #x0b)
|
|
(%fix% . #x0c)
|
|
(%fix< . #x0d)
|
|
(%fix>= . #x0e)
|
|
(%bit-and . #x10)
|
|
(%bit-or . #x11)
|
|
(%bit-xor . #x12)
|
|
(%fix<< . #x14)
|
|
(%fix>> . #x15)
|
|
(%fix>>> . #x16)
|
|
(%float+ . #x18)
|
|
(%float- . #x19)
|
|
(%float* . #x1a)
|
|
(%float/ . #x1b)
|
|
(%float= . #x1c)
|
|
(%float< . #x1d)
|
|
(%float>= . #x1e)
|
|
; add floating-point ops...
|
|
))
|
|
|
|
(define unary-statement-primitives
|
|
'((%goto-end-if . #x40)
|
|
(%goto-end-unless . #x41)))
|
|
|
|
(define binary-statement-primitives
|
|
'((%set-box! . #x50)
|
|
(%set-car! . #x51)
|
|
(%set-cdr! . #x52)))
|
|
|
|
(define ternary-statement-primitives
|
|
'((%vector-set! . #x60)
|
|
(%byte-string-set! . #x61)
|
|
(%struct-set! . #x62)))
|
|
|
|
(define value-primitives
|
|
(append
|
|
(map car unary-value-primitives)
|
|
(map car binary-value-primitives)
|
|
(list '%if)))
|
|
|
|
(define statement-primitives
|
|
(append
|
|
(map car unary-statement-primitives)
|
|
(map car binary-statement-primitives)
|
|
(map car ternary-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) 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) statement-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 primitives
|
|
(append value-primitives statement-primitives))
|
|
|
|
(define (primitive-form? form)
|
|
(and (pair? form) (memq (first form) primitives)))
|
|
|
|
(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-name (string-append "%" (symbol->string (first form)))])
|
|
(if (member primitive-name (map symbol->string primitives))
|
|
(simplify-primitive (string->symbol primitive-name) (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 (cdr (assoc (first value) unary-value-primitives))
|
|
(variable->code (second value)))]
|
|
[(eq? (length (cdr value)) 2)
|
|
(list* (cdr (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 (cdr (assoc (first form) unary-statement-primitives))
|
|
(variable->code (second form))
|
|
#x00
|
|
#x00)]
|
|
[(2) (list (cdr (assoc (first form) binary-statement-primitives))
|
|
(variable->code (second form))
|
|
(variable->code (third form))
|
|
#x00)]
|
|
[(3) (list (cdr (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:
|