fasl-write now writes different fasl objects depending on the

architecture bitness.

configure

@@ -5536,11 +5536,9 @@ cat >>confdefs.h <<_ACEOF
 _ACEOF
 
 
-if (test $ac_cv_sizeof_void_p != 4); then
+# if (test $ac_cv_sizeof_void_p != 4); then
-  { { echo "$as_me:$LINENO: error: Ikarus can only run in 32-bit mode." >&5
+#   AC_MSG_ERROR([Ikarus can only run in 32-bit mode.])
-echo "$as_me: error: Ikarus can only run in 32-bit mode." >&2;}
+# fi
-   { (exit 1); exit 1; }; }
-fi
 
 # Checks for libraries.
 { echo "$as_me:$LINENO: checking for library containing dlsym" >&5

configure.ac

@@ -29,9 +29,9 @@ case "$target_os" in
 
 
 AC_CHECK_SIZEOF(void *)
-if (test $ac_cv_sizeof_void_p != 4); then
+# if (test $ac_cv_sizeof_void_p != 4); then
-  AC_MSG_ERROR([Ikarus can only run in 32-bit mode.])
+#   AC_MSG_ERROR([Ikarus can only run in 32-bit mode.])
-fi
+# fi
 
 # Checks for libraries.
 AC_SEARCH_LIBS(dlsym, dl,, [AC_MSG_ERROR([Cannot find libdl])])

scheme/Makefile.am

@@ -31,10 +31,12 @@ revno = "$(shell sed 's/ .*//' ../.bzr/branch/last-revision 2>/dev/null)"
 last-revision: $(shell ls ../.bzr/branch/last-revision 2>/dev/null) 
 	echo $(revno) >$@
 
-ikarus.config.ss: Makefile last-revision
+ikarus.config.ss: Makefile last-revision ../config.h
 	echo '(define ikarus-version "$(PACKAGE_VERSION)")' >$@
 	echo '(define ikarus-revision "$(shell cat last-revision)")' >>$@
 	echo '(define ikarus-lib-dir "$(pkglibdir)")' >>$@
+	echo '(define wordsize $(shell grep SIZEOF_VOID_P ../config.h | sed "s/.*\(.\)/\1/g"))' >>$@
+
 
 CLEANFILES=$(nodist_pkglib_DATA) ikarus.config.ss
 MAINTAINERCLEANFILES=last-revision

scheme/Makefile.in

@@ -370,10 +370,11 @@ all: $(nodist_pkglib_DATA)
 last-revision: $(shell ls ../.bzr/branch/last-revision 2>/dev/null) 
 	echo $(revno) >$@
 
-ikarus.config.ss: Makefile last-revision
+ikarus.config.ss: Makefile last-revision ../config.h
 	echo '(define ikarus-version "$(PACKAGE_VERSION)")' >$@
 	echo '(define ikarus-revision "$(shell cat last-revision)")' >>$@
 	echo '(define ikarus-lib-dir "$(pkglibdir)")' >>$@
+	echo '(define wordsize $(shell grep SIZEOF_VOID_P ../config.h | sed "s/.*\(.\)/\1/g"))' >>$@
 
 ikarus.boot: $(EXTRA_DIST) ikarus.config.ss
 	../src/ikarus -b ./ikarus.boot.prebuilt --r6rs-script makefile.ss

scheme/ikarus.compiler.ss

@@ -25,8 +25,10 @@
     (only (ikarus system $codes) $code->closure)
     (only (ikarus system $structs) $struct-ref $struct/rtd?)
     (except (ikarus)
+        fasl-write
         compile-core-expr-to-port assembler-output
         current-primitive-locations eval-core)
+    (ikarus fasl write)
     (ikarus intel-assembler))
 
 
@@ -807,6 +809,7 @@
   (define (mk-seq e0 e1)  ;;; keep e1 seq-free.
     (cond
       [(and (primcall? e0) (eq? (primcall-op e0) 'void)) e1]
+      [(or (constant? e0) (primref? e0)) e1]
       [(seq? e1)
        (make-seq (make-seq e0 (seq-e0 e1)) (seq-e1 e1))]
       [else
@@ -1084,6 +1087,65 @@
                                   (list (make-constant v0) a1))))))
                     (make-funcall (make-primref op) rand*))))
          (giveup))]
+    [(-)
+     (or (and (>= (length rand*) 1)
+              (andmap 
+                (lambda (x) 
+                  (constant-value x number?))
+                rand*)
+              (begin 
+                (let ([r (apply - 
+                           (map (lambda (x)
+                                  (constant-value x 
+                                    (lambda (v) v)))
+                                rand*))])
+                  (let f ([rand* rand*])
+                    (cond
+                      [(null? rand*) (make-constant r)]
+                      [else
+                       (mk-seq (car rand*) (f (cdr rand*)))])))))
+         (giveup))]
+    [(+ *)
+     (or (and (>= (length rand*) 0)
+              (andmap 
+                (lambda (x) 
+                  (constant-value x number?))
+                rand*)
+              (begin 
+                (let ([r (apply 
+                           (case op
+                             [(+) +]
+                             [(*) *]
+                             [else (error 'ikarus "BUG: no prim" op)])
+                           (map (lambda (x)
+                                  (constant-value x 
+                                    (lambda (v) v)))
+                                rand*))])
+                  (let f ([rand* rand*])
+                    (cond
+                      [(null? rand*) (make-constant r)]
+                      [else
+                       (mk-seq (car rand*) (f (cdr rand*)))])))))
+         (giveup))]
+    [(expt)
+     (or (and (= (length rand*) 2)
+              (andmap 
+                (lambda (x) 
+                  (constant-value x 
+                    (lambda (v) (or (fixnum? v) (bignum? v)))))
+                rand*)
+              (begin 
+                (let ([r (apply expt 
+                           (map (lambda (x)
+                                  (constant-value x 
+                                    (lambda (v) v)))
+                                rand*))])
+                  (let f ([rand* rand*])
+                    (cond
+                      [(null? rand*) (make-constant r)]
+                      [else
+                       (mk-seq (car rand*) (f (cdr rand*)))])))))
+         (giveup))]
     ;X; [(fx- fx+ fx*)
     ;X;  (or (and (fx= (length rand*) 2)
     ;X;           (let ([a0 (car rand*)] [a1 (cadr rand*)])
@@ -1838,9 +1900,16 @@
        (make-codes (map CodeExpr list) (Tail body))]))
   (CodesExpr x))
 
+
 (begin ;;; DEFINITIONS
-  (define wordsize  4)
+  (module (wordsize)
-  (define wordshift 2)
+    (include "ikarus.config.ss"))
+  (define wordshift
+    (case wordsize
+      [(4) 2]
+      [(8) 3]
+      [else 
+       (error 'ikarus "wordsize is neither 4 nor 8" wordsize)])) 
   (define object-alignment (* 2 wordsize))
   (define align-shift (+ wordshift 1))
   (define fx-shift  wordshift)

scheme/ikarus.fasl.write.ss

@@ -29,7 +29,33 @@
     (ikarus system $bignums)
     (except (ikarus code-objects) procedure-annotation)
     (except (ikarus) fasl-write write-byte))
-  
+ 
+  (module (wordsize)
+    (include "ikarus.config.ss"))
+
+  (define-syntax fxshift 
+    (identifier-syntax
+      (case wordsize
+        [(4) 2]
+        [(8) 3]
+        [else (error 'fxshift "invalid wordsize" wordsize)])))
+
+  (define-syntax intbits (identifier-syntax (* wordsize 8)))
+
+  (define-syntax fxbits (identifier-syntax (- intbits fxshift)))
+
+  (define (fx? x)
+    (and (or (fixnum? x) (bignum? x)) 
+         (<= (- (expt 2 (- fxbits 1)))
+             x
+             (- (expt 2 (- fxbits 1)) 1))))
+ 
+  (define (int? x) 
+    (and (or (fixnum? x) (bignum? x)) 
+         (<= (- (expt 2 (- intbits 1))) 
+             x
+             (- (expt 2 (- intbits 1)) 1))))
+
   (define-syntax write-byte
     (syntax-rules ()
       [(_ byte port)
@@ -38,27 +64,26 @@
   (define (put-tag c p)
     (write-byte (char->integer c) p))
   
-  (define write-fixnum 
-    (lambda (x p)
-      (unless (fixnum? x) (die 'write-fixnum "not a fixnum" x))
-      (write-byte (fxsll (fxlogand x #x3F) 2) p)
-      (write-byte (fxlogand (fxsra x 6) #xFF) p)
-      (write-byte (fxlogand (fxsra x 14) #xFF) p)
-      (write-byte (fxlogand (fxsra x 22) #xFF) p)))
   (define write-int 
     (lambda (x p)
-      (unless (fixnum? x) (die 'write-int "not a fixnum" x))
+      (unless (int? x) (die 'write-int "not a int" x))
-      (write-byte (fxlogand x #xFF) p)
+      (write-byte (bitwise-and x #xFF) p)
-      (write-byte (fxlogand (fxsra x 8) #xFF) p)
+      (write-byte (bitwise-and (sra x 8) #xFF) p)
-      (write-byte (fxlogand (fxsra x 16) #xFF) p)
+      (write-byte (bitwise-and (sra x 16) #xFF) p)
-      (write-byte (fxlogand (fxsra x 24) #xFF) p)))
+      (write-byte (bitwise-and (sra x 24) #xFF) p)
+      (when (eqv? wordsize 8)
+        (write-byte (bitwise-and (sra x 32) #xFF) p)
+        (write-byte (bitwise-and (sra x 40) #xFF) p)
+        (write-byte (bitwise-and (sra x 48) #xFF) p)
+        (write-byte (bitwise-and (sra x 56) #xFF) p))))
+
   (define fasl-write-immediate
     (lambda (x p)
       (cond
         [(null? x) (put-tag #\N p)]
-        [(fixnum? x) 
+        [(fx? x)
          (put-tag #\I p)
-         (write-fixnum x p)]
+         (write-int (bitwise-arithmetic-shift-left x fxshift) p)]
         [(char? x)
          (let ([n ($char->fixnum x)])
            (if ($fx<= n 255)
@@ -152,7 +177,10 @@
         [(code? x)
          (put-tag #\x p)
          (write-int (code-size x) p)
-         (write-fixnum (code-freevars x) p)
+         (write-int (bitwise-arithmetic-shift-left
+                      (code-freevars x)
+                      fxshift)
+                    p)
          (let ([m (fasl-write-object ($code-annotation x) p h m)])
            (let f ([i 0] [n (code-size x)])
              (unless (fx= i n)
@@ -315,7 +343,7 @@
          (put-tag #\I port)
          (put-tag #\K port)
          (put-tag #\0 port)
-         (put-tag #\1 port)
+         (put-tag (if (= wordsize 4) #\1 #\2) port)
          (fasl-write-object x port h 1)
          (void))))
   (define fasl-write

scheme/ikarus.intel-assembler.ss

@@ -136,7 +136,7 @@
 
 (define-syntax byte
   (syntax-rules ()
-    [(_ x) (fxlogand x 255)]))
+    [(_ x) (bitwise-and x 255)]))
 
 
 (define word
@@ -194,17 +194,17 @@
        (if (fixnum? n)
            (cons* 
              (byte n)
-             (byte (fxsra n 8))
+             (byte (sra n 8))
-             (byte (fxsra n 16))
+             (byte (sra n 16))
-             (byte (fxsra n 24))
+             (byte (sra n 24))
              ac)
            (let* ([lo (remainder n 256)]
                   [hi (quotient (if (< n 0) (- n 255) n) 256)])
              (cons* 
                (byte lo)
                (byte hi)
-               (byte (fxsra hi 8))
+               (byte (sra hi 8))
-               (byte (fxsra hi 16))
+               (byte (sra hi 16))
                ac)))]
       [(obj? n)
        (let ([v (cadr n)])
@@ -218,7 +218,7 @@
        (cons (cons 'label-addr (label-name n)) ac)]
       [(foreign? n)
        (cons (cons 'foreign-label (label-name n)) ac)]
-      [(label? n) 
+      [(label? n)
        (cons (cons 'relative (label-name n)) ac)]
       [else (die 'IMM32 "invalid" n)])))
 
@@ -291,7 +291,7 @@
       [else 
        (cons*
          (byte (fxlogor 4 (fxsll (register-index r1) 3)))
-         (byte (fxlogor (register-index r2) 
+         (byte (fxlogor (register-index r2)
                         (fxsll (register-index r3) 3)))
          ac)])))
 

scheme/last-revision

@@ -1 +1 @@
-1314
+1315