diff options
Diffstat (limited to 'csc')
| -rw-r--r-- | csc/codegen.csc | 9 | ||||
| -rw-r--r-- | csc/compiler.csc | 27 | ||||
| -rw-r--r-- | csc/config.csc | 2 | ||||
| -rw-r--r-- | csc/cps.csc | 13 | ||||
| -rw-r--r-- | csc/flag.csc | 12 | ||||
| -rw-r--r-- | csc/ir2.csc | 14 | ||||
| -rw-r--r-- | csc/main.csc | 10 |
7 files changed, 72 insertions, 15 deletions
diff --git a/csc/codegen.csc b/csc/codegen.csc index 1fd7099..7712427 100644 --- a/csc/codegen.csc +++ b/csc/codegen.csc @@ -207,6 +207,9 @@ (if (label? proc) (list 'jmp (list 'label proc-temp)) (list 'jmp (list 'local proc-temp)))))) + ((% %tail) + (list + (list 'jmp (list 'label 0)))) (_ (error "Unexpected form in ir2->bytecode expr")))) @@ -225,7 +228,7 @@ ; Converts an IR2 program into bytecode. (define (ir2->ir3 expr) (define label-map (make-map compare-labels)) - (define next-label-id 0) + (define next-label-id 1) ; start at 1 because label 0 is used for tail. (define (translate-label x) (or (lookup label-map x #f) (let ((id next-label-id)) @@ -248,9 +251,9 @@ (set! locals-map (insert locals-map x local-count)) local-count))))) (append + (ir2->bytecode (fix-body expr) (make-locals-map '())) (loop for func in (fix-functions expr) collect (list 'label (translate-label (closure-name func))) append (ir2->bytecode (closure-body func) (make-locals-map (closure-arguments func)))) (list - (list 'label 'init)) - (ir2->bytecode (fix-body expr) (make-locals-map '())))))) + (list 'label 0)))))) diff --git a/csc/compiler.csc b/csc/compiler.csc index 6bdf1ba..ee0b3b4 100644 --- a/csc/compiler.csc +++ b/csc/compiler.csc @@ -4,7 +4,10 @@ compile) (import (scheme base) (only (scheme file) + call-with-input-file file-exists?) + (only (scheme read) + read) (only (csc codegen) ir2->ir3) (only (csc config) @@ -17,16 +20,32 @@ (only (csc format) sprintf) (only (csc hash-map) + compare-symbols hash-bytevector + insert + key-not-found-error? + lookup make-comparer make-map merge) + (only (csc ir1) + %define-syntax + %library-define + %library-ref + %sequence) (only (csc linker) link) (only (csc list) revappend) + (only (csc loop) + loop + return) + (only (csc macros) + expand-body) (only (csc match) - match)) + match) + (only (csc strings) + join)) (begin @@ -80,7 +99,7 @@ (define (ir1->bytecode expr) - (ir2->ir3 (closure-convert (ir1->ir2 expr)))) + (ir2->ir3 (closure-convert (ir1->ir2 expr (lambda (x) *tail*))))) ; compile turns scheme code into bytecode. @@ -104,8 +123,10 @@ ('import . imports) ('begin . body)) + (define expanded-body (expand-body library-name body env)) + (define env (make-import-map imports)) - (let loop ((expr (expand-body library-name body env))) + (let loop ((expr expanded-body)) (match expr ((% %library-define (% %library-ref name _) val) (set! env (insert env name val))) diff --git a/csc/config.csc b/csc/config.csc index 39268c0..d2618a7 100644 --- a/csc/config.csc +++ b/csc/config.csc @@ -1,5 +1,5 @@ (define-library (csc config) - (export *library-search-dir*) + (export *standard-library-dir*) (import (scheme base)) (begin diff --git a/csc/cps.csc b/csc/cps.csc index 9e1721c..cdd6611 100644 --- a/csc/cps.csc +++ b/csc/cps.csc @@ -56,7 +56,9 @@ %branch %fix %primitive + %tail *globals* + *tail* branch-atom closure-arguments closure-body @@ -69,7 +71,8 @@ make-label make-label make-primitive - make-variable) + make-variable + tail?) (only (csc loop) loop return) @@ -341,6 +344,8 @@ (get-boxed false))) ((% %apply proc args) (make-ref-map)) + ((% %tail) + (make-ref-map)) ((% %fix funs body) (loop with m = (get-boxed body) for fun in funs @@ -404,6 +409,8 @@ do (set! new-expr (make-primitive 'peek (list p (make-constant 0)) (list var) new-expr)) finally (return new-expr))) + ((% %tail) + *tail*) ((% %fix funs body) (define-values (new-names boxed-names temp-names) (convert-arg-list (loop for fun in funs collect (closure-name fun)))) @@ -468,6 +475,8 @@ if (free? arg) do (set! m (insert m arg #t)) finally (return m))) + ((% %tail) + (make-ref-map)) ((% %fix funs body) (loop for fun in funs for name = (closure-name fun) @@ -521,6 +530,8 @@ (fn (make-variable (gensym)))) (make-primitive 'peek (list p (make-constant 0)) (list fn) (make-apply fn (cons p (map translate args)))))) + ((% %tail) + *tail*) ((% %fix functions body) (define frees (map free-vars functions)) (define fn-ptrs (loop for fun in functions diff --git a/csc/flag.csc b/csc/flag.csc index ea699db..c328dcf 100644 --- a/csc/flag.csc +++ b/csc/flag.csc @@ -9,16 +9,22 @@ parse-error? parse-flags) (import (scheme base) + (only (scheme process-context) + command-line) (only (csc hash-map) compare-strings + insert key-not-found-error? lookup make-map) (only (csc loop) loop) + (only (csc match) + match) (only (csc strings) - prefix? - contains?)) + contains? + has-prefix? + split)) (begin @@ -94,7 +100,7 @@ (set! value (car args)) (set! args (cdr args))) (unless value - (raise (make-parse-flag "flag needs an argument" s))) + (raise (make-parse-error "flag needs an argument" s))) (parser value))) #t))) (loop while (parse-one)) diff --git a/csc/ir2.csc b/csc/ir2.csc index 4e4c42e..800d3c0 100644 --- a/csc/ir2.csc +++ b/csc/ir2.csc @@ -7,8 +7,10 @@ %globals %label %primitive + %tail %variable *globals* + *tail* apply-arguments apply-procedure apply? @@ -43,6 +45,7 @@ primitive-operation primitive-results primitive? + tail? variable-gensym variable? @@ -180,6 +183,17 @@ (arguments apply-arguments)) + ; The tail continuation. Used for the exit point of library init functions, + ; and the end of a program. + (define-match-record-type <tail> + (make-tail) + tail? + %tail) + + + (define *tail* (make-tail)) + + ; A procedure. All closures are allocated in a fix expression. A closure ; does not take a continuation. Instead, the procedure will accept the ; continuation as an argument. diff --git a/csc/main.csc b/csc/main.csc index a67a511..1e2cde1 100644 --- a/csc/main.csc +++ b/csc/main.csc @@ -2,8 +2,8 @@ (only (scheme read) read) (only (csc compiler) - *library-search-dirs*) - compile + *library-search-dirs* + compile) (only (csc flag) *args* bool-flag @@ -15,10 +15,12 @@ (only (csc format) printf) (only (csc loop) - loop)) + loop) + (only (csc match) + match)) -(define-flag *include* "include" (lambda (s) (cons s include)) '()) +(define-flag *include* "include" (lambda (s) (cons s *include*)) '()) (define-flag *output* "output" string-copy "") (define-flag *help* "help" bool-flag #f) |