diff options
-rw-r--r-- | libguile/vm-i-scheme.c | 26 | ||||
-rw-r--r-- | module/language/tree-il/compile-glil.scm | 2 | ||||
-rw-r--r-- | module/language/tree-il/primitives.scm | 28 | ||||
-rw-r--r-- | test-suite/tests/tree-il.test | 2 |
4 files changed, 52 insertions, 6 deletions
diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c index dce9b5fbc..675ec1a0a 100644 --- a/libguile/vm-i-scheme.c +++ b/libguile/vm-i-scheme.c @@ -215,11 +215,37 @@ VM_DEFINE_FUNCTION (120, add, "add", 2) FUNC2 (+, scm_sum); } +VM_DEFINE_FUNCTION (167, add1, "add1", 1) +{ + ARGS1 (x); + if (SCM_I_INUMP (x)) + { + scm_t_int64 n = SCM_I_INUM (x) + 1; + if (SCM_FIXABLE (n)) + RETURN (SCM_I_MAKINUM (n)); + } + SYNC_REGISTER (); + RETURN (scm_sum (x, SCM_I_MAKINUM (1))); +} + VM_DEFINE_FUNCTION (121, sub, "sub", 2) { FUNC2 (-, scm_difference); } +VM_DEFINE_FUNCTION (168, sub1, "sub1", 1) +{ + ARGS1 (x); + if (SCM_I_INUMP (x)) + { + scm_t_int64 n = SCM_I_INUM (x) - 1; + if (SCM_FIXABLE (n)) + RETURN (SCM_I_MAKINUM (n)); + } + SYNC_REGISTER (); + RETURN (scm_difference (x, SCM_I_MAKINUM (1))); +} + VM_DEFINE_FUNCTION (122, mul, "mul", 2) { ARGS2 (x, y); diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index bf4699797..975cbf02a 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -85,6 +85,8 @@ ((>= . 2) . ge?) ((+ . 2) . add) ((- . 2) . sub) + ((1+ . 1) . add1) + ((1- . 1) . sub1) ((* . 2) . mul) ((/ . 2) . div) ((quotient . 2) . quo) diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm index 9ccd2720d..0f58e22fb 100644 --- a/module/language/tree-il/primitives.scm +++ b/module/language/tree-il/primitives.scm @@ -19,6 +19,7 @@ ;;; Code: (define-module (language tree-il primitives) + #:use-module (system base pmatch) #:use-module (rnrs bytevector) #:use-module (system base syntax) #:use-module (language tree-il) @@ -142,8 +143,14 @@ (define (consequent exp) (cond ((pair? exp) - `(make-application src (make-primitive-ref src ',(car exp)) - ,(inline-args (cdr exp)))) + (pmatch exp + ((if ,test ,then ,else) + `(if ,test + ,(consequent then) + ,(consequent else))) + (else + `(make-application src (make-primitive-ref src ',(car exp)) + ,(inline-args (cdr exp)))))) ((symbol? exp) ;; assume locally bound exp) @@ -163,6 +170,15 @@ (define-primitive-expander + () 0 (x) x + (x y) (if (and (const? y) + (let ((y (const-exp y))) + (and (exact? y) (= y 1)))) + (1+ x) + (if (and (const? x) + (let ((x (const-exp x))) + (and (exact? x) (= x 1)))) + (1+ y) + (+ x y))) (x y z . rest) (+ x (+ y z . rest))) (define-primitive-expander * @@ -172,11 +188,13 @@ (define-primitive-expander - (x) (- 0 x) + (x y) (if (and (const? y) + (let ((y (const-exp y))) + (and (exact? y) (= y 1)))) + (1- x) + (- x y)) (x y z . rest) (- x (+ y z . rest))) -(define-primitive-expander 1- - (x) (- x 1)) - (define-primitive-expander / (x) (/ 1 x) (x y z . rest) (/ x (* y z . rest))) diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test index 896206b1f..d993e4ff2 100644 --- a/test-suite/tests/tree-il.test +++ b/test-suite/tests/tree-il.test @@ -72,7 +72,7 @@ (program 0 0 0 () (const 1) (call return 1))) (assert-tree-il->glil (apply (primitive +) (void) (const 1)) - (program 0 0 0 () (void) (const 1) (call add 2) (call return 1)))) + (program 0 0 0 () (void) (call add1 1) (call return 1)))) (with-test-prefix "application" (assert-tree-il->glil |