diff options
Diffstat (limited to 'module')
-rw-r--r-- | module/language/cps/effects-analysis.scm | 2 | ||||
-rw-r--r-- | module/language/cps/primitives.scm | 7 | ||||
-rw-r--r-- | module/language/cps/types.scm | 8 | ||||
-rw-r--r-- | module/language/tree-il/peval.scm | 3 | ||||
-rw-r--r-- | module/language/tree-il/primitives.scm | 40 | ||||
-rw-r--r-- | module/system/vm/assembler.scm | 2 |
6 files changed, 24 insertions, 38 deletions
diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm index 9112c429b..21df42ccd 100644 --- a/module/language/cps/effects-analysis.scm +++ b/module/language/cps/effects-analysis.scm @@ -428,8 +428,6 @@ is or might be a read or a write to the same location as A." ((uadd . _)) ((usub . _)) ((umul . _)) - ((sub1 . _) &type-check) - ((add1 . _) &type-check) ((quo . _) &type-check) ((rem . _) &type-check) ((mod . _) &type-check) diff --git a/module/language/cps/primitives.scm b/module/language/cps/primitives.scm index 3628b5cf7..d6488450d 100644 --- a/module/language/cps/primitives.scm +++ b/module/language/cps/primitives.scm @@ -34,9 +34,10 @@ )) (define *instruction-aliases* - '((+ . add) (1+ . add1) - (- . sub) (1- . sub1) - (* . mul) (/ . div) + '((+ . add) + (- . sub) + (* . mul) + (/ . div) (quotient . quo) (remainder . rem) (modulo . mod) (variable-ref . box-ref) diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index 4fd5e569e..1a0eebbe1 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -1061,14 +1061,6 @@ minimum, and maximum." (lambda (min max) (define! result &f64 min max))))) -(define-simple-type-checker (add1 &number)) -(define-type-inferrer (add1 a result) - (define-unary-result! a result (1+ (&min a)) (1+ (&max a)))) - -(define-simple-type-checker (sub1 &number)) -(define-type-inferrer (sub1 a result) - (define-unary-result! a result (1- (&min a)) (1- (&max a)))) - (define-type-checker (quo a b) (and (check-type a &exact-integer -inf.0 +inf.0) (check-type b &exact-integer -inf.0 +inf.0) diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm index fca849ec0..355d423dd 100644 --- a/module/language/tree-il/peval.scm +++ b/module/language/tree-il/peval.scm @@ -1357,7 +1357,8 @@ top-level bindings from ENV and return the resulting expression." (let revisit-proc ((proc (visit orig-proc 'operator))) (match proc (($ <primitive-ref> _ name) - (for-tail (make-primcall src name orig-args))) + (for-tail + (expand-primcall (make-primcall src name orig-args)))) (($ <lambda> _ _ ($ <lambda-case> _ req opt rest #f inits gensyms body #f)) ;; Simple case: no keyword arguments. diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm index 7bed7832c..57072d4d9 100644 --- a/module/language/tree-il/primitives.scm +++ b/module/language/tree-il/primitives.scm @@ -27,7 +27,7 @@ #:use-module (srfi srfi-4) #:use-module (srfi srfi-16) #:export (resolve-primitives add-interesting-primitive! - expand-primitives + expand-primcall expand-primitives effect-free-primitive? effect+exception-free-primitive? constructor-primitive? singly-valued-primitive? equality-primitive? @@ -313,16 +313,16 @@ (define *primitive-expand-table* (make-hash-table)) +(define (expand-primcall x) + (record-case x + ((<primcall> src name args) + (let ((expand (hashq-ref *primitive-expand-table* name))) + (or (and expand (apply expand src args)) + x))) + (else x))) + (define (expand-primitives x) - (pre-order - (lambda (x) - (record-case x - ((<primcall> src name args) - (let ((expand (hashq-ref *primitive-expand-table* name))) - (or (and expand (apply expand src args)) - x))) - (else x))) - x)) + (pre-order expand-primcall x)) ;;; I actually did spend about 10 minutes trying to redo this with ;;; syntax-rules. Patches appreciated. @@ -388,18 +388,16 @@ ;; FIXME: All the code that uses `const?' is redundant with `peval'. +(define-primitive-expander 1+ (x) + (+ x 1)) + +(define-primitive-expander 1- (x) + (- x 1)) + (define-primitive-expander + () 0 (x) (values x) - (x y) (if (and (const? y) (eqv? (const-exp y) 1)) - (1+ x) - (if (and (const? y) (eqv? (const-exp y) -1)) - (1- x) - (if (and (const? x) (eqv? (const-exp x) 1)) - (1+ y) - (if (and (const? x) (eqv? (const-exp x) -1)) - (1- y) - (+ x y))))) + (x y) (+ x y) (x y z ... last) (+ (+ x y . z) last)) (define-primitive-expander * @@ -409,9 +407,7 @@ (define-primitive-expander - (x) (- 0 x) - (x y) (if (and (const? y) (eqv? (const-exp y) 1)) - (1- x) - (- x y)) + (x y) (- x y) (x y z ... last) (- (- x y . z) last)) (define-primitive-expander / diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 76ae892a3..9dcd6dc79 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -129,9 +129,7 @@ (emit-set-car!* . emit-set-car!) (emit-set-cdr!* . emit-set-cdr!) (emit-add* . emit-add) - (emit-add1* . emit-add1) (emit-sub* . emit-sub) - (emit-sub1* . emit-sub1) (emit-mul* . emit-mul) (emit-div* . emit-div) (emit-quo* . emit-quo) |