diff options
Diffstat (limited to 'csc')
| -rw-r--r-- | csc/cps-test.csc | 202 | ||||
| -rw-r--r-- | csc/cps.csc | 197 | ||||
| -rw-r--r-- | csc/hash-map-test.csc | 17 | ||||
| -rw-r--r-- | csc/hash-map.csc | 8 | ||||
| -rw-r--r-- | csc/ir1.csc | 12 | ||||
| -rw-r--r-- | csc/ir2.csc | 64 | ||||
| -rw-r--r-- | csc/linker.csc | 9 | ||||
| -rw-r--r-- | csc/macros.csc | 10 |
8 files changed, 356 insertions, 163 deletions
diff --git a/csc/cps-test.csc b/csc/cps-test.csc index 3f0d743..c72aca6 100644 --- a/csc/cps-test.csc +++ b/csc/cps-test.csc @@ -22,7 +22,8 @@ make-kargs make-klabel make-ktail - make-primitive) + make-primitive + make-variable) (only (csc testing) assert-equal test) @@ -128,85 +129,152 @@ tail))) -(test letrec-in-order +(test letrec-functions + (define x (test-ref 'x)) + (define f (gensym)) (assert-equal ir2=? (make-fix (list - (make-closure (test-ref 'f) (list (test-ref 'generated-symbol) - (test-ref 'x)) #f - (make-apply (test-ref 'generated-symbol) (list (make-constant 5))))) + (make-closure (test-ref 'f) (list (test-ref 'generated-symbol) (test-ref 'x)) #f + (make-apply (test-ref 'generated-symbol) (list (test-ref 'x))))) (make-fix (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) #f (make-apply (test-ref 'tail) (list (test-ref 'generated-symbol))))) + (make-apply (test-ref 'f) (list (test-ref 'generated-symbol) (make-constant 10))))) + (ir1->ir2 + (make-letrec #f '(f) (list f) + (list (make-lambda (list x) #f x)) + (make-call (make-lexical-ref 'f f) (list (make-constant 10)))) + tail))) + + +(test letrec-in-order + (assert-equal ir2=? + (make-primitive 'alloc (list (make-constant 1)) (list (test-ref 'b)) + (make-primitive 'alloc (list (make-constant 1)) (list (test-ref 'a)) (make-fix (list - (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) - (test-ref 'a)) #f - (make-fix - (list - (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) #f - (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) - (make-fix - (list - (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) - (test-ref 'b)) #f - (make-apply (test-ref 'generated-symbol) (list (make-constant 10))))) - (make-apply (test-ref 'generated-symbol) - (list (test-ref 'generated-symbol) - (make-constant 2))))))) - (make-apply (test-ref 'generated-symbol) - (list (test-ref 'generated-symbol) - (make-constant 1)))))) - (ir1->ir2 (make-letrec - #t - '(a f b) - (list (gensym) (gensym) (gensym)) - (list (make-constant 1) - (make-lambda (list (test-ref 'x)) #f (make-constant 5)) - (make-constant 2)) - (make-constant 10)) - tail))) + (make-closure (test-ref 'f) (list (test-ref 'generated-symbol) (test-ref 'x)) #f + (make-apply (test-ref 'generated-symbol) (list (make-constant 5))))) + (make-primitive 'poke (list (make-constant 1) (test-ref 'a) (make-constant 0)) '() + (make-primitive 'poke (list (make-constant 2) (test-ref 'b) (make-constant 0)) '() + (make-apply (test-ref 'tail) (list (make-constant 10)))))))) + (ir1->ir2 + (make-letrec #t + '(a f b) + (list (gensym) (gensym) (gensym)) + (list (make-constant 1) + (make-lambda (list (test-ref 'x)) #f (make-constant 5)) + (make-constant 2)) + (make-constant 10)) + tail))) + + +; What does the following letrec return? +; (letrec* ((f (lambda () x)) +; (x (f))) +; x) +(test letrec-very-cool + (define f (gensym)) + (define x (gensym)) + (assert-equal ir2=? + (make-primitive 'alloc (list (make-constant 1)) (list (test-ref 'x)) + (make-fix + (list + (make-closure (test-ref 'f) (list (test-ref 'generated-symbol)) #f + (make-primitive 'peek (list (test-ref 'x) (make-constant 0)) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)))))) + (make-fix + (list + (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) #f + (make-primitive 'poke (list (test-ref 'generated-symbol) (test-ref 'x) (make-constant 0)) '() + (make-primitive 'peek (list (test-ref 'x) (make-constant 0)) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'tail) (list (test-ref 'generated-symbol))))))) + (make-apply (test-ref 'f) (list (test-ref 'generated-symbol)))))) + (ir1->ir2 + (make-letrec #t + '(f x) + (list f x) + (list (make-lambda '() #f (make-lexical-ref 'x x)) + (make-call (make-lexical-ref 'f f) '())) + (make-lexical-ref 'x x)) + tail))) (test set-argument - (make-fix - (list - (make-closure (test-ref 'f) (list (test-ref 'generated-symbol) - (test-ref 'generated-symbol)) #f - (make-primitive 'alloc (list (make-constant 1)) - (list (test-ref 'x)) - (make-primitive 'poke (list (test-ref 'generated-symbol) - (test-ref 'x) - (make-constant 0)) '() - (make-primitive 'poke (list (make-constant 10) + (define test-sym (gensym)) + (assert-equal ir2=? + (make-fix + (list + (make-closure (test-ref 'f) (list (test-ref 'generated-symbol) + (test-ref 'generated-symbol)) #f + (make-primitive 'alloc (list (make-constant 1)) + (list (test-ref 'x)) + (make-primitive 'poke (list (test-ref 'generated-symbol) (test-ref 'x) (make-constant 0)) '() - (make-apply (test-ref 'generated-symbol) (list (make-constant #f)))))))) - (make-apply (test-ref 'tail) (make-constant 5))) - (ir1->ir2 (make-letrec - #f - '(f) - (list (gensym)) - (list (make-lambda (list (test-ref 'x)) #f - (make-lexical-set (test-ref 'x) (make-constant 10)))) - (make-constant 5)) - tail)) - + (make-primitive 'poke (list (make-constant 10) + (test-ref 'x) + (make-constant 0)) '() + (make-apply (test-ref 'generated-symbol) (list (make-constant #f)))))))) + (make-apply (test-ref 'tail) (list (make-constant 5)))) + (ir1->ir2 (make-letrec + #f + '(f) + (list (gensym)) + (list (make-lambda (list (make-lexical-ref 'x test-sym)) #f + (make-lexical-set (make-lexical-ref 'x test-sym) (make-constant 10)))) + (make-constant 5)) + tail))) (test set-function - (make-primitive 'alloc (list (make-constant 1)) (list (test-ref 'f)) - (make-fix - (list - (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) #f - (make-apply (test-ref 'generated-symbol) (list (make-constant 10))))) - (make-primitive 'poke (list (test-ref 'generated-symbol) (test-ref 'f) (make-constant 0)) '() - (make-primitive 'poke (list (make-constant 5) (test-ref 'f) (make-constant 0)) '() - (make-apply (test-ref 'tail) (make-constant #f)))))) - (ir1->ir2 (make-letrec - #f - '(f) - (list (gensym)) - (list (make-lambda '() #f (make-constant 10))) - (make-lexical-set (test-ref 'f) (make-constant 5))) - tail)) + (define test-sym (gensym)) + (assert-equal ir2=? + (make-primitive 'alloc (list (make-constant 1)) (list (test-ref 'f)) + (make-fix + (list + (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) #f + (make-apply (test-ref 'generated-symbol) (list (make-constant 10))))) + (make-primitive 'poke (list (test-ref 'generated-symbol) (test-ref 'f) (make-constant 0)) '() + (make-primitive 'poke (list (make-constant 5) (test-ref 'f) (make-constant 0)) '() + (make-apply (test-ref 'tail) (list (make-constant #f))))))) + (ir1->ir2 (make-letrec + #f + '(f) + (list test-sym) + (list (make-lambda '() #f (make-constant 10))) + (make-lexical-set (make-lexical-ref 'f test-sym) (make-constant 5))) + tail))) + + +(define (test-var) + (make-variable (gensym))) + + +(test closure-convert-primitive + (define a-sym (gensym)) + (define f-sym (gensym)) + (define ret-sym (gensym)) + (define x-sym (gensym)) + (assert-equal ir2=? + (make-primitive 'alloc (list (make-constant 1)) (list (test-var)) + (make-fix + (list + (make-closure (test-var) (list (test-var) (test-var) (test-var)) #f + (make-primitive 'peek (list (test-var) (make-constant 0)) (list (test-var)) + (make-primitive 'poke (list (test-var) (test-var) (make-constant 0)) '() + (make-primitive 'peek (list (test-var) (make-constant 0)) (list (test-var)) + (make-apply (test-var) (list (test-var) (make-constant #f)))))))) + (make-primitive 'alloc (list (make-constant 2)) (list (test-var)) + (make-primitive 'poke (list (test-var) (test-var) (make-constant 0)) '() + (make-primitive 'poke (list (test-var) (test-var) (make-constant 1)) '() + (make-primitive 'peek (list (test-var) (make-constant 0)) (list (test-var)) + (make-apply (test-var) (list (test-var) (make-library-ref 'tail '(csc builtins)) (make-constant 10))))))))) + (closure-convert (make-primitive 'alloc (list (make-constant 1)) (list (make-lexical-ref 'a a-sym)) + (make-fix + (list + (make-closure (make-lexical-ref 'f f-sym) (list (make-lexical-ref 'ret ret-sym) (make-lexical-ref 'x x-sym)) #f + (make-primitive 'poke (list (make-lexical-ref 'x x-sym) (make-lexical-ref 'a a-sym) (make-constant 0)) '() + (make-apply (make-lexical-ref 'ret ret-sym) (list (make-constant #f)))))) + (make-apply (make-lexical-ref 'f f-sym) (list (make-library-ref 'tail '(csc builtins)) (make-constant 10)))))))) diff --git a/csc/cps.csc b/csc/cps.csc index cf46e05..827f4b7 100644 --- a/csc/cps.csc +++ b/csc/cps.csc @@ -1,5 +1,6 @@ (define-library (csc cps) (export + closure-convert ir1->ir2) (import (scheme base) (only (csc gensym) @@ -10,6 +11,7 @@ key-not-found-error? lookup make-map + map->alist merge) (only (csc ir1) %call @@ -17,6 +19,7 @@ %if %lambda %letrec + %lexical-ref %lexical-set %library-define %sequence @@ -58,7 +61,8 @@ make-kargs make-klabel make-ktail - make-primitive) + make-primitive + make-variable) (only (csc loop) loop return) @@ -189,34 +193,23 @@ (lambda (ret) (make-apply k (list ret)))))) (continuation f))) - ((% %letrec in-order? _ _ _ body) + ((% %letrec _ _ _ _ body) (define-values (functions variable-names variable-values) (collect-functions-and-variables expr)) - (make-fix functions - (to-cps - ; We re-write a letrec into a corresponding lambda form. - (if in-order? - (loop for name in (reverse variable-names) - for value in (reverse variable-values) - for expr = (make-call - (make-lambda - (list name) - #f - body) - (list value)) - then (make-call - (make-lambda - (list name) - #f - expr) - (list value)) - finally (return expr)) - (make-call - (make-lambda - variable-names - #f - body) - variable-values)) - continuation))) + (if (null? variable-names) + (make-fix functions + (to-cps body continuation)) + (loop with new-expr = (make-fix functions + (loop for var in (reverse variable-names) + for val in (reverse variable-values) + with new-body = (to-cps body continuation) + do (set! new-body (to-cps val (lambda (x) + (make-update var x + new-body)))) + finally (return new-body))) + for var in variable-names + do (set! new-expr (make-primitive 'alloc (list (make-constant 1)) (list var) + new-expr)) + finally (return new-expr)))) (_ (error "unexpected type in to-cps" expr)))) @@ -224,7 +217,8 @@ (make-map (lambda (ref) (gensym->int (lexical-ref-gensym ref))) - (lambda (x y) (< (gensym->int (lexical-ref-gensym x)) + (lambda (x y) + (< (gensym->int (lexical-ref-gensym x)) (gensym->int (lexical-ref-gensym y)))))) @@ -248,7 +242,7 @@ for fun in funs do (set! m (merge m (get-boxed (closure-body fun)))) finally (return m))) - (_ (error "Unexpected form in get-boxed")))) + (_ (error "Unexpected form in get-boxed" expr)))) (define (all-closure-args fun) @@ -339,8 +333,147 @@ (loop for name in boxed-names do (set! new-expr (make-primitive 'alloc (list (make-constant 1)) (list name) new-expr)) - finally (return expr)))))) + finally (return new-expr))) + (_ (error "Unexpected form in box-conversion" expr))))) (define (ir1->ir2 expr continuation) - (box-conversion (to-cps expr continuation))))) + (box-conversion (to-cps expr continuation))) + + + (define (free-vars-expr expr bound-vars) + (define (free? ref) + (and (lexical-ref? ref) + (not (guard (e ((key-not-found-error? e) #f)) + (lookup bound-vars ref))))) + (match expr + ((% %primitive _ args res continuation) + (loop for r in res + if (lexical-ref? r) + do (set! bound-vars (insert bound-vars r #t))) + (loop with m = (free-vars-expr continuation bound-vars) + for arg in args + if (free? arg) + do (set! m (insert m arg #t)) + finally (return m))) + ((% %branch atom true false) + (define m (merge (free-vars-expr true bound-vars) (free-vars-expr false bound-vars))) + (if (free? atom) + (set! m (insert m atom #t))) + m) + ((% %apply proc args) + (define m (make-ref-map)) + (if (free? proc) + (set! m (insert m proc #t))) + (loop for arg in args + if (free? arg) + do (set! m (insert m arg #t)) + finally (return m))) + ((% %fix funs body) + (loop for fun in funs + for name = (closure-name fun) + if (lexical-ref? name) + do (set! bound-vars (insert bound-vars name #t))) + (define m (free-vars-expr body bound-vars)) + (loop for fun in funs + do (set! m (merge m (free-vars-closure fun bound-vars))) + finally (return m))) + (_ (error "Unexpected form in free-vars-expr" expr)))) + + + (define (free-vars-closure fun bound-vars) + (define name (closure-name fun)) + (define rest (closure-rest fun)) + (when (lexical-ref? name) + (set! bound-vars (insert bound-vars name #t))) + (when rest + (set! bound-vars (insert bound-vars rest #t))) + (loop for arg in (closure-arguments fun) + do (set! bound-vars (insert bound-vars arg #t))) + (free-vars-expr (closure-body fun) bound-vars)) + + + ; Returns a list of the free variables in a closure. + (define (free-vars expr) + (define m (free-vars-closure expr (make-ref-map))) + (map car (map->alist m))) + + + (define (translate-ref ref env) + (if (lexical-ref? ref) + (guard (e ((key-not-found-error? e) (error "Undefined symbol in closure-convert" ref))) + (lookup env ref)) + ref)) + + + ; converts a CPS expression into an equivalent expression with no + ; free variables. + (define (closure-convert expr) + (let convert ((expr expr) + (env (make-ref-map))) + (define (translate ref) + (translate-ref ref env)) + (match expr + ((% %primitive op args res continuation) + (loop for r in res + do (set! env (insert env r (make-variable (gensym))))) + (make-primitive op (map translate args) (map translate res) (convert continuation env))) + ((% %branch atom true false) + (make-branch (translate atom) (convert true env) (convert false env))) + ((% %apply proc args) + (let ((p (translate proc)) + (fn (make-variable (gensym)))) + (make-primitive 'peek (list p (make-constant 0)) (list fn) + (make-apply fn (cons p (map translate args)))))) + ((% %fix functions body) + (define frees (map free-vars functions)) + (define fn-ptrs (loop for fun in functions + collect (make-variable (gensym)))) + (define converted-functions (loop for fun in functions + for fn-ptr in fn-ptrs + for free-list in frees + for env* = env + for name = (closure-name fun) + for closure = (make-variable (gensym)) + if (lexical-ref? name) + do (set! env* (insert env* name closure)) + do (loop for arg in (closure-arguments fun) + do (set! env* (insert env* arg (make-variable (gensym))))) + (loop for var in free-list + do (set! env* (insert env* var (make-variable (gensym))))) + collect (let ((new-body (convert (closure-body fun) env*))) + (loop for var in free-list + for i from 0 + do (set! new-body (make-primitive 'peek (list closure (make-constant i)) (list (translate-ref var env*)) + new-body))) + (make-closure + fn-ptr + (cons closure (map (lambda (x) (translate-ref x env*)) (closure-arguments fun))) + (if (closure-rest fun) + (translate (closure-rest fun)) + #f) + new-body)))) + (loop for fun in functions + for name = (closure-name fun) + if (lexical-ref? name) + do (set! env (insert env name (make-variable (gensym))))) + (let ((new-body (convert body env))) + ; Build the closures. + (loop for fun in functions + for free-list in frees + for ptr in fn-ptrs + for closure = (translate (closure-name fun)) + do (loop for var in free-list + for i from 1 + do (set! new-body (make-primitive 'poke (list (translate var) closure (make-constant i)) '() + new-body))) + (set! new-body (make-primitive 'poke (list ptr closure (make-constant 0)) '() + new-body))) + ; Allocate the closures. + (loop for fun in functions + for free-list in frees + for closure = (translate (closure-name fun)) + do (set! new-body (make-primitive 'alloc (list (make-constant (+ 1 (length free-list)))) (list closure) + new-body))) + (make-fix converted-functions new-body))) + (_ (error "Unexpected form in closure-convert" expr))))))) diff --git a/csc/hash-map-test.csc b/csc/hash-map-test.csc index f346e1e..677406e 100644 --- a/csc/hash-map-test.csc +++ b/csc/hash-map-test.csc @@ -15,15 +15,8 @@ (string<? (symbol->string s1) (symbol->string s2))) -(define (cmp-symbols s1 s2) - (cond - ((symbol<? s1 s2) -1) - ((symbol=? s1 s2) 0) - (else 1))) - - (define (alist->map->alist l) - (map->alist (alist->map hash-symbol cmp-symbols l))) + (map->alist (alist->map hash-symbol symbol<? l))) (define (sort-alist l) @@ -77,12 +70,12 @@ (test lookup (assert-equal 2 - (lookup (alist->map hash-symbol cmp-symbols '((a . 1) (b . 2) (c . 3))) 'b))) + (lookup (alist->map hash-symbol symbol<? '((a . 1) (b . 2) (c . 3))) 'b))) (test lookup-notfound (assert-raises key-not-found-error? - (lookup (alist->map hash-symbol cmp-symbols '((a . 1) (b . 2) (c . 3))) 'd))) + (lookup (alist->map hash-symbol symbol<? '((a . 1) (b . 2) (c . 3))) 'd))) (test merge @@ -91,5 +84,5 @@ (sort-alist (map->alist (merge - (alist->map hash-symbol cmp-symbols '((a . 1) (b . 2))) - (alist->map hash-symbol cmp-symbols '((c . 3) (d . 4)))))))) + (alist->map hash-symbol symbol<? '((a . 1) (b . 2))) + (alist->map hash-symbol symbol<? '((c . 3) (d . 4)))))))) diff --git a/csc/hash-map.csc b/csc/hash-map.csc index ae5c3df..be9e507 100644 --- a/csc/hash-map.csc +++ b/csc/hash-map.csc @@ -26,11 +26,15 @@ (define (key-hash<? k1 k2 cmp) (cond ((< (key-hash-hash k1) (key-hash-hash k2)) #t) ((> (key-hash-hash k1) (key-hash-hash k2)) #f) - (else (< (cmp (key-hash-value k1) (key-hash-value k2)) 0)))) + (else (cmp (key-hash-value k1) (key-hash-value k2))))) (define (key-hash=? k1 k2 cmp) - (and (= (key-hash-hash k1) (key-hash-hash k2)) (= 0 (cmp (key-hash-value k1) (key-hash-value k2))))) + (let ((v1 (key-hash-value k1)) + (v2 (key-hash-value k2))) + (and (= (key-hash-hash k1) (key-hash-hash k2)) + (not (cmp v1 v2)) + (not (cmp v2 v1))))) (define-record-type <node> diff --git a/csc/ir1.csc b/csc/ir1.csc index 73ec703..33588c9 100644 --- a/csc/ir1.csc +++ b/csc/ir1.csc @@ -196,7 +196,7 @@ (expression letrec-expression)) - (define (ir1=?-sametype x y) + (define (ir1=? x y) (cond ((and (constant? x) (constant? y)) (equal? (constant-expression x) (constant-expression y))) @@ -253,12 +253,4 @@ (= (length x-values) (length y-values)) (all ir1=? x-values y-values) (ir1=? (letrec-expression x) (letrec-expression y))))) - (else #f))) - - - (define (ir1=? x y) - (cond - ((ir1=?-sametype x y) #t) - ((and (ir1=?-sametype x x) (ir1=?-sametype y y)) - #f) - (else (error "One or more arguments has a type unknown to ir1=?" x y)))))) + (else #f))))) diff --git a/csc/ir2.csc b/csc/ir2.csc index 7aea0a3..462a4a4 100644 --- a/csc/ir2.csc +++ b/csc/ir2.csc @@ -5,6 +5,7 @@ %closure %fix %primitive + %variable apply-arguments apply-procedure apply? @@ -43,11 +44,14 @@ make-klabel make-ktail make-primitive + make-variable primitive-arguments primitive-continuation primitive-operation primitive-results primitive? + variable-gensym + variable? ; Re-exports from IR1. constant-expression @@ -100,6 +104,17 @@ ; - constant, ; - lexical-ref, ; - or library-ref + ; After closure conversion, there are no more lexical refs. + ; Each lexical ref will be converted to one of the following + ; data types. + + + ; A function argument or local variable. + (define-match-record-type <variable> + (make-variable gensym) + variable? + %variable + (gensym variable-gensym)) ; CPS expressions: @@ -171,46 +186,45 @@ (body fix-body)) + (define (atom=? x y) + (if (and (variable? x) (variable? y)) + #t + (ir1=? x y))) + + (define (closure=? x y) - (let ((x-args (closure-arguments x)) - (x-rest (closure-rest x)) - (y-args (closure-arguments y)) - (y-rest (closure-rest y))) - (and (ir1=? (closure-name x) (closure-name y)) - (= (length x-args) (length y-args)) - (all ir1=? x-args y-args) - (or (and (not x-rest) (not y-rest)) - (and x-rest y-rest (ir1=? x-rest y-rest))) - (ir2=? (closure-body x) (closure-body y))))) + (and (closure? x) (closure? y) + (let ((x-args (closure-arguments x)) + (x-rest (closure-rest x)) + (y-args (closure-arguments y)) + (y-rest (closure-rest y))) + (and (atom=? (closure-name x) (closure-name y)) + (= (length x-args) (length y-args)) + (all atom=? x-args y-args) + (or (and (not x-rest) (not y-rest)) + (and x-rest y-rest (atom=? x-rest y-rest))) + (ir2=? (closure-body x) (closure-body y)))))) - (define (ir2=?-sametype x y) + (define (ir2=? x y) (match (cons x y) (((% %primitive x-oper x-args x-res x-cont) . (% %primitive y-oper y-args y-res y-cont)) (and (symbol=? x-oper y-oper) (= (length x-args) (length y-args)) - (all ir1=? x-args y-args) + (all atom=? x-args y-args) (= (length x-res) (length y-res)) - (all ir1=? x-res y-res) + (all atom=? x-res y-res) (ir2=? x-cont y-cont))) (((% %branch x-atom x-true x-false) . (% %branch y-atom y-true y-false)) - (and (ir1=? x-atom y-atom) + (and (atom=? x-atom y-atom) (ir2=? x-true y-true) (ir2=? x-false y-false))) (((% %apply x-proc x-args) . (% %apply y-proc y-args)) - (and (ir1=? x-proc y-proc) + (and (atom=? x-proc y-proc) (= (length x-args) (length y-args)) - (all ir1=? x-args y-args))) + (all atom=? x-args y-args))) (((% %fix x-funs x-body) . (% %fix y-funs y-body)) (and (= (length x-funs) (length y-funs)) (all closure=? x-funs y-funs) (ir2=? x-body y-body))) - (_ #f))) - - - (define (ir2=? x y) - (cond - ((ir2=?-sametype x y) #t) - ((and (ir2=?-sametype x x) (ir2=?-sametype y y)) - #f) - (else (error "One or more arguments has a type unknown to ir2=?" x y)))))) + (_ #f))))) diff --git a/csc/linker.csc b/csc/linker.csc index b3f2a5d..852ee13 100644 --- a/csc/linker.csc +++ b/csc/linker.csc @@ -41,15 +41,8 @@ (hash-bytevector (string->utf8 s))) - (define (cmp-strings s1 s2) - (cond - ((string<? s1 s2) -1) - ((string=? s1 s2) 0) - (else 1))) - - (define (make-label-map program) - (let loop ((m (make-map hash-string cmp-strings)) + (let loop ((m (make-map hash-string string<?)) (program program) (i 0)) (match program diff --git a/csc/macros.csc b/csc/macros.csc index 6364e19..045194b 100644 --- a/csc/macros.csc +++ b/csc/macros.csc @@ -17,7 +17,6 @@ insert key-not-found-error? lookup - make-map map-for-each merge) (only (csc ir1) @@ -374,15 +373,12 @@ (hash-bytevector (string->utf8 (identifier-uuid i)))) - (define (cmp-identifier i1 i2) - (cond - ((string<? (identifier-uuid i1) (identifier-uuid i2)) -1) - ((string=? (identifier-uuid i1) (identifier-uuid i2)) 0) - (else 1))) + (define (identifier<? i1 i2) + (string<? (identifier-uuid i1) (identifier-uuid i2))) (define (alist->substitutions l) - (alist->map hash-identifier cmp-identifier l)) + (alist->map hash-identifier identifier<? l)) (define (is-underscore expression) |