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

273
compiler.ss
View File

@ -22,11 +22,96 @@
(when (eq? y x) (return i))) (when (eq? y x) (return i)))
#f)) #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) (define (variable-value? form)
(and (symbol? form) (and (symbol? form)
(not (eq? form '%undef)))) (not (eq? form '%undef))))
(define (special-value? var) (define (special-variable? var)
(and (memq var '(%nil %self %argv %ctx %k)) #t)) (and (memq var '(%nil %self %argv %ctx %k)) #t))
(define (literal-value? form) (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! ...). ; 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. ; If there are any side-effect they occur before the variable is updated.
(define (value-form? form) (define (value-form? form)
(define value-ops (define complex-values '(%bind %apply %call/cc %values))
'(%bind %if %apply %call/cc %make-lambda (or (simple-value? form)
%make-box %unbox %cons %car %cdr %values)) (memq (first form) complex-values)
(or (simple-value? form) (memq (first form) value-ops))) (memq (first form) value-primitives)))
; 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)))
; A statement-form is any simple form which has, or may have, side-effects. ; A statement-form is any simple form which has, or may have, side-effects.
(define (statement-form? form) (define (statement-form? form)
(define statement-ops (define complex-statements '(%set! %apply %call/cc %tail-call))
'(%set! %set-box! %set-car! %set-cdr! %apply %call/cc %tail-call)) (and (not (simple-value? form))
(and (pair? form) (memq (first form) statement-ops))) (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 (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))) (and (pair? form) (memq (first form) primitives)))
(define (bind-form? form) (define (bind-form? form)
@ -81,6 +163,7 @@
#:primitive [primitive-fn (lambda (recurse op . simple-values) #:primitive [primitive-fn (lambda (recurse op . simple-values)
`(,op ,@(map recurse simple-values)))] `(,op ,@(map recurse simple-values)))]
#:values [values-fn primitive-fn]
#:call [call-fn primitive-fn] #:call [call-fn primitive-fn]
#:apply [apply-fn call-fn] #:apply [apply-fn call-fn]
#:call/cc [call/cc-fn call-fn] #:call/cc [call/cc-fn call-fn]
@ -98,6 +181,7 @@
#:lambda lambda-fn #:lambda lambda-fn
#:set set-fn #:set set-fn
#:primitive primitive-fn #:primitive primitive-fn
#:values values-fn
#:call call-fn #:call call-fn
#:apply apply-fn #:apply apply-fn
#:call/cc call/cc-fn #:call/cc call/cc-fn
@ -115,6 +199,7 @@
[(%bind) bind-fn] [(%bind) bind-fn]
[(%lambda) lambda-fn] [(%lambda) lambda-fn]
[(%set!) set-fn] [(%set!) set-fn]
[(%values) values-fn]
[(%apply) apply-fn] [(%apply) apply-fn]
[(%call/cc) call/cc-fn] [(%call/cc) call/cc-fn]
[(%tail-call) tail-call-fn] [(%tail-call) tail-call-fn]
@ -136,6 +221,7 @@
#:primitive [primitive-fn (lambda (recurse op . simple-values) #:primitive [primitive-fn (lambda (recurse op . simple-values)
(merge-fn recurse simple-values))] (merge-fn recurse simple-values))]
#:values [values-fn primitive-fn]
#:call [call-fn primitive-fn] #:call [call-fn primitive-fn]
#:apply [apply-fn call-fn] #:apply [apply-fn call-fn]
#:call/cc [call/cc-fn call-fn] #:call/cc [call/cc-fn call-fn]
@ -152,6 +238,7 @@
#:lambda lambda-fn #:lambda lambda-fn
#:set set-fn #:set set-fn
#:primitive primitive-fn #:primitive primitive-fn
#:values values-fn
#:call call-fn #:call call-fn
#:apply apply-fn #:apply apply-fn
#:call/cc call/cc-fn #:call/cc call/cc-fn
@ -186,21 +273,23 @@
[(set!) (simplify-set! form)] [(set!) (simplify-set! form)]
[(let/cc) (simplify-form [(let/cc) (simplify-form
`(call/cc (lambda (,(second form)) ,@(cddr form))))] `(call/cc (lambda (,(second form)) ,@(cddr form))))]
[(call/cc values make-box set-box! unbox [(fix>) (simplify-form
cons set-car! car set-cdr! cdr) (let ([a (gensym)] [b (gensym)])
(simplify-primitive (case (first form) `(let ([,a ,(second form)]
[(call/cc) '%call/cc] [,b ,(third form)])
[(values) '%values] (fix< ,b ,a))))]
[(make-box) '%make-box] [(fix<=) (simplify-form
[(set-box!) '%set-box!] (let ([a (gensym)] [b (gensym)])
[(unbox) '%unbox] `(let ([,a ,(second form)]
[(cons) '%cons] [,b ,(third form)])
[(set-car!) '%set-car!] (fix>= ,b ,a))))]
[(car) '%car] [(values) (simplify-primitive '%values (cdr form))]
[(set-cdr!) '%set-cdr!] [(call/cc) (simplify-primitive '%call/cc (cdr form))]
[(cdr) '%cdr]) [else
(cdr form))] (let ([primitive-name (string-append "%" (symbol->string (first form)))])
[else (simplify-funcall 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]) (define (form-sets? form variable [call-may-set? #t])
(search-form (simplify-form form) (search-form (simplify-form form)
@ -251,7 +340,7 @@
(error "Attempted to set variable to void in:" form) (error "Attempted to set variable to void in:" form)
`((set! ,(second form) ,(second subform))))] `((set! ,(second form) ,(second subform))))]
[(value-form? subform) `((set! ,(second form) ,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)))) (cddr value-form))))
`(%set! ,(second form) ,value-form)))) `(%set! ,(second form) ,value-form))))
@ -392,13 +481,13 @@
(let-values ([(opt rst) (split-optional (cdr arglist))]) (let-values ([(opt rst) (split-optional (cdr arglist))])
(values (cons (car arglist) opt) rst)) (values (cons (car arglist) opt) rst))
(values '() arglist))) (values '() arglist)))
(if (pair? arglist) (cond
(if (pair? (car arglist)) [(null? arglist) (values '() '() #f)]
(let-values ([(opt rst) (split-optional arglist)]) [(not (pair? arglist)) (values '() '() arglist)]
(values '() opt rst)) [(pair? (car arglist)) (let-values ([(opt rst) (split-optional arglist)])
(let-values ([(req opt rst) (split-arglist (cdr arglist))]) (values '() opt rst))]
(values (cons (car arglist) req) opt rst))) [else (let-values ([(req opt rst) (split-arglist (cdr arglist))])
(values '() '() #f))) (values (cons (car arglist) req) opt rst))]))
(define (add-return ctx k form) (define (add-return ctx k form)
(define argv (gensym)) (define argv (gensym))
@ -566,7 +655,7 @@
#f #f
(cddr bind)) (cddr bind))
#f)) #f))
(and (not (special-value? var)) (and (not (special-variable? var))
(or captured-input? (or captured-input?
captured-output?) captured-output?)
(set-after-first-use?))) (set-after-first-use?)))
@ -796,6 +885,9 @@
(if (and (pair? subform) (if (and (pair? subform)
(eq? (first subform) '%set!) (eq? (first subform) '%set!)
(or (memq (second subform) vars) (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)) (error "Setting unbound var:" subform))
(not (value-used? (second subform) after))) (not (value-used? (second subform) after)))
after after
@ -916,7 +1008,7 @@
(define (global-var? var) (and (memq var global-vars) #t)) (define (global-var? var) (and (memq var global-vars) #t))
(define (machine-var? var) (define (machine-var? var)
(or (special-value? var) (or (special-variable? var)
(frame/instance-var? var) (frame/instance-var? var)
(global-var? var))) (global-var? var)))
@ -972,39 +1064,58 @@
(error "No bytecode for variable:" var))) (error "No bytecode for variable:" var)))
(define (statement->code form) (define (statement->code form)
(case (first form) (if (eq? (first form) '%set!)
[(%set!) (let ([out (variable->code (second form))] (let ([out (variable->code (second form))]
[value (third form)]) [value (third form)])
(if (machine-var? value) (cond
(list #x00 out #x01 (variable->code value)) [(machine-var? value)
(case (first value) (list #x00 out #x01 (variable->code value))]
[(%unbox) (list #x00 out #x02 (variable->code (second value)))] [(eq? (length (cdr value)) 1)
[(%car) (list #x00 out #x03 (variable->code (second value)))] (list #x00 out (cdr (assoc (first value) unary-value-primitives))
[(%cdr) (list #x00 out #x04 (variable->code (second value)))] (variable->code (second value)))]
[(%make-box) (list #x00 out #x18 (variable->code (second value)))] [(eq? (length (cdr value)) 2)
[(%make-lambda) (list #x00 out #x1b (variable->code (second value)))] (list* (cdr (assoc (first value) binary-value-primitives))
[(%cons) (list* #x02 out (map variable->code (cdr value)))] out (map variable->code (cdr value)))]
[(%if) (list* out (map variable->code (cdr value)))] [else
[else (error "Unknown statement type:" form)])))] (unless (and (eq? (first value) '%if)
[(%set-box!) (list #x50 (variable->code (second form)) (variable->code (third form)) #x00)] (eq? (length (cdr value)) 3))
[(%set-car!) (list #x51 (variable->code (second form)) (variable->code (third form)) #x00)] (error "Unsupported ternary form:" form))
[(%set-cdr!) (list #x52 (variable->code (second form)) (variable->code (third form)) #x00)] (list* out (map variable->code (cdr value)))]))
[else (error "Unknown statement type:" form)])) (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 current-indent (make-parameter 0))
(define indent-step 3) (define indent-step 2)
(define (write-rla-value value [port (current-output-port)]) (define (write-rla-value value [port (current-output-port)])
(define hex-digits "0123456789abcdef")
(define (new-line port) (define (new-line port)
(write-char #\Newline port) (write-char #\Newline port)
(for ([i (in-range 0 (current-indent))]) (for ([i (in-range 0 (current-indent))])
(write-char #\Space port))) (write-char #\Space port)))
(define (write-hex-char ord port) (define (write-hex-char ord port)
(define digits "0123456789abcdef")
(write-string "\\x" port) (write-string "\\x" port)
(write-char (string-ref digits (quotient ord 16)) port) (write-char (string-ref hex-digits (quotient ord 16)) port)
(write-char (string-ref digits (remainder 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) (define (write-rla-string value port)
(write-char #\" port) (write-char #\" port)
@ -1025,20 +1136,18 @@
(write-char #\" port)) (write-char #\" port))
(define (write-rla-bytecode+tail-call forms 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)]) (let-values ([(line col pos) (port-next-location port)])
(parameterize ([current-indent col]) (parameterize ([current-indent col])
(write-char #\" port) (write-char #\" port)
(if (eq? (first (first forms)) '%tail-call) (if (eq? (first (first forms)) '%tail-call)
(begin (begin
(write-char #\" port) (write-char #\" port)
(new-line port) (write-tail-call (first forms)))
(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))
(let iter ([forms forms]) (let iter ([forms forms])
(map (lambda (x) (write-hex-char x port)) (map (lambda (x) (write-hex-char x port))
(statement->code (car forms))) (statement->code (car forms)))
@ -1046,14 +1155,7 @@
(begin (begin
(write-string "\"; " port) (write-string "\"; " port)
(write (car forms) port) (write (car forms) port)
(new-line port) (write-tail-call (second forms)))
(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))
(begin (begin
(write-string "\\; " port) (write-string "\\; " port)
(write (car forms) port) (write (car forms) port)
@ -1138,7 +1240,7 @@
(define (simplify-function lambda-form) (define (simplify-function lambda-form)
((compose ((compose
promote-free-vars ;promote-free-vars
promote-shared-vars promote-shared-vars
simplify-lambda simplify-lambda
) )
@ -1153,7 +1255,8 @@
simple-lambda-form)) simple-lambda-form))
(define (compile-function lambda-form) (define (compile-function lambda-form)
((compose (lambda (x) (write-rla-value x) (write-char #\Newline)) ((compose
(lambda (x) (write-rla-value x) (write-char #\Newline))
; pretty-print ; pretty-print
map-variables map-variables
optimize-function optimize-function
@ -1161,6 +1264,6 @@
) )
lambda-form)) lambda-form))
(compile-function `(lambda () ,(read))) (compile-function `(lambda argv ,(read)))
; vim:set sw=2 expandtab: ; vim:set sw=2 expandtab: