add1 and sub1 instructions

* libguile/vm-i-scheme.c: Add add1 and sub1 instructions.
* module/language/tree-il/compile-glil.scm: Compile 1+ and 1- to add1
  and sub1.

* module/language/tree-il/primitives.scm (define-primitive-expander):
  Add support for `if' statements in the consequent.
  (+, -): Compile (- x 1), (+ x 1), and (+ 1 x) to 1- or 1+ as
  appropriate.
  (1-): Remove this one. Seems we forgot 1+ before, but we weren't
  compiling it nicely anyway.

* test-suite/tests/tree-il.test ("void"): Fix expected compilation of (+
  (void) 1) to allow for add1.

diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c
index dce9b5f..675ec1a 100644 (file)
--- 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 bf46997..975cbf0 100644 (file)
--- 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 9ccd272..0f58e22 100644 (file)
--- 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 896206b..d993e4f 100644 (file)
--- 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