diff --git a/compiler.ss b/compiler.ss index 2129f08..847b6af 100755 --- a/compiler.ss +++ b/compiler.ss @@ -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: