Fixes bug 191659: add1 and sub1 are slow

scheme/ikarus.fixnums.ss

@@ -26,7 +26,7 @@
           fixnum->string 
           fxarithmetic-shift-left fxarithmetic-shift-right fxarithmetic-shift
           fxmin fxmax
-          error@fx+ error@fx* error@fx-)
+          error@fx+ error@fx* error@fx- error@fxadd1 error@fxsub1)
   (import 
     (ikarus system $fx)
     (ikarus system $chars)
@@ -52,17 +52,6 @@
         [(fixnum? x) #f]
         [else (die 'fxzero? "not a fixnum" x)])))
   
-  (define fxadd1
-    (lambda (n)
-      (if (fixnum? n)
-          ($fxadd1 n)
-          (die 'fxadd1 "not a fixnum" n))))
-  
-  (define fxsub1 
-    (lambda (n) 
-      (if (fixnum? n)
-          ($fxsub1 n)
-          (die 'fxsub1 "not a fixnum" n))))
 
   (define fxlognot 
     (lambda (x)
@@ -107,6 +96,22 @@
       [(x y) (sys:fx- x y)]
       [(x)   (sys:fx- x)]))
 
+  (define error@fxadd1 
+    (make-fx-error 'fxadd1 "overflow during addition"))
+
+  (define error@fxsub1 
+    (make-fx-error 'fxsub1 "overflow during subtraction"))
+
+  (define fxadd1
+    (lambda (n)
+      (import (ikarus))
+      (fxadd1 n)))
+  
+  (define fxsub1 
+    (lambda (n) 
+      (import (ikarus))
+      (fxsub1 n)))
+
   (define false-loop
     (lambda (who ls)
       (if (pair? ls) 

scheme/ikarus.numerics.ss

@@ -406,7 +406,8 @@
           exact->inexact inexact floor ceiling round log fl=? fl<? fl<=? fl>?
           fl>=? fl+ fl- fl* fl/ flsqrt flmin flzero? flnegative?
           sin cos tan asin acos atan sqrt exp
-          flmax random)
+          flmax random
+          error@add1 error@sub1)
   (import 
     (ikarus system $fx)
     (ikarus system $flonums)
@@ -1720,23 +1721,31 @@
     (mk< >= $fx>= fxbn> bnfx> bnbn>= fxfl>= flfx>= bnfl>= flbn>= flfl>=
                exrt> rtex> exrt> rtex> flrt>= rtfl>= rtrt>=))
 
+  (define error@add1
+    (lambda (x)
+      (import (ikarus))
+      (cond
+        [(fixnum? x) (+ (greatest-fixnum) 1)]
+        [(number? x) (+ x 1)]
+        [else (die 'add1 "not a number" x)])))
+  
   (define add1
     (lambda (x)
+      (import (ikarus))
+      (add1 x)))
+
+  (define error@sub1
+    (lambda (x)
+      (import (ikarus))
       (cond
-        [(fixnum? x) 
+        [(fixnum? x) (- (least-fixnum) 1)]
-         (foreign-call "ikrt_fxfxplus" x 1)]
+        [(number? x) (- x 1)]
-        [(bignum? x)
+        [else (die 'sub1 "not a number" x)])))
-         (foreign-call "ikrt_fxbnplus" 1 x)]
-        [else (die 'add1 "not a number" x)])))
 
   (define sub1
     (lambda (x)
-      (cond
+      (import (ikarus))
-        [(fixnum? x) 
+      (sub1 x)))
-         (foreign-call "ikrt_fxfxplus" x -1)]
-        [(bignum? x)
-         (foreign-call "ikrt_fxbnplus" -1 x)]
-        [else (die 'sub1 "not a number" x)])))
 
   (define zero?
     (lambda (x)

scheme/last-revision

@@ -1 +1 @@
-1382
+1383

scheme/makefile.ss

@@ -567,6 +567,10 @@
     [error@fx+                                   ]
     [error@fx*                                   ]
     [error@fx-                                   ]
+    [error@add1                                  ]
+    [error@sub1                                  ]
+    [error@fxadd1                                ]
+    [error@fxsub1                                ]
     [fasl-write                                  i]
     [lambda                                      i r ba se ne]
     [and                                         i r ba se ne]

scheme/pass-specify-rep-primops.ss

@@ -1199,6 +1199,17 @@
   [(E) (nop)]
   [(E a . a*) (assert-fixnums a a*)])
 
+(define-primop add1 safe
+  [(V x) (cogen-value-+ x (K 1))])
+(define-primop sub1 safe
+  [(V x) (cogen-value-+ x (K -1))])
+
+(define-primop fxadd1 safe
+  [(V x) (cogen-value-+ x (K 1))])
+(define-primop fxsub1 safe
+  [(V x) (cogen-value-+ x (K -1))])
+
+
 (define-primop * safe
   [(V) (K (fxsll 1 fx-shift))]
   [(V a b) 

scheme/pass-specify-rep.ss

@@ -58,6 +58,10 @@
       [(fx+)          'error@fx+]
       [(fx-)          'error@fx-]
       [(fx*)          'error@fx*]
+      [(add1)         'error@add1]
+      [(sub1)         'error@sub1]
+      [(fxadd1)       'error@fxadd1]
+      [(fxsub1)       'error@fxsub1]
       [else                    x]))
   (define (make-interrupt-call op args)
     (make-funcall