* Open-coded fxadd1 and fxsub1.

lib/libcompile.ss

@@ -1097,6 +1097,22 @@
                     (giveup))))
          (error 'optimize "incorrect args ~s to ~s"
                 (map unparse rand*) op))]
+    [(fxadd1 fxsub1)
+     (or (and (fx= (length rand*) 1)
+              (let ([a (car rand*)])
+                (or (constant-value a
+                      (lambda (v)
+                        (and (fixnum? v)
+                             (let ([t 
+                                    (case op
+                                      [(fxadd1) (add1 v)]
+                                      [else     (sub1 v)])])
+                                (and (fixnum? t)
+                                     (mk-seq a 
+                                       (make-constant t)))))))
+                    (make-primcall op rand*))))
+         (giveup))]
+                                  
     ;;; unoptimizables
     [(error syntax-error $syntax-dispatch $sc-put-cte 
       primitive-set!  apply) 
@@ -2025,7 +2041,7 @@
       [(seq e0 e1) (make-seq (Expr e0) (Expr e1))]
       [(primcall op arg*)
        (cond
-         [(memq op '(not car cdr))
+         [(memq op '(not car cdr fxadd1 fxsub1)) ;;; SIMPLIFY
           (make-primcall op (map Expr arg*))]
          [else
           (simplify* arg* '() '()
@@ -2785,6 +2801,7 @@
   (define (jl label) (list 'jl label))
   (define (jb label) (list 'jb label))
   (define (ja label) (list 'ja label))
+  (define (jo label) (list 'jo label))
   (define (jmp label) (list 'jmp label))
   (define edi '%edx) ; closure pointer
   (define esi '%esi) ; pcb
@@ -3156,6 +3173,22 @@
        (list* (movl (Simple (car arg*)) eax)
               (addl (constant-val 1) eax)
               ac)]
+      [(fxadd1)
+       (NonTail (car arg*)
+         (list* (movl eax ebx)
+                (andl (int fx-mask) ebx)
+                (jne (label SL_fxadd1_error))
+                (addl (int (fxsll 1 fx-shift)) eax)
+                (jo (label SL_fxadd1_error))
+                ac))]
+      [(fxsub1)
+       (NonTail (car arg*)
+         (list* (movl eax ebx)
+                (andl (int fx-mask) ebx)
+                (jne (label SL_fxsub1_error))
+                (subl (int (fxsll 1 fx-shift)) eax)
+                (jo (label SL_fxsub1_error))
+                ac))] 
       [($fxsub1) 
        (list* (movl (Simple (car arg*)) eax)
               (addl (constant-val -1) eax)
@@ -4326,6 +4359,8 @@
            (map CodeExpr list))]))
 
 (begin ;;; ASSEMBLY HELPERS
+  (define SL_fxadd1_error (gensym "SL_fxadd1_error"))
+  (define SL_fxsub1_error (gensym "SL_fxsub1_error"))
   (define SL_nonprocedure (gensym "SL_nonprocedure"))
   (define SL_top_level_value_error (gensym "SL_top_level_value_error"))
   (define SL_car_error (gensym "SL_car_error"))
@@ -4344,6 +4379,18 @@
   (module ()
     (list*->code* (lambda (x) #f)
       (list
+        (list 0
+              (label SL_fxadd1_error)
+              (movl eax (mem (fx- 0 wordsize) fpr))
+              (movl (primref-loc 'fxadd1-error) cpr)
+              (movl (int (argc-convention 1)) eax)
+              (tail-indirect-cpr-call))
+        (list 0
+              (label SL_fxsub1_error)
+              (movl eax (mem (fx- 0 wordsize) fpr))
+              (movl (primref-loc 'fxsub1-error) cpr)
+              (movl (int (argc-convention 1)) eax)
+              (tail-indirect-cpr-call)) 
         (list 0
               (label SL_car_error)
               (movl ebx (mem (fx- 0 wordsize) fpr))

lib/libcore.ss

@@ -30,15 +30,11 @@
 
 (primitive-set! 'fxadd1
   (lambda (n)
-    (unless (fixnum? n)
-      (error 'fxadd1 "~s is not a fixnum" n))
-    ($fxadd1 n)))
+    (fxadd1 n)))
   
 (primitive-set! 'fxsub1 
   (lambda (n) 
-    (unless (fixnum? n)
-      (error 'fxsub1 "~s is not a fixnum" n))
-    ($fxsub1 n)))
+    (fxsub1 n)))
   
 (primitive-set! 'integer->char
   (lambda (n)

lib/libhandlers.ss

@@ -43,3 +43,15 @@
   (lambda (x)
     (error 'cdr "~s is not a pair" x)))
 
+(primitive-set! 'fxadd1-error
+  (lambda (x)
+    (if (fixnum? x)
+        (error 'fxadd1 "overflow")
+        (error 'fxadd1 "~s is not a fixnum" x))))
+
+(primitive-set! 'fxsub1-error
+  (lambda (x)
+    (if (fixnum? x)
+        (error 'fxsub1 "underflow")
+        (error 'fxsub1 "~s is not a fixnum" x))))
+

lib/libintelasm.ss

@@ -673,6 +673,7 @@
    [(jnl dst)  (conditional-jump #x8D dst ac)]
    [(jnle dst) (conditional-jump #x8F dst ac)]
    [(jne dst)  (conditional-jump #x85 dst ac)]
+   [(jo dst)   (conditional-jump #x80 dst ac)]
    [(byte x)
     (unless (byte? x) (error who "~s is not a byte" x))
     (cons (byte x) ac)]