summaryrefslogtreecommitdiff
path: root/module
diff options
context:
space:
mode:
Diffstat (limited to 'module')
-rw-r--r--module/language/cps/effects-analysis.scm2
-rw-r--r--module/language/cps/primitives.scm7
-rw-r--r--module/language/cps/types.scm8
-rw-r--r--module/language/tree-il/peval.scm3
-rw-r--r--module/language/tree-il/primitives.scm40
-rw-r--r--module/system/vm/assembler.scm2
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)