* completed the move to new specify-representation pass infrastructure.

benchmarks/src/gcold.scm

@@ -303,7 +303,7 @@
     (define (oldGenMut n)
       (do ((i 0 (+ i 1)))
 	  ((>= i (quotient n 2)))
-	(oldGenSwapSubTrees)))
+	(oldGenSwapSubtrees)))
 
     ; Does the amount of mutator work appropriate for n bytes of young-gen
     ; garbage allocation.

benchmarks/src/simplex.scm

@@ -10,6 +10,7 @@
 
 (define (simplex a m1 m2 m3)
  (define *epsilon* 1e-6)
+ ;(define *epsilon* 0.000001)
  (if (not (and (>= m1 0)
                (>= m2 0)
                (>= m3 0)

benchmarks/src/smlboyer.scm

@@ -199,8 +199,8 @@
 (define (CProp.terms x) (cadr x))
 
 (define (cterm_to_term x)
-  (if (Cvar? x)
-      (Var (Cvar.i x))
+  (if (CVar? x)
+      (Var (CVar.i x))
       (Prop (get (CProp.name x))
             (map cterm_to_term (CProp.terms x)))))
 

bin/ikarus-numerics.c

@@ -708,12 +708,12 @@ ikrt_bnbnminus(ikp x, ikp y, ikpcb* pcb){
             ref(x, -vector_tag+disp_bignum_data+(xlimbs-1)*wordsize))){
           s1 = y; n1 = ylimbs;
           s2 = x; n2 = xlimbs;
-          result_sign = (1 << bignum_length_shift) - ysign;
+          result_sign = (1 << bignum_sign_shift) - ysign;
         }
       } else {
         s1 = y; n1 = ylimbs;
         s2 = x; n2 = xlimbs;
-        result_sign = (1 << bignum_length_shift) - ysign;
+        result_sign = (1 << bignum_sign_shift) - ysign;
       }
     }
     /* |s1| > |s2| */

src/libcore.ss

@@ -317,18 +317,14 @@ reference-implementation:
            (and s #t)))))
 
 
-;;; OLD (primitive-set! 'top-level-value
-;;; OLD   (lambda (x)
-;;; OLD     (unless (symbol? x)
-;;; OLD       (error 'top-level-value "~s is not a symbol" x))
-;;; OLD     (let ([v ($symbol-value x)])
-;;; OLD       (when ($unbound-object? v)
-;;; OLD         (error 'top-level-value "unbound variable ~s" x))
-;;; OLD       v)))
-
 (primitive-set! 'top-level-value
   (lambda (x)
-    (top-level-value x)))
+    (unless (symbol? x)
+      (error 'top-level-value "~s is not a symbol" x))
+    (let ([v ($symbol-value x)])
+      (when ($unbound-object? v)
+        (error 'top-level-value "unbound variable ~s" x))
+      v)))
 
 (primitive-set! 'top-level-bound?
   (lambda (x)
@@ -1861,4 +1857,3 @@ reference-implementation:
        (convert-sign x ($string-length x))]
       [else (error 'string->number "~s is not a string" x)])))
 
-#!eof

src/libnumerics.ss

@@ -240,6 +240,12 @@
          (cond
            [(flonum? y)
             (foreign-call "ikrt_fl_div" (fixnum->flonum x) y)]
+           [(fixnum? y) 
+            (let ([q (fxquotient x y)]
+                  [r (fxremainder x y)])
+              (if (fxzero? r)
+                  q
+                  (error '/ "no ratnum for ~s/~s" x y)))]
            [else (error '/ "unsupported ~s ~s" x y)])]
         [else (error '/ "unsupported ~s ~s" x y)])))
 
@@ -345,8 +351,13 @@
         [(flonum? x) #f]
         [else (error 'rational? "~s is not a number" x)])))
 
-  (define integer?
-    (lambda (x) (number? x)))
+  (define integer? 
+    (lambda (x) 
+      (cond
+        [(fixnum? x) #t]
+        [(bignum? x) #t]
+        [(flonum? x) (error 'integer "dunno for ~s" x)]
+        [else #f])))
 
   (define exact?
     (lambda (x) 
@@ -706,7 +717,12 @@
       (cond
         [(fixnum? x) (eq? x 0)]
         [(bignum? x) #f]
-        [else (error 'zero? "~s is not a number" x)])))
+        [(flonum? x) (= x (exact->inexact 0))]
+        [else (error 'zero? "tag=~s / ~s  is not a number" 
+                     (#%$fxlogand 255 
+                      (#%$fxsll x 2))
+                     (#%$fxlogand x -1)
+                     )])))
 
   (primitive-set! 'expt
     (lambda (n m)

src/libtokenizer.ss

@@ -794,7 +794,6 @@
           (unless (eof-object? x)
             (eval x)
             (read-and-eval p eval)))))
-
     (primitive-set! 'load
       (case-lambda
         [(x) (load x eval)]

src/pass-specify-rep-primops.ss

@@ -89,6 +89,10 @@
   [(P x) (prm '= (T x) (K nil))]
   [(E x) (nop)])
 
+(define-primop not safe
+  [(P x) (prm '= (T x) (K bool-f))]
+  [(E x) (nop)])
+
 (define-primop eof-object safe
   [(V) (K eof)]
   [(P) (K #t)]
@@ -132,6 +136,43 @@
   [(P) (K #t)]
   [(E) (nop)])
 
+(define-primop $memq safe
+  [(P x ls)
+   (record-case ls
+     [(constant ls)
+      (cond
+        [(not (list? ls)) (interrupt)]
+        [else
+         (with-tmp ([x (T x)])
+           (let f ([ls ls])
+             (cond
+               [(null? ls) (K #f)]
+               [(null? (cdr ls)) (prm '= x (T (K (car ls))))]
+               [else
+                (make-conditional 
+                  (prm '= x (T (K (car ls))))
+                  (K #t)
+                  (f (cdr ls)))])))])]
+     [else (interrupt)])]
+  [(V x ls)
+   (record-case ls
+     [(constant ls)
+      (cond
+        [(not (list? ls)) (interrupt)]
+        [else
+         (with-tmp ([x (T x)])
+           (let f ([ls ls])
+             (cond
+               [(null? ls) (K bool-f)]
+               [else
+                (make-conditional 
+                  (prm '= x (T (K (car ls))))
+                  (T (K ls))
+                  (f (cdr ls)))])))])]
+     [else (interrupt)])]
+  [(E x ls) (nop)])
+
+
 /section)
 
 (section ;;; pairs 
@@ -344,7 +385,7 @@
          (prm 'int+ (T x) (T i))
          (- disp-vector-data vector-tag))])])
 
-#;(define-primop vector-set! safe
+(define-primop vector-set! safe
   [(E x i v)
    (seq*
      (vector-range-check x i)
@@ -478,6 +519,15 @@
         (with-tmp ([v (cogen-value-$symbol-value x)])
           (interrupt-when (cogen-pred-$unbound-object? v))))])])
 
+
+(define-primop $init-symbol-function! unsafe
+  [(E x v)
+   (with-tmp ([x (T x)] [v (T v)])
+     (prm 'mset x (K (- disp-symbol-function symbol-tag)) v)
+     (prm 'mset x (K (- disp-symbol-error-function symbol-tag)) v)
+     (dirty-vector-set x))])
+
+
 /section)
 
 (section ;;; fixnums
@@ -619,12 +669,20 @@
 (define (or* a a*)
   (cond
     [(null? a*) a]
+    [(constant? (car a*)) (or* a (cdr a*))]
     [else (or* (prm 'logor a (T (car a*))) (cdr a*))]))
 
 (define (assert-fixnums a a*)
-  (interrupt-unless (tag-test (or* (T a) a*) fixnum-mask fixnum-tag)))
+  (cond
+    [(constant? a) 
+     (if (null? a*) 
+         (nop)
+         (assert-fixnums (car a*) (cdr a*)))]
+    [else
+     (interrupt-unless 
+       (tag-test (or* (T a) a*) fixnum-mask fixnum-tag))]))
 
-(define (fold-p op a a*)
+(define (fixnum-fold-p op a a*)
   (cond
     [(or (non-fixnum? a) (ormap non-fixnum? a*)) (interrupt)]
     [else
@@ -640,40 +698,40 @@
                 (f b (cdr a*))
                 (K #f)))])))]))
 
-(define (fold-e a a*)
+(define (fixnum-fold-e a a*)
   (cond
     [(or (non-fixnum? a) (ormap non-fixnum? a*)) (interrupt)]
     [else (assert-fixnums a a*)]))
 
 (define-primop = safe
   [(P) (interrupt)]
-  [(P a . a*) (fold-p '= a a*)]
+  [(P a . a*) (fixnum-fold-p '= a a*)]
   [(E) (interrupt)]
-  [(E a . a*) (fold-e a a*)])
+  [(E a . a*) (fixnum-fold-e a a*)])
 
 (define-primop < safe
   [(P) (interrupt)]
-  [(P a . a*) (fold-p '< a a*)]
+  [(P a . a*) (fixnum-fold-p '< a a*)]
   [(E) (interrupt)]
-  [(E a . a*) (fold-e a a*)])
+  [(E a . a*) (fixnum-fold-e a a*)])
 
 (define-primop <= safe
   [(P) (interrupt)]
-  [(P a . a*) (fold-p '<= a a*)]
+  [(P a . a*) (fixnum-fold-p '<= a a*)]
   [(E) (interrupt)]
-  [(E a . a*) (fold-e a a*)])
+  [(E a . a*) (fixnum-fold-e a a*)])
 
 (define-primop > safe
   [(P) (interrupt)]
-  [(P a . a*) (fold-p '> a a*)]
+  [(P a . a*) (fixnum-fold-p '> a a*)]
   [(E) (interrupt)]
-  [(E a . a*) (fold-e a a*)])
+  [(E a . a*) (fixnum-fold-e a a*)])
 
 (define-primop >= safe
   [(P) (interrupt)]
-  [(P a . a*) (fold-p '>= a a*)]
+  [(P a . a*) (fixnum-fold-p '>= a a*)]
   [(E) (interrupt)]
-  [(E a . a*) (fold-e a a*)])
+  [(E a . a*) (fixnum-fold-e a a*)])
 
 (define-primop - safe
   [(V a) 
@@ -715,6 +773,12 @@
   [(E) (nop)]
   [(E a . a*) (assert-fixnums a a*)])
 
+(define-primop zero? safe
+  [(P x)
+   (seq*
+     (interrupt-unless (cogen-pred-fixnum? x))
+     (cogen-pred-$fxzero? x))]
+  [(E x) (interrupt-unless (cogen-pred-fixnum? x))])
 
 /section)
 
@@ -724,7 +788,7 @@
   [(P x) (sec-tag-test (T x) vector-mask vector-tag vector-mask vector-tag)]
   [(E x) (nop)])
 
-#;(define-primop $record/rtd? unsafe
+(define-primop $record/rtd? unsafe
   [(P x rtd)
    (make-conditional
      (tag-test (T x) vector-mask vector-tag)
@@ -762,9 +826,13 @@
   [(P x i) (cogen-pred-$vector-ref x i)])
 
 (define-primop $record-set! unsafe
-  [(V x i v) (cogen-value-$vector-set! x i v)]
+  [(V x i v) 
+   (seq* (cogen-effect-$vector-set! x i v) 
+         (K void-object))]
   [(E x i v) (cogen-effect-$vector-set! x i v)]
-  [(P x i v) (cogen-pred-$vector-set! x i v)])
+  [(P x i v) 
+   (seq* (cogen-effect-$vector-set! x i v)
+         (K #t))])
 
 (define-primop $record unsafe
   [(V rtd . v*)
@@ -826,6 +894,72 @@
   [(P x) (K #t)]
   [(E x) (nop)])
 
+(define (non-char? x)
+  (record-case x
+    [(constant i) (not (char? i))]
+    [else #f]))
+
+(define (assert-chars a a*)
+  (cond
+    [(constant? a) 
+     (if (null? a*) 
+         (nop)
+         (assert-chars (car a*) (cdr a*)))]
+    [else
+     (interrupt-unless 
+       (tag-test (or* (T a) a*) char-mask char-tag))]))
+
+(define (char-fold-p op a a*)
+  (cond
+    [(or (non-char? a) (ormap non-char? a*)) (interrupt)]
+    [else
+     (seq*
+       (assert-chars a a*)
+       (let f ([a a] [a* a*])
+         (cond
+           [(null? a*) (K #t)]
+           [else
+            (let ([b (car a*)])
+              (make-conditional
+                (prm op (T a) (T b))
+                (f b (cdr a*))
+                (K #f)))])))]))
+
+(define (char-fold-e a a*)
+  (cond
+    [(or (non-char? a) (ormap non-char? a*)) (interrupt)]
+    [else (assert-chars a a*)]))
+
+(define-primop char=? safe
+  [(P) (interrupt)]
+  [(P a . a*) (char-fold-p '= a a*)]
+  [(E) (interrupt)]
+  [(E a . a*) (char-fold-e a a*)])
+
+(define-primop char<? safe
+  [(P) (interrupt)]
+  [(P a . a*) (char-fold-p '< a a*)]
+  [(E) (interrupt)]
+  [(E a . a*) (char-fold-e a a*)])
+
+(define-primop char<=? safe
+  [(P) (interrupt)]
+  [(P a . a*) (char-fold-p '<= a a*)]
+  [(E) (interrupt)]
+  [(E a . a*) (char-fold-e a a*)])
+
+(define-primop char>? safe
+  [(P) (interrupt)]
+  [(P a . a*) (char-fold-p '> a a*)]
+  [(E) (interrupt)]
+  [(E a . a*) (char-fold-e a a*)])
+
+(define-primop char>=? safe
+  [(P) (interrupt)]
+  [(P a . a*) (char-fold-p '>= a a*)]
+  [(E) (interrupt)]
+  [(E a . a*) (char-fold-e a a*)])
+
 /section)
 
 (section ;;; strings
@@ -1192,21 +1326,7 @@
 #!eof
 
 
-         [($init-symbol-function!)
-          (tbind ([x (Value (car arg*))] [v (Value (cadr arg*))])
-            (seq*
-              (prm 'mset x (K (- disp-symbol-function symbol-tag)) v)
-              (prm 'mset x (K (- disp-symbol-error-function symbol-tag)) v)
-              (dirty-vector-set x)))]
 
-         [(zero?) 
-          (tbind ([x (Value (car arg*))])
-            (make-conditional
-              (tag-test x fixnum-mask fixnum-tag)
-              (prm '= x (K 0))
-              (prm '!=
-                   (make-funcall (Value (make-primref 'zero?)) (list x))
-                   (Value (K #f)))))]
          [($procedure-check)
           (tbind ([x (Value (car arg*))])
             (make-shortcut

src/pass-specify-rep.ss

@@ -17,7 +17,7 @@
   (define fixnum-tag 0)
   (define fixnum-mask 3))
 
-(module (specify-representation)
+(module (specify-representation primop?)
   (import object-representation)
   (define cookie (gensym))
   (define (primop? x)
@@ -34,7 +34,8 @@
       [(not (PH-interruptable? p))
        (parameterize ([interrupt-handler 
                        (lambda ()
-                         (error 'cogen "~s is uninterruptable" x))])
+                         (error 'cogen "~s ~s is uninterruptable in ~s" 
+                                x args ctxt))])
           (k))]
       [else
        (let ([interrupted? #f])
@@ -44,14 +45,28 @@
                    (k))])
            (cond
              [(not interrupted?) body]
-             [(or (eq? ctxt 'V) (eq? ctxt 'E))
-              (make-shortcut body 
-                (make-funcall (V (K x)) args))]
+             [(eq? ctxt 'V)
+              (let ([h (make-funcall (V (make-primref x)) args)])
+                (if (record-case body
+                      [(primcall op) (eq? op 'interrupt)]
+                      [else #f])
+                     h
+                     (make-shortcut body h)))]
+             [(eq? ctxt 'E)
+              (let ([h (make-funcall (V (make-primref x)) args)])
+                (if (record-case body
+                      [(primcall op) (eq? op 'interrupt)]
+                      [else #f])
+                     h
+                     (make-shortcut body h)))]
              [(eq? ctxt 'P)
-              (make-shortcut body
-                (prm '!=
-                     (make-funcall (V (K x)) args) 
-                     (K bool-f)))]
+              (let ([h (prm '!= (make-funcall (V (make-primref x)) args)
+                            (K bool-f))])
+                (if (record-case body
+                      [(primcall op) (eq? op 'interrupt)]
+                      [else #f])
+                     h
+                     (make-shortcut body h)))]
              [else (error 'with-interrupt-handler "invalid context ~s" ctxt)])))]))
   (define-syntax with-tmp
     (lambda (x)
@@ -141,8 +156,7 @@
                        (with-tmp ([t (apply (PH-v-handler p) args)])
                          (prm 'nop))]
                       [else (error 'cogen-primop "~s is not handled" x)])]
-                   [else (error 'cogen-primop "invalid context ~s"
-                                ctxt)]))))))]
+                   [else (error 'cogen-primop "invalid context ~s" ctxt)]))))))]
       [else (error 'cogen-primop "~s is not a prim" x)]))
   
   (define-syntax define-primop
@@ -315,7 +329,10 @@
 
   (define (P x)
     (record-case x
-      [(constant) x]
+      [(constant c) (if c (K #t) (K #f))]
+      [(primref)  (K #t)]
+      [(code-loc) (K #t)]
+      [(closure)  (K #t)]
       [(bind lhs* rhs* body)
        (make-bind lhs* (map V rhs*) (P body))]
       [(conditional e0 e1 e2) 
@@ -326,10 +343,19 @@
        (handle-fix lhs* rhs* (P body))]
       [(primcall op arg*)
        (cogen-primop op 'P arg*)]
+      [(var)     (prm '!= (V x) (V (K #f)))]
+      [(funcall) (prm '!= (V x) (V (K #f)))]
+      [(jmpcall) (prm '!= (V x) (V (K #f)))]
+      [(forcall) (prm '!= (V x) (V (K #f)))]
       [else (error 'cogen-P "invalid pred expr ~s" x)])) 
   
   (define (E x)
     (record-case x
+      [(constant) (nop)]
+      [(var)      (nop)]
+      [(primref)  (nop)]
+      [(code-loc) (nop)]
+      [(closure)  (nop)]
       [(bind lhs* rhs* body)
        (make-bind lhs* (map V rhs*) (E body))]
       [(conditional e0 e1 e2) 
@@ -468,7 +494,8 @@
       [else (error 'specify-rep "invalid program ~s" x)]))
 
   (define (specify-representation x)
-    (Program x))
+    (let ([x (Program x)])
+      x))