* disabled gzipped fasl files. too slow :-(

bin/ikarus-fasl.c

@@ -19,7 +19,7 @@
 #define RTLD_DEFAULT 0
 #endif
 
-#define USE_ZLIB 1
+#define USE_ZLIB 0
 
 typedef struct {
 #if USE_ZLIB
@@ -473,6 +473,49 @@ static ikp do_read(ikpcb* pcb, fasl_port* p){
     }
     return x;
   }
+  else if(c == 'l'){
+    int len = (unsigned char) fasl_read_byte(p);
+    if(len < 0){
+      fprintf(stderr, "invalid len=%d\n", len);
+      exit(-1);
+    }
+    ikp pair = ik_alloc(pcb, pair_size * (len+1)) + pair_tag;
+    if(put_mark_index){
+      p->marks[put_mark_index] = pair;
+    }
+    int i; ikp pt = pair;
+    for(i=0; i<len; i++){
+      ref(pt, off_car) = do_read(pcb, p);
+      ref(pt, off_cdr) = pt + pair_size;
+      pt += pair_size;
+    }
+    ref(pt, off_car) = do_read(pcb, p);
+    ref(pt, off_cdr) = do_read(pcb, p);
+    return pair;
+  }
+  else if(c == 'L'){
+    int len;
+    fasl_read_buf(p, &len, sizeof(int));
+    if(len < 0){
+      fprintf(stderr, "invalid len=%d\n", len);
+      exit(-1);
+    }
+    ikp pair = ik_alloc(pcb, pair_size * (len+1)) + pair_tag;
+    if(put_mark_index){
+      p->marks[put_mark_index] = pair;
+    }
+    int i; ikp pt = pair;
+    for(i=0; i<len; i++){
+      ref(pt, off_car) = do_read(pcb, p);
+      ref(pt, off_cdr) = pt + pair_size;
+      pt += pair_size;
+    }
+    ref(pt, off_car) = do_read(pcb, p);
+    ref(pt, off_cdr) = do_read(pcb, p);
+    return pair;
+  }
+
+
   else {
     fprintf(stderr, "invalid type '%c' (0x%02x) found in fasl file\n", c, c);
     exit(-1);

src/ikarus.fasl.write.ss

@@ -3,6 +3,7 @@
   (export fasl-write)
   (import
     (ikarus system $codes)
+    (ikarus system $pairs)
     (ikarus system $records)
     (ikarus system $io)
     (ikarus system $bytevectors)
@@ -48,13 +49,42 @@
           (and ($char<= ($string-ref s i) ($fixnum->char 127))
                (f s ($fxadd1 i) n)))))
 
+  (define (count-unshared-cdrs x h n)
+    (cond
+      [(and (pair? x) (eq? (get-hash-table h x #f) 0))
+       (count-unshared-cdrs ($cdr x) h ($fxadd1 n))]
+      [else n]))
+
+  (define (write-pairs x p h m n)
+    (cond
+      [($fx= n 0) (fasl-write-object x p h m)]
+      [else 
+       (write-pairs (cdr x) p h 
+         (fasl-write-object (car x) p h m)
+         ($fxsub1 n))]))
+       
   (define do-write
     (lambda (x p h m)
       (cond
-        [(pair? x)   
-         (write-char #\P p)
-         (fasl-write-object (cdr x) p h
-           (fasl-write-object (car x) p h m))]
+        [(pair? x)
+         (let ([d ($cdr x)])
+           (let ([n (count-unshared-cdrs d h 0)])
+             (cond
+               [($fx= n 0)
+                (write-char #\P p)
+                (fasl-write-object d p h
+                  (fasl-write-object (car x) p h m))]
+               [else 
+                (cond
+                  [($fx<= n 255) 
+                   (write-char #\l p)
+                   (write-byte n p)]
+                  [else
+                   (write-char #\L p)
+                   (write-int n p)])
+                (write-pairs d p h 
+                  (fasl-write-object (car x) p h m)
+                  n)])))]
         [(vector? x)
          (write-char #\V p)
          (write-int (vector-length x) p)

src/makefile.ss

@@ -843,14 +843,14 @@
               [(assq x locs) => cdr]
               [else 
                (error 'bootstrap "no location for ~s" x)])))
-        (let ([p (open-output-file "ikarus.tmp" 'replace)])
+        (let ([p (open-output-file "ikarus.boot" 'replace)])
           (for-each 
             (lambda (x) (compile-core-expr-to-port x p))
             core*)
           (close-output-port p)))))
 
-(system "gzip -f ikarus.tmp")
-(system "mv ikarus.tmp.gz ikarus.boot")
+;(system "gzip -f ikarus.boot.uncompressed")
+;(system "mv ikarus.boot.uncompressed.gz ikarus.boot")
 
 (printf "Happy Happy Joy Joy\n")