[Guile-commits] 29/41: Remove add1 and sub1

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 8f18b71b7afcd475553f760f83af7d79fc34cf01
Author: Andy Wingo <address@hidden>
Date:   Fri Nov 20 14:03:32 2015 +0100

    Remove add1 and sub1
    
    * libguile/vm-engine.c: Remove add1 and sub1 instructions.  Will replace
      with add/immediate and sub/immediate.
    * module/language/tree-il/peval.scm (peval): If we reify a new
      <primcall>, expand it.  Removes 1- and similar primcalls.
    * module/language/tree-il/primitives.scm: Don't specialize (+ x 1) to 1+.
      (expand-primcall): New export, does a single primcall expansion.
      (expand-primitives): Use the new helper.
    * module/language/cps/effects-analysis.scm:
    * module/language/cps/primitives.scm:
    * module/language/cps/types.scm:
    * module/system/vm/assembler.scm: Remove support for add1 and sub1 CPS
      primitives.
    * test-suite/tests/peval.test ("partial evaluation"): Adapt tests that
      expect 1+/1- to expect +/-.
---
 libguile/vm-engine.c                     |   48 +----------------------------
 module/language/cps/effects-analysis.scm |    2 -
 module/language/cps/primitives.scm       |    7 ++--
 module/language/cps/types.scm            |    8 -----
 module/language/tree-il/peval.scm        |    3 +-
 module/language/tree-il/primitives.scm   |   40 +++++++++++-------------
 module/system/vm/assembler.scm           |    2 -
 test-suite/tests/peval.test              |    8 ++--
 8 files changed, 30 insertions(+), 88 deletions(-)

diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index d615af1..80ab3af 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -2382,29 +2382,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
       BINARY_INTEGER_OP (+, scm_sum);
     }
 
-  /* add1 dst:12 src:12
-   *
-   * Add 1 to the value in SRC, and place the result in DST.
-   */
-  VM_DEFINE_OP (87, add1, "add1", OP1 (X8_S12_S12) | OP_DST)
-    {
-      ARGS1 (x);
-
-      /* Check for overflow.  We must avoid overflow in the signed
-         addition below, even if X is not an inum.  */
-      if (SCM_LIKELY ((scm_t_signed_bits) SCM_UNPACK (x) <= INUM_MAX - 
INUM_STEP))
-        {
-          SCM result;
-
-          /* Add 1 to the integer without untagging.  */
-          result = SCM_PACK ((scm_t_signed_bits) SCM_UNPACK (x) + INUM_STEP);
-
-          if (SCM_LIKELY (SCM_I_INUMP (result)))
-            RETURN (result);
-        }
-
-      RETURN_EXP (scm_sum (x, SCM_I_MAKINUM (1)));
-    }
+  VM_DEFINE_OP (87, unused_87, NULL, NOP)
 
   /* sub dst:8 a:8 b:8
    *
@@ -2415,29 +2393,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
       BINARY_INTEGER_OP (-, scm_difference);
     }
 
-  /* sub1 dst:12 src:12
-   *
-   * Subtract 1 from SRC, and place the result in DST.
-   */
-  VM_DEFINE_OP (89, sub1, "sub1", OP1 (X8_S12_S12) | OP_DST)
-    {
-      ARGS1 (x);
-
-      /* Check for overflow.  We must avoid overflow in the signed
-         subtraction below, even if X is not an inum.  */
-      if (SCM_LIKELY ((scm_t_signed_bits) SCM_UNPACK (x) >= INUM_MIN + 
INUM_STEP))
-        {
-          SCM result;
-
-          /* Substract 1 from the integer without untagging.  */
-          result = SCM_PACK ((scm_t_signed_bits) SCM_UNPACK (x) - INUM_STEP);
-
-          if (SCM_LIKELY (SCM_I_INUMP (result)))
-            RETURN (result);
-        }
-
-      RETURN_EXP (scm_difference (x, SCM_I_MAKINUM (1)));
-    }
+  VM_DEFINE_OP (89, unused_89, NULL, NOP)
 
   /* mul dst:8 a:8 b:8
    *
diff --git a/module/language/cps/effects-analysis.scm 
b/module/language/cps/effects-analysis.scm
index 9112c42..21df42c 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 3628b5c..d648845 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 4fd5e56..1a0eebb 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 fca849e..355d423 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 7bed783..57072d4 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 76ae892..9dcd6dc 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)
diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test
index 93988af..5475103 100644
--- a/test-suite/tests/peval.test
+++ b/test-suite/tests/peval.test
@@ -534,7 +534,7 @@
     ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html>.
     (let ((fold (lambda (f g) (f (g top)))))
       (fold 1+ (lambda (x) x)))
-    (primcall 1+ (toplevel top)))
+    (primcall + (toplevel top) (const 1)))
   
   (pass-if-peval
     ;; Procedure not inlined when residual code contains recursive calls.
@@ -557,7 +557,7 @@
                    (lambda ()
                      (lambda-case
                       (((x2) #f #f #f () (_))
-                       (primcall 1- (lexical x2 _))))))))
+                       (primcall - (lexical x2 _) (const 1))))))))
 
   (pass-if "inlined lambdas are alpha-renamed"
     ;; In this example, `make-adder' is inlined more than once; thus,
@@ -788,8 +788,8 @@
                            (((x) #f #f #f () (_))
                             (if _ _
                                 (call (lexical loop _)
-                                       (primcall 1-
-                                                 (lexical x _))))))))
+                                      (primcall - (lexical x _)
+                                                (const 1))))))))
             (call (lexical loop _) (toplevel x))))
 
   (pass-if-peval