nybble
/
rosella
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Add many additional primitives, and centralize definitions. 

Also:
- assume top-level free variables are constants, not boxes;
- bind variable 'argv' to top-level argument list, rather than assuming no arguments;
- make %values a first-class form, just like %apply and %call/cc (was: pseudo-primitive);
- fix case where 'rest' argument is sole item in argument list: (lambda argv ...); and
- perform misc. cleanup in output code.
This commit is contained in:
Jesse D. McDonald 2010-04-20 22:32:13 -05:00
parent 03fc616b7a
commit cc8dc5d9b6
1 changed files with 190 additions and 87 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

277
compiler.ss
View File

@ -22,11 +22,96 @@
(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-value? var)
(define (special-variable? var)
(and (memq var '(%nil %self %argv %ctx %k)) #t))
(define (literal-value? form)
@ -42,30 +127,27 @@
; 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 value-ops
'(%bind %if %apply %call/cc %make-lambda
%make-box %unbox %cons %car %cdr %values))
(or (simple-value? form) (memq (first form) value-ops)))
; A pure-form is any simple form known to be free of side effects.
; Creation of a new object is not counted as a side-effect.
; Pure-forms are a subset of value-forms.
(define (pure-form? form)
(define pure-ops
'(%if %make-lambda %make-box %unbox %cons %car %cdr %values))
(or (simple-value? form) (memq (first form) pure-ops)))
(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 statement-ops
'(%set! %set-box! %set-car! %set-cdr! %apply %call/cc %tail-call))
(and (pair? form) (memq (first form) statement-ops)))
(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)
(define primitives
'(%make-box %set-box! %unbox
%cons %set-car! %car %set-cdr! %cdr
%if %make-lambda %values))
(and (pair? form) (memq (first form) primitives)))
(define (bind-form? form)
@ -81,6 +163,7 @@
#: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]
@ -98,6 +181,7 @@
#:lambda lambda-fn
#:set set-fn
#:primitive primitive-fn
#:values values-fn
#:call call-fn
#:apply apply-fn
#:call/cc call/cc-fn
@ -115,6 +199,7 @@
[(%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]
@ -136,6 +221,7 @@
#: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]
@ -152,6 +238,7 @@
#:lambda lambda-fn
#:set set-fn
#:primitive primitive-fn
#:values values-fn
#:call call-fn
#:apply apply-fn
#:call/cc call/cc-fn
@ -186,21 +273,23 @@
[(set!) (simplify-set! form)]
[(let/cc) (simplify-form
`(call/cc (lambda (,(second form)) ,@(cddr form))))]
[(call/cc values make-box set-box! unbox
cons set-car! car set-cdr! cdr)
(simplify-primitive (case (first form)
[(call/cc) '%call/cc]
[(values) '%values]
[(make-box) '%make-box]
[(set-box!) '%set-box!]
[(unbox) '%unbox]
[(cons) '%cons]
[(set-car!) '%set-car!]
[(car) '%car]
[(set-cdr!) '%set-cdr!]
[(cdr) '%cdr])
(cdr form))]
[else (simplify-funcall 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)
@ -251,7 +340,7 @@
(error "Attempted to set variable to void in:" form)
`((set! ,(second form) ,(second subform))))]
[(value-form? subform) `((set! ,(second form) ,subform))]
[else (error "Attempted to set variable to non-value in:" form)]))
[else (error "Attempted to set variable to void in:" form)]))
'()
(cddr value-form))))
`(%set! ,(second form) ,value-form))))
@ -392,13 +481,13 @@
(let-values ([(opt rst) (split-optional (cdr arglist))])
(values (cons (car arglist) opt) rst))
(values '() arglist)))
(if (pair? arglist)
(if (pair? (car arglist))
(let-values ([(opt rst) (split-optional arglist)])
(values '() opt rst))
(let-values ([(req opt rst) (split-arglist (cdr arglist))])
(values (cons (car arglist) req) opt rst)))
(values '() '() #f)))
(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 form)
(define argv (gensym))
@ -566,7 +655,7 @@
#f
(cddr bind))
#f))
(and (not (special-value? var))
(and (not (special-variable? var))
(or captured-input?
captured-output?)
(set-after-first-use?)))
@ -796,6 +885,9 @@
(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
@ -916,7 +1008,7 @@
(define (global-var? var) (and (memq var global-vars) #t))
(define (machine-var? var)
(or (special-value? var)
(or (special-variable? var)
(frame/instance-var? var)
(global-var? var)))
@ -972,39 +1064,58 @@
(error "No bytecode for variable:" var)))
(define (statement->code form)
(case (first form)
[(%set!) (let ([out (variable->code (second form))]
[value (third form)])
(if (machine-var? value)
(list #x00 out #x01 (variable->code value))
(case (first value)
[(%unbox) (list #x00 out #x02 (variable->code (second value)))]
[(%car) (list #x00 out #x03 (variable->code (second value)))]
[(%cdr) (list #x00 out #x04 (variable->code (second value)))]
[(%make-box) (list #x00 out #x18 (variable->code (second value)))]
[(%make-lambda) (list #x00 out #x1b (variable->code (second value)))]
[(%cons) (list* #x02 out (map variable->code (cdr value)))]
[(%if) (list* out (map variable->code (cdr value)))]
[else (error "Unknown statement type:" form)])))]
[(%set-box!) (list #x50 (variable->code (second form)) (variable->code (third form)) #x00)]
[(%set-car!) (list #x51 (variable->code (second form)) (variable->code (third form)) #x00)]
[(%set-cdr!) (list #x52 (variable->code (second form)) (variable->code (third form)) #x00)]
[else (error "Unknown statement type:" 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 3)
(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)
(define digits "0123456789abcdef")
(write-string "\\x" port)
(write-char (string-ref digits (quotient ord 16)) port)
(write-char (string-ref digits (remainder ord 16)) 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)
@ -1025,20 +1136,18 @@
(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)
(new-line port)
(write-rla-value (variable->code (second (second forms))) port)
(new-line port)
(write-rla-value (variable->code (third (second forms))) port)
(new-line port)
(write-rla-value (variable->code (fourth (second forms))) port)
(new-line port)
(write-rla-value (variable->code (fifth (second forms))) port))
(write-tail-call (first forms)))
(let iter ([forms forms])
(map (lambda (x) (write-hex-char x port))
(statement->code (car forms)))
@ -1046,14 +1155,7 @@
(begin
(write-string "\"; " port)
(write (car forms) port)
(new-line port)
(write-rla-value (variable->code (second (second forms))) port)
(new-line port)
(write-rla-value (variable->code (third (second forms))) port)
(new-line port)
(write-rla-value (variable->code (fourth (second forms))) port)
(new-line port)
(write-rla-value (variable->code (fifth (second forms))) port))
(write-tail-call (second forms)))
(begin
(write-string "\\; " port)
(write (car forms) port)
@ -1138,7 +1240,7 @@
(define (simplify-function lambda-form)
((compose
promote-free-vars
;promote-free-vars
promote-shared-vars
simplify-lambda
)
@ -1153,14 +1255,15 @@
simple-lambda-form))
(define (compile-function lambda-form)
((compose (lambda (x) (write-rla-value x) (write-char #\Newline))
;pretty-print
((compose
(lambda (x) (write-rla-value x) (write-char #\Newline))
; pretty-print
map-variables
optimize-function
simplify-function
)
lambda-form))
(compile-function `(lambda () ,(read)))
(compile-function `(lambda argv ,(read)))
; vim:set sw=2 expandtab: