imported compiler3

src/Makefile

@@ -2,7 +2,7 @@
 all: ikarus.fasl
 
 ikarus.fasl: 
-	echo '(load "compiler-6.1.ss")' | petite
+	echo '(load "compiler-6.2.ss")' | petite
 
 clean:
 	rm -f *.fasl

src/build-date.tmp

@@ -1 +1 @@
-2006-07-28
+2006-08-02

src/compiler-6.1.ss

@@ -61,7 +61,7 @@
 (define scheme-library-files
   '(["libhandlers-6.0.ss"    "libhandlers.fasl"]
     ["libcontrol-6.1.ss"     "libcontrol.fasl"]
-    ["libcollect-6.0.ss"     "libcollect.fasl"]
+    ["libcollect-6.1.ss"     "libcollect.fasl"]
     ["librecord-6.1.ss"      "librecord.fasl"]
     ["libcxr-6.0.ss"         "libcxr.fasl"]
     ["libcore-6.1.ss"        "libcore.fasl"]

src/libassembler-compat-6.0.ss

@@ -7,7 +7,7 @@
       (let ([code-size (fxsll (fxsra (fx+ code-size 3) 2) 2)]) 
         (make-code 
           closure-size
-          (make-string code-size)
+          (make-string code-size (integer->char 0))
           (make-vector (fxsra reloc-size 2)))))))
 
 (define set-code-byte! 

src/libcollect-6.1.ss

@@ -0,0 +1,36 @@
+
+;(primitive-set! 'do-overflow
+;  (lambda ()
+;    ($do-overflow 4096)))
+
+(primitive-set! 'do-overflow
+  (lambda (n)
+    (foreign-call "ik_collect" n)
+    (void)))
+
+(primitive-set! 'do-overflow-words
+  (lambda (n)
+    (foreign-call "ik_collect" ($fxsll n 2))
+    (void)))
+
+(primitive-set! 'do-vararg-overflow
+  (lambda (n)
+    (foreign-call "ik_collect_vararg" n)
+    (void)))
+
+(primitive-set! 'collect
+  (lambda ()
+    (do-overflow 4096)))
+
+(primitive-set! 'do-stack-overflow
+  (lambda ()
+    (foreign-call "ik_stack_overflow")))
+
+(primitive-set! 'dump-metatable
+  (lambda ()
+    (foreign-call "ik_dump_metatable")))
+
+(primitive-set! 'dump-dirty-vector
+  (lambda ()
+    (foreign-call "ik_dump_dirty_vector")))
+

src/libfasl-6.0.ss

@@ -189,15 +189,8 @@
                         [else (error 'fasl-write "unrecognized reloc ~s" b)]
                         )))))]
              [else (error 'fasl-write "~s is not fasl-writable" x)])]))))
-  (primitive-set! 'fasl-write
+  (define do-fasl-write 
-     (lambda (x . rest)
+    (lambda (x port)
-       (let ([port 
-              (if (null? rest)
-                  (current-output-port)
-                  (let ([a (car rest)])
-                    (unless (output-port? a)
-                      (error 'fasl-write "~s is not an output port" a))
-                    a))])
       (let ([h (make-hash-table)])
          (make-graph x h)
          (write-char #\# port)
@@ -206,5 +199,12 @@
          (write-char #\K port)
          (write-char #\0 port)
          (write-char #\1 port)
-           (fasl-write x port h 1))))))
+         (fasl-write x port h 1))))
+  (primitive-set! 'fasl-write
+     (case-lambda 
+       [(x) (do-fasl-write x (current-output-port))]
+       [(x port)
+        (unless (output-port? port)
+          (error 'fasl-write "~s is not an output port" port))
+        (do-fasl-write x port)])))
 

src/libhash-6.2.ss

@@ -0,0 +1,200 @@
+
+(let ([hash-rtd (make-record-type '"hash-table" '(hash-vec count tc))])
+  ;;; accessors
+  (define get-vec (record-field-accessor hash-rtd 0))
+  (define set-vec! (record-field-mutator hash-rtd 0))
+  (define get-count (record-field-accessor hash-rtd 1))
+  (define set-count! (record-field-mutator hash-rtd 1))
+  (define get-tc (record-field-accessor hash-rtd 2))
+  ;;; implementation
+
+  ;;; directly from Dybvig's
+  (define tc-pop
+    (lambda (tc)
+      (let ([x ($car tc)])
+        (if (eq? x ($cdr tc))
+            #f
+            (let ([v ($car x)])
+              ($set-car! tc ($cdr x))
+              ($set-car! x #f)
+              ($set-cdr! x #f)
+              v)))))
+
+  (define inthash
+    (lambda (key)
+      ;static int inthash(int key) {
+      ;  key += ~(key << 15);
+      ;  key ^=  (key >> 10);
+      ;  key +=  (key << 3);
+      ;  key ^=  (key >> 6);
+      ;  key += ~(key << 11);
+      ;  key ^=  (key >> 16);
+      ;  return key;
+      ;}
+      (let* ([key ($fx+ key ($fxlognot ($fxsll key 15)))]
+             [key ($fxlogxor key ($fxsra key 10))]
+             [key ($fx+ key ($fxsll key 3))]
+             [key ($fxlogxor key ($fxsra key 6))]
+             [key ($fx+ key ($fxlognot ($fxsll key 11)))]
+             [key ($fxlogxor key ($fxsra key 16))])
+        key)))
+
+  ;;; assq-like lookup
+  (define direct-lookup 
+    (lambda (x b)
+      (if (fixnum? b)
+          #f
+          (if (eq? x ($tcbucket-key b))
+              b
+              (direct-lookup x ($tcbucket-next b))))))
+
+  (define rehash-lookup
+    (lambda (h tc x)
+      (cond
+        [(tc-pop tc) =>
+         (lambda (b)
+           (re-add! h b)
+           (if (eq? x ($tcbucket-key b))
+               b
+               (rehash-lookup h tc x)))]
+        [else #f])))
+
+  (define get-bucket-index
+    (lambda (b)
+      (let ([next ($tcbucket-next b)])
+        (if (fixnum? next)
+            next
+            (get-bucket-index next)))))
+
+  (define replace!
+    (lambda (lb x y)
+      (let ([n ($tcbucket-next lb)])
+        (cond
+          [(eq? n x) 
+           ($set-tcbucket-next! lb y)
+           (void)]
+          [else
+           (replace! n x y)]))))
+
+  (define re-add! 
+    (lambda (h b)
+      (let ([vec (get-vec h)]
+            [next ($tcbucket-next b)])
+        ;;; first remove it from its old place
+        (let ([idx 
+               (if (fixnum? next)
+                   next
+                   (get-bucket-index next))])
+          (let ([fst ($vector-ref vec idx)])
+            (cond
+              [(eq? fst b) 
+               ($vector-set! vec idx next)]
+              [else 
+               (replace! fst b next)])))
+        ;;; then add it to the new place
+        (let ([k ($tcbucket-key b)])
+          (let ([ih (inthash (pointer-value k))])
+            (let ([idx ($fxlogand ih ($fx- ($vector-length vec) 1))])
+              (let ([n ($vector-ref vec idx)])
+                ($set-tcbucket-next! b n)
+                ($vector-set! vec idx b)
+                ($set-tcbucket-tconc! b (get-tc h))
+                (void))))))))
+
+  (define get-hash
+    (lambda (h x v)
+      (let ([pv (pointer-value x)]
+            [vec (get-vec h)])
+        (let ([ih (inthash pv)])
+          (let ([idx ($fxlogand ih ($fx- ($vector-length vec) 1))])
+            (let ([b ($vector-ref vec idx)])
+              (cond
+                [(or (direct-lookup x b) (rehash-lookup h (get-tc h) x))
+                 =>
+                 (lambda (b) 
+                   ($tcbucket-val b))]
+                [else v])))))))
+  
+  (define put-hash!
+    (lambda (h x v)
+      (let ([pv (pointer-value x)]
+            [vec (get-vec h)])
+        (let ([ih (inthash pv)])
+          (let ([idx ($fxlogand ih ($fx- ($vector-length vec) 1))])
+            (let ([b ($vector-ref vec idx)])
+              (cond
+                [(or (direct-lookup x b) (rehash-lookup h (get-tc h) x))
+                 =>
+                 (lambda (b) 
+                   ($set-tcbucket-val! b v)
+                   (void))]
+                [else 
+                 ($vector-set! vec idx
+                   ($make-tcbucket (get-tc h) x v 
+                     ($vector-ref vec idx)))
+                 (let ([ct (get-count h)])
+                   (set-count! h ($fxadd1 ct))
+                   (when ($fx> ct ($vector-length vec))
+                     (enlarge-table h)))])))))))
+
+  (define insert-b
+    (lambda (b vec mask)
+      (let* ([x ($tcbucket-key b)]
+             [pv (pointer-value x)]
+             [ih (inthash pv)]
+             [idx ($fxlogand ih mask)]
+             [next ($tcbucket-next b)])
+        ($set-tcbucket-next! b ($vector-ref vec idx))
+        ($vector-set! vec idx b)
+        (unless (fixnum? next)
+          (insert-b next vec mask)))))
+
+  (define move-all
+    (lambda (vec1 i n vec2 mask)
+      (unless ($fx= i n)
+        (let ([b ($vector-ref vec1 i)])
+          (unless (fixnum? b)
+            (insert-b b vec2 mask))
+          (move-all vec1 ($fxadd1 i) n vec2 mask)))))
+
+  (define enlarge-table
+    (lambda (h)
+      (let* ([vec1 (get-vec h)]
+             [n1 ($vector-length vec1)]
+             [n2 ($fxsll n1 1)]
+             [vec2 (make-base-vec n2)])
+        (move-all vec1 0 n1 vec2 ($fx- n2 1))
+        (set-vec! h vec2))))
+
+
+
+  (define init-vec
+    (lambda (v i n)
+      (if ($fx= i n)
+          v
+          (begin
+            ($vector-set! v i i)
+            (init-vec v ($fxadd1 i) n)))))
+
+  (define make-base-vec
+    (lambda (n)
+      (init-vec (make-vector n) 0 n)))
+
+  ;;; public interface
+  (primitive-set! 'hash-table? (record-predicate hash-rtd))
+  (primitive-set! 'make-hash-table
+    (let ([make (record-constructor hash-rtd)])
+      (lambda ()
+        (let ([x (cons #f #f)])
+          (let ([tc (cons x x)])
+            (make (make-base-vec 32) 0 tc))))))
+  (primitive-set! 'get-hash-table
+    (lambda (h x v)
+      (if (hash-table? h)
+          (get-hash h x v)
+          (error 'get-hash-table "~s is not a hash table" h))))
+  (primitive-set! 'put-hash-table!
+    (lambda (h x v)
+      (if (hash-table? h)
+          (put-hash! h x v)
+          (error 'put-hash-table! "~s is not a hash table" h)))))

src/libintelasm-6.0.ss

@@ -32,6 +32,7 @@
    ;;;      ret
    ;;;      sall
    ;;;      sarl
+   ;;;      shrl
    ;;;      sete
    ;;;      setg
 
@@ -110,6 +111,7 @@
         [subl s d]
         [sall s d]
         [sarl s d]
+        [shrl s d]
         [andl s d]
         [xorl s d]
         [orl s d]
@@ -499,6 +501,17 @@
              [(and (eq? src '%cl) (reg? dst))
               (CODE #xD3 (ModRM 3 '/4 dst ac))]
              [else (error who "invalid ~s" a)])))]
+      [(shrl)
+       (with-args a
+         (lambda (src dst)
+           (cond
+             [(and (equal? '(int 1) src) (reg? dst))
+              (CODE #xD1 (ModRM 3 '/5 dst ac))]
+             [(and (imm8? src) (reg? dst))
+              (CODE #xC1 (ModRM 3 '/5 dst (IMM8 src ac)))]
+             [(and (eq? src '%cl) (reg? dst))
+              (CODE #xD3 (ModRM 3 '/5 dst ac))]
+             [else (error who "invalid ~s" a)])))]
       [(sarl)
        (with-args a
          (lambda (src dst)

src/libsyncase-6.2.ss

@@ -0,0 +1,534 @@
+
+;;; 6.2: initial syncase implementation
+;;;
+
+
+;;; Expand : Scheme -> Core Scheme 
+;;;
+;;; <CS> ::= (quote datum)
+;;;        | <gensym>
+;;;        | (if <CS> <CS> <CS>)
+;;;        | (set! <gensym> <CS>)
+;;;        | (begin <CS> <CS> ...)
+;;;        | (letrec ([<gensym> <CS>] ...) <CS> <CS> ...)
+;;;        | (lambda <FMLS> <CS> <CS> ...)
+;;;        | (<prim> <CS> <CS> ...)
+;;;        | (#primitive| <primname>)
+;;;        | (<CS> <CS> ...)
+;;; <FML> ::= ()
+;;;         | <gensym>
+;;;         | (<gensym> . <FML>)
+;;; <prim> ::= void | memv | top-level-value | set-top-level-value! 
+;;;          | primitive-set! | foreign-call | $apply
+
+(let ([*stx* (make-record-type "*stx*" '(e marks ribcage))]
+      [*rib* (make-record-type "*rib*" '(sym* marks* lab*))]
+      [*top* (make-record-type "*top*" '())])
+
+  (define stx? (record-predicate *stx*))
+  (define make-stx (record-constructor *stx*))
+  (define stx-e (record-field-accessor *stx* 'e))
+  (define stx-marks (record-field-accessor *stx* 'marks))
+  (define stx-ribcage (record-field-accessor *stx* 'ribcage))
+  (define make-rib (record-constructor *rib*))
+  (define rib-sym* (record-field-accessor *rib* 'sym*))
+  (define rib-marks* (record-field-accessor *rib* 'marks*))
+  (define rib-lab* (record-field-accessor *rib* 'lab*))
+  (define *top-ribcage* ((record-constructor *top*)))
+  (define (top? x) (eq? x *top-ribcage*))
+  (define *syncase-macro* (gensym "*syncase-macro*"))
+
+  (define (build-data x)            `(quote ,x))
+  (define (build-global-ref x)      `(top-level-value ',x))
+  (define (build-lexical-ref x)     x)
+  (define (build-app a d)           `(,a . ,d))
+  (define (build-lambda fml* body)
+    (cond
+      [(and (pair? body) (eq? (car body) 'begin))
+       `(lambda ,fml* . ,(cdr body))]
+      [else 
+       `(lambda ,fml* ,body)]))
+  (define (build-begin body*)       `(begin . ,body*))
+
+
+  (define (build-void)              `(void))
+  (define (build-if e0 e1 e2)       `(if ,e0 ,e1 ,e2))
+  (define (build-foreign-call e e*) `(foreign-call ,e ,e*))
+
+
+
+  (define (id? x) 
+    (and (stx? x)
+         (symbol? (stx-e x))))
+
+  (define (stx->datum x) ;;;; use strip
+    (cond
+      [(stx? x) (stx-e x)]
+      [else     x]))
+
+  (define (stx-pair? x)
+    (and (stx? x)
+         (pair? (stx-e x))))
+
+  (define (strip x)
+    (cond
+      [(stx? x) (stx-e x)]
+      [else x]))
+
+  (define label? string?)
+
+  (define (eqmarks? m1* m2*)
+    (cond
+      [(null? m1*) (null? m2*)]
+      [(memq (car m1*) m2*) (eqmarks? (cdr m1*) (remq (car m1*) m2*))]
+      [else #f]))
+
+  (define (rib-lookup sym m* sym* m** lab*)
+    (and (pair? sym*)
+        (if (and (eq? sym (car sym*))
+                 (eqmarks? m* (car m**)))
+            (car lab*)
+            (rib-lookup sym m* (cdr sym*) (cdr m**) (cdr lab*)))))
+
+  (define (ribcage-lookup sym m* rc)
+    (cond
+      [(pair? rc)
+       (let ([r (car rc)])
+         (cond
+           [(eq? r 'shift) 
+            (ribcage-lookup sym (cdr m*) (cdr rc))]
+           [else
+            (or (rib-lookup sym m* (rib-sym* r) (rib-marks* r) (rib-lab* r))
+                (ribcage-lookup sym m* (cdr rc)))]))]
+      [(top? rc) #f]
+      [else (error "BUG1")]))
+  
+  (define (resolve x)
+    (unless (id? x) (error "BUG2"))
+    (let ([sym (stx-e x)]
+          [m* (stx-marks x)]
+          [rc (stx-ribcage x)])
+      (or (ribcage-lookup sym m* rc)    ; bound            -> label
+          (getprop sym *syncase-macro*) ; top-level-macros -> pair
+          sym                           ; global           -> symbol
+          )))
+
+  (define (remove-last ls)
+    (let ([d (cdr ls)])
+      (cond
+        [(null? d) '()]
+        [else (cons (car ls) (remove-last d))])))
+
+  (define (unshift rc)
+    (cond
+      [(pair? rc)
+       (if (eq? (car rc) 'shift)
+           (cdr rc)
+           (cons (car rc) (unshift (cdr rc))))]
+      [else (error "BUG3: missing shift")]))
+
+  (define (push-wrap m r x)
+    (cond
+      [(stx? x)
+       (let ([xm (stx-marks x)])
+         (cond
+           [(and (pair? xm) (eq? (car xm) #f))
+            (make-stx (stx-e x)
+                      (append (remove-last m) (cdr xm))
+                      (unshift (append r (stx-ribcage x))))]
+           [else
+            (make-stx (stx-e x)
+                      (append m xm)
+                      (append r (stx-ribcage x)))]))]
+      [else (make-stx x m r)]))
+
+  (define (push-subst sym* marks* lab* x)
+    (cond
+      [(stx? x)
+       (make-stx (stx-e x)
+                 (stx-marks x)
+                 (cons (make-rib sym* marks* lab*) (stx-ribcage x)))]
+      [else
+       (make-stx x 
+                 '()
+                 (cons (make-rib sym* marks* lab*) '()))]))
+
+  (define (push-antimark x)
+    (cond
+      [(stx? x)
+       (make-stx (stx-e x)
+                 (cons #f (stx-marks x))
+                 (stx-ribcage x))]
+      [else (make-stx x (cons #f '()) '())]))
+
+  (define (push-mark m x)
+    (cond
+      [(stx? x)
+       (let ([m* (stx-marks x)])
+         (cond
+           [(and (pair? m*) (eq? (car m*) #f))
+            (make-stx (stx-e x) (cdr m*) (stx-ribcage x))]
+           [else
+            (make-stx (stx-e x) (cons m m*) (cons 'shift (stx-ribcage x)))]))]
+      [else
+       (make-stx x (list m) '(shift))]))
+
+  (define (push-rib rib x)
+    (cond
+      [(stx? x) 
+       (make-stx (stx-e x) (stx-marks x) (cons rib (stx-ribcage x)))]
+      [else (make-stx x '() (list rib))]))
+
+  (define (expose-stx x)
+    (let ([e (stx-e x)])
+      (cond
+        [(pair? e)
+         (let ([m (stx-marks x)]
+               [r (stx-ribcage x)])
+           (cons
+             (push-wrap m r (car e))
+             (push-wrap m r (cdr e))))]
+        [(vector? e)
+         (let ([m (stx-marks x)]
+               [r (stx-ribcage x)])
+           (list->vector
+             (map (lambda (x) (push-wrap m r x)) 
+                  (vector->list e))))]
+        [(null? e) e]
+        [else x])))
+
+  (define (expose x)
+    (cond
+      [(stx? x) (expose-stx x)]
+      [else x]))
+
+  (define (expose-ls ox)
+    (let loop ([x (expose ox)])
+      (cond
+        [(pair? x) (cons (car x) (loop (expose (cdr x))))]
+        [(null? x) '()]
+        [else (error 'expose-ls "BUG: not a list: ~s" x)])))
+
+  (define (expose* x)
+    (cond
+      [(id? x) x]
+      [(stx? x) (expose* (expose x))]
+      [(pair? x) (cons (expose* (car x)) (expose* (cdr x)))]
+      [(vector? x) 
+       (list->vector (map expose* (vector->list x)))]
+      [else x]))
+
+  (define (lookup lab r)
+    (define (lookup1 lab lab* g*)
+      (cond
+        [(null? lab*) #f]
+        [(eq? lab (car lab*)) (car g*)]
+        [else (lookup1 lab (cdr lab*) (cdr g*))]))
+    (cond
+      [(null? r) #f]
+      [(eq? (car r) 'lexical-barrier)
+       (let ([v (lookup lab (cdr r))])
+         (cond
+           [(not (symbol? v)) v]
+           [else             #f]))]
+      [else
+       (or (lookup1 lab (caar r) (cdar r))
+           (lookup lab (cdr r)))]))
+
+  (define (genmark) (gensym "M"))
+  (define (newsym x) 
+    (gensym))
+    ;(gensym (symbol->string x)))
+
+  (define (apply-macro proc x r)
+    (expand-ctx (push-mark (genmark) (proc (push-antimark x))) r))
+      
+  (define (identifier-macro? x r)
+    (and (id? x)
+         (let ([a (resolve x)])
+           (or (and (label? a)
+                    (let ([a (lookup a r)])
+                      (and (procedure? a) a)))
+               (and (pair? a)
+                    (eq? (car a) '*user-macro*)
+                    (cdr a))))))
+
+  (define (macro-call? x r)
+    (if (id? x)
+        (identifier-macro? x r)
+        (let ([x (expose x)])
+          (and (pair? x)
+               (identifier-macro? (car x) r)))))
+
+  (define (core? x)
+    (and (pair? x) (eq? (car x) '*core-macro*)))
+
+  (define (apply-core-form a d ctx r)
+    (unless (core? a) (syntax-error ctx))
+    ((cdr a) a d ctx r))
+
+  (define (E* d r ctx)
+    (let ([d (expose-ls d)])
+      (map (lambda (x) (E x r)) d)))
+
+  (define (extend-core name proc)
+    (putprop name *syncase-macro* (cons '*core-macro* proc)))
+
+  (define (extend-user-macro name proc)
+    (putprop name *syncase-macro* (cons '*user-macro* proc)))
+
+  (define (E ctx r)
+    (let ([x (expose ctx)])
+      (cond
+        [(macro-call? x r) =>
+         (lambda (proc)
+           (apply-macro proc ctx r))]
+        [(pair? x)
+         (let ([a (car x)] [d (cdr x)])
+           (cond
+             [(id? a)
+              (let ([a (resolve a)])
+                (cond
+                  [(label? a)
+                   (cond
+                     [(lookup a r) =>
+                      (lambda (g)
+                        (cond
+                          [(symbol? g)
+                           (build-app (build-lexical-ref g) 
+                                      (E* d r ctx))]
+                          [(and (pair? g) (eq? (car g) 'pat))
+                           (syntax-error ctx)]
+                          [else (error 'expand "BUG4")]))]
+                     [else (syntax-error ctx)])]
+                  [(core? a)
+                   (apply-core-form a d ctx r)]
+                  [(symbol? a)
+                   (build-app (build-global-ref a) 
+                              (E* d r ctx))]
+                  [else (syntax-error ctx)]))]
+             [else
+              (build-app 
+                (E a r)
+                (E* d r ctx))]))]
+        [(id? x)
+         (let ([a (resolve x)])
+           (cond
+             [(label? a)
+              (cond
+                [(lookup a r) =>
+                 (lambda (g)
+                   (cond
+                     [(symbol? g) (build-lexical-ref g)]
+                     [(and (pair? g) (eq? (car g) 'pat))
+                      (syntax-error ctx)]
+                     [else (error 'expand "BUG5")]))]
+                [else (syntax-error ctx)])]
+             [(core? a) (syntax-error ctx)]
+             [(symbol? a)
+              (build-global-ref a)]
+             [else (syntax-error ctx)]))]
+        [else (build-data (strip x))])))
+
+  (define (core-expand x)
+    (E (make-stx x '() *top-ribcage*) '()))
+
+  (define (process-fml* bind* ctx)
+    (define (assert-no-dups s m* s* m**)
+      (unless (null? s*)
+        (when (and (eq? s (car s*))
+                   (eqmarks? m* (car m**)))
+          (syntax-error ctx))
+        (assert-no-dups s m* (cdr s*) (cdr m*))))
+    (let loop ([bind* (expose bind*)])
+      (cond
+        [(null? bind*) (values '() '() '() '() '())]
+        [(pair? bind*)
+         (let ([b (car bind*)])
+           (unless (id? b) (syntax-error ctx))
+           (let-values ([(fml* s* m** g* lab*) 
+                         (loop (expose (cdr bind*)))])
+             (let ([s (stx-e b)] [m* (stx-marks b)])
+               (assert-no-dups s m* s* m**)
+               (let ([lab (string #\i)] [g (newsym s)])
+                 (values (cons g fml*)
+                         (cons s s*)
+                         (cons m* m**)
+                         (cons g g*)
+                         (cons lab lab*))))))]
+        [else (syntax-error ctx)])))
+
+  (define (top-level-macro? x r sym)
+    (let ([x (expose x)])
+      (and (pair? x)
+           (id? (car x))
+           (let ([loc (resolve (car x))])
+             (and (or (and (pair? loc) 
+                           (eq? (car loc) '*core-macro*))
+                      (symbol? loc))
+                  (eq? (stx->datum (car x)) sym))))))
+
+  (define (define? x r)
+    (top-level-macro? x r 'define))
+
+  (define (begin? x r)
+    (top-level-macro? x r 'begin))
+
+  (define (begin-e* x ctx)
+    (let ([x (expose x)])
+      (let loop ([x (expose (cdr x))])
+        (cond
+          [(null? x) '()]
+          [(pair? x) (cons (car x) (loop (expose (cdr x))))]
+          [else (syntax-error ctx)]))))
+
+  (define (expand-body* body* ctx r)
+    (let ([rib (make-rib '() '() '())])
+      (let loop ([body* (expose (push-rib rib body*))]
+                 [r r]
+                 [lab* '()] [sym* '()] [marks* '()] [vrhs* '()])
+        (cond
+          [(null? body*) (syntax-error ctx)]
+          [(pair? body*)
+           (let ([a (car body*)] [d (cdr body*)])
+             (cond
+               [(macro-call? a r) =>
+                (lambda (proc)
+                  (loop (cons (push-mark (genmark) (proc (push-antimark a))) d)
+                        r lab* sym* marks* vrhs*))]
+               [(define? a r)
+                (let-values ([(lhs rhs) (extract-define a ctx)])
+                  (loop (expose d) 
+                        r
+                        (cons (string #\p) lab*)
+                        (cons (stx-e lhs) sym*)
+                        (cons (stx-marks lhs) marks*)
+                        (cons rhs vrhs*)))]
+               [(begin? a r)
+                (loop (expose (append (begin-e* a ctx) d))
+                      r lab* sym* marks* vrhs*)]
+               [else
+                ;;; done
+                (cond
+                  [(null? sym*) 
+                   (let ([body* (E* body* r ctx)])
+                     (build-begin body*))]
+                  [else
+                   (let ([g* (map newsym sym*)])
+                     (let* ([r (cons (cons lab* g*) r)]
+                            [rhs* 
+                             (E* (push-subst sym* marks* lab* vrhs*)
+                                          r ctx)]
+                            [body* 
+                             (E* (push-subst sym* marks* lab* body*)
+                                          r ctx)])
+                       (build-letrec g* rhs* (build-begin body*))))])]))]
+          [else (syntax-error ctx)]))))
+
+  (define (extract-bindings bind* ctx)
+    (let ([bind* (expose bind*)])
+      (cond
+        [(null? bind*) (values '() '())]
+        [(not (pair? bind*)) (syntax-error ctx)]
+        [else
+         (let ([a (car bind*)] [d (cdr bind*)])
+           (let ([a (expose-ls a)])
+             (cond
+               [(fx= (length a) 2)
+                (let-values ([(lhs* rhs*) 
+                              (extract-bindings d ctx)])
+                  (values (cons (car a) lhs*)
+                          (cons (cadr a) rhs*)))]
+               [else (syntax-error ctx)])))])))
+
+  (define (core-stx x)
+    (make-stx x '() *top-ribcage*))
+
+  (extend-core 'quote
+    (lambda (a d ctx r)
+      (let ([d (expose-ls d)])
+        (cond
+          [(and (list? d) (fx= (length d) 1))
+           (build-data (strip (car d)))]
+          [else (syntax-error ctx)]))))
+
+  (extend-core 'lambda
+    (lambda (a d ctx r)
+      (let ([d (expose d)])
+        (cond
+          [(pair? d)
+           (let ([fml* (car d)] [body* (cdr d)])
+             (let-values ([(fml* s* m** g* lab*)
+                           (process-fml* fml* ctx)])
+               (let ([body* (push-subst s* m** lab* body*)])
+                 (let ([r (cons (cons lab* g*) r)])
+                   (build-lambda fml* 
+                     (expand-body* body* ctx r))))))]
+          [else (syntax-error ctx)]))))
+
+  (extend-core 'if
+    (lambda (a d ctx r)
+      (let ([d (expose d)])
+        (unless (pair? d) (syntax-error ctx))
+        (let ([test (car d)] [d (expose (cdr d))])
+          (unless (pair? d) (syntax-error ctx))
+          (let ([conseq (car d)] [d (expose (cdr d))])
+            (let ([altern
+                   (cond
+                     [(null? d) (build-void)]
+                     [(pair? d)
+                      (let ([altern (car d)] [d (expose (cdr d))])
+                        (cond
+                          [(null? d) (E altern r)]
+                          [else (syntax-error ctx)]))]
+                     [else (syntax-error ctx)])])
+              (build-if (E test r) (E conseq r) altern)))))))
+
+  (extend-core 'begin
+    (lambda (a d ctx r)
+      (let ([d (expose-ls d)])
+        (when (null? d) (syntax-error ctx))
+        (build-begin (E* d r ctx)))))
+
+
+  (extend-core 'define 
+    (lambda (a d ctx r) (syntax-error ctx)))
+
+  (extend-core 'foreign-call
+    (lambda (a d ctx r)
+      (let ([d (expose-ls d)])
+        (unless (fx>= (length d) 1) (syntax-error ctx))
+        (build-foreign-call
+          (E (car d) r)
+          (E* (cdr d) r ctx)))))
+
+  (extend-core 'let
+    (lambda (a d ctx r)
+      (let ([d (expose d)])
+        (unless (pair? d) (syntax-error ctx))
+        (let ([bind* (car d)] [body* (cdr d)])
+          (let-values ([(lhs* rhs*) 
+                        (extract-bindings bind* ctx)])
+            (let ([lambda^ (core-stx 'lambda)])
+              (E `((,lambda^ ,lhs* . ,body*) . ,rhs*) r)))))))
+
+  (extend-core 'let*
+    (lambda (a d ctx r)
+      (let ([d (expose d)])
+        (unless (pair? d) (syntax-error ctx))
+        (let ([bind* (car d)] [body* (cdr d)])
+          (let-values ([(lhs* rhs*)
+                        (extract-bindings bind* ctx)])
+            (let ([lambda^ (core-stx 'lambda)])
+              (E (let f ([lhs* lhs*] [rhs* rhs*])
+                   (cond
+                     [(null? lhs*) 
+                      `((,lambda^ () . ,body*))]
+                     [else
+                      `((,lambda^ (,(car lhs*)) 
+                          ,(f (cdr lhs*) (cdr rhs*)))
+                        ,(car rhs*))]))
+                 r)))))))
+
+  (set! expand core-expand)
+)

src/libwriter-6.2.ss

@@ -0,0 +1,373 @@
+
+;;; 6.2: * added a printer for bwp-objects
+
+;;; WRITER provides display and write.
+
+(let ()
+  (define char-table ; first nonprintable chars
+    '#("nul" "soh" "stx" "etx" "eot" "enq" "ack" "bel" "bs" "tab" "newline"
+       "vt" "ff" "return" "so" "si" "dle" "dc1" "dc2" "dc3" "dc4" "nak" 
+       "syn" "etb" "can" "em" "sub" "esc" "fs" "gs" "rs" "us" "space"))
+  (define write-character
+    (lambda (x p m)
+      (if m 
+          (let ([i ($char->fixnum x)])
+            (write-char #\# p)
+            (cond
+             [(fx< i (vector-length char-table))
+              (write-char #\\ p)
+              (write-char* (vector-ref char-table i) p)]
+             [(fx< i 127)
+              (write-char #\\ p)
+              (write-char x p)]
+             [(fx= i 127) 
+              (write-char #\\ p)
+              (write-char* "del" p)]
+             [else
+              (write-char #\+ p)
+              (write-fixnum i p)]))
+          (write-char x p))))
+  (define write-list
+    (lambda (x p m)
+      (cond
+       [(pair? x)
+        (write-char #\space p)
+        (writer (car x) p m)
+        (write-list (cdr x) p m)]
+       [(not (null? x))
+        (write-char #\space p)
+        (write-char #\. p)
+        (write-char #\space p)
+        (writer x p m)])))
+  (define write-vector
+    (lambda (x p m)
+      (write-char #\# p)
+      (write-char #\( p)
+      (let ([n (vector-length x)])
+        (when (fx> n 0)
+          (writer (vector-ref x 0) p m)
+          (letrec ([f 
+                    (lambda (i)
+                      (unless (fx= i n)
+                        (write-char #\space p)
+                        (writer (vector-ref x i) p m)
+                        (f (fxadd1 i))))])
+            (f 1))))
+      (write-char #\) p)))
+  (define write-record
+    (lambda (x p m)
+      (write-char #\# p)
+      (write-char #\[ p)
+      (writer (record-name x) p m)
+      (let ([n (record-length x)])
+        (letrec ([f 
+                  (lambda (i)
+                    (unless (fx= i n)
+                      (write-char #\space p)
+                      (writer (record-ref x i) p m)
+                      (f (fxadd1 i))))])
+          (f 0)))
+      (write-char #\] p)))
+  (define initial?
+    (lambda (c)
+      (or (letter? c) (special-initial? c))))
+  (define letter?
+    (lambda (c)
+      (or (and ($char<= #\a c) ($char<= c #\z))
+          (and ($char<= #\A c) ($char<= c #\Z)))))
+  (define digit?
+    (lambda (c)
+      (and ($char<= #\0 c) ($char<= c #\9))))
+  (define special-initial? 
+    (lambda (x)
+      (memq x '(#\! #\$ #\% #\& #\* #\/ #\: #\< #\= #\> #\? #\^ #\_ #\~))))
+  (define subsequent?
+    (lambda (x)
+      (or (initial? x)
+          (digit? x)
+          (special-subsequent? x))))
+  (define special-subsequent?
+    (lambda (x) 
+      (memq x '(#\+ #\- #\. #\@))))
+  (define subsequent*?
+    (lambda (str i n)
+      (or ($fx= i n)
+          (and (subsequent? ($string-ref str i))
+               (subsequent*? str ($fxadd1 i) n)))))
+  (define valid-symbol-string?
+    (lambda (str)
+      (or (let ([n ($string-length str)])
+            (and ($fx>= n 1)
+                 (initial? ($string-ref str 0))
+                 (subsequent*? str 1 n)))
+          (string=? str "+")
+          (string=? str "-")
+          (string=? str "..."))))
+  (define write-symbol-esc-loop
+    (lambda (x i n p)
+      (unless ($fx= i n)
+        (let ([c ($string-ref x i)])
+          (when (memq c '(#\\ #\|))
+            (write-char #\\ p))
+          (write-char c p))
+        (write-symbol-esc-loop x ($fxadd1 i) n p))))
+  (define write-symbol-esc
+    (lambda (x p)
+      (write-char #\| p)
+      (write-symbol-esc-loop x 0 ($string-length x) p)
+      (write-char #\| p)))
+  (define write-symbol
+    (lambda (x p m)
+      (let ([str (symbol->string x)])
+        (if m
+            (if (valid-symbol-string? str)
+                (write-char* str p)
+                (write-symbol-esc str p))
+            (write-char* str p)))))
+  (define write-gensym
+    (lambda (x p m)
+      (cond
+        [(and m (print-gensym))
+         (let ([str (symbol->string x)])
+           (write-char #\# p)
+           (write-char #\{ p)
+           (if (valid-symbol-string? str)
+               (write-char* str p)
+               (write-symbol-esc str p))
+           (write-char #\space p)
+           (write-symbol-esc (gensym->unique-string x) p)
+           (write-char #\} p))]
+        [else (write-symbol x p m)])))
+  (define write-string-escape
+    (lambda (x p)
+      (define loop 
+        (lambda (x i n p)
+         (unless (fx= i n)
+           (let ([c (string-ref x i)])
+             (cond
+               [(or ($char= #\" c) ($char= #\\ c))
+                (write-char #\\ p)
+                (write-char c p)]
+               [($char= #\tab c)
+                (write-char #\\ p)
+                (write-char #\t p)]
+               [else
+                (write-char c p)]))
+           (loop x (fxadd1 i) n p)))) 
+      (write-char #\" p)
+      (loop x 0 (string-length x) p)
+      (write-char #\" p)))
+  (define write-string
+    (lambda (x p m)
+      (if m
+          (write-string-escape x p)
+          (write-char* x p))))
+  (define write-fixnum
+    (lambda (x p)
+      (define loop
+        (lambda (x p)
+          (unless (fxzero? x)
+            (loop (fxquotient x 10) p)
+            (write-char 
+               ($fixnum->char
+                  ($fx+ (fxremainder x 10)
+                        ($char->fixnum #\0)))
+               p))))
+      (cond
+       [(fxzero? x) (write-char #\0 p)]
+       [(fx< x 0)
+        (write-char #\- p)
+        (if (fx= x -536870912)
+            (write-char* "536870912" p)
+            (loop (fx- 0 x) p))]
+       [else (loop x p)])))
+  (define write-char*
+    (lambda (x p)
+      (define loop 
+        (lambda (x i n p)
+         (unless (fx= i n)
+           (write-char (string-ref x i) p)
+           (loop x (fxadd1 i) n p)))) 
+      (loop x 0 (string-length x) p)))
+  (define macro
+    (lambda (x)
+      (define macro-forms
+        '([quote .            "'"]
+          [quasiquote .       "`"]
+          [unquote .          ","]
+          [unquote-splicing . ",@"]
+          [syntax .           "#'"]
+          [|#primitive| .     "#%"]))
+      (and (pair? x)
+           (let ([d ($cdr x)])
+             (and (pair? d)
+                  (null? ($cdr d))))
+           (assq ($car x) macro-forms))))
+  (define writer
+    (lambda (x p m)
+      (cond
+        [(macro x) =>
+         (lambda (y)
+           (write-char* (cdr y) p)
+           (writer (cadr x) p m))]
+        [(pair? x) 
+         (write-char #\( p)
+         (writer (car x) p m)
+         (write-list (cdr x) p m)
+         (write-char #\) p)]
+        [(symbol? x) 
+         (if (gensym? x)
+             (write-gensym x p m)
+             (write-symbol x p m))]
+        [(fixnum? x)
+         (write-fixnum x p)]
+        [(string? x)
+         (write-string x p m)]
+        [(boolean? x)
+         (write-char* (if x "#t" "#f") p)]
+        [(char? x)
+         (write-character x p m)]
+        [(procedure? x)
+         (write-char* "#<procedure>" p)]
+        [(output-port? x)
+         (write-char* "#<output-port " p)
+         (writer (output-port-name x) p #t)
+         (write-char #\> p)]
+        [(input-port? x)
+         (write-char* "#<input-port " p)
+         (writer (input-port-name x) p #t)
+         (write-char #\> p)]
+        [(vector? x)
+         (write-vector x p m)]
+        [(null? x) 
+         (write-char #\( p)
+         (write-char #\) p)]
+        [(eq? x (void)) 
+         (write-char* "#<void>" p)]
+        [(eof-object? x)
+         (write-char* "#!eof" p)]
+        [(bwp-object? x)
+         (write-char* "#!bwp" p)]
+        [(record? x)
+         (let ([printer (record-printer x)])
+           (if (procedure? printer)
+               (printer x p)
+               (write-record x p m)))]
+        ;[(code? x)
+        ; (write-char* "#<code>" p)]
+        [(hash-table? x)
+         (write-char* "#<hash-table>" p)]
+        [($unbound-object? x)
+         (write-char* "#<unbound-object>" p)]
+        [($forward-ptr? x)
+         (write-char* "#<forward-ptr>" p)]
+        [else 
+         (write-char* "#<unknown>" p)])))
+
+  (define (write x p)
+    (writer x p #t)
+    (flush-output-port p))
+  (define (display x p)
+    (writer x p #f)
+    (flush-output-port p))
+  ;;;
+  (define formatter
+    (lambda (who p fmt args)
+      (let f ([i 0] [args args])
+        (unless (fx= i (string-length fmt))
+          (let ([c (string-ref fmt i)])
+            (cond
+              [($char= c #\~)
+               (let ([i (fxadd1 i)])
+                 (when (fx= i (string-length fmt))
+                   (error who "invalid ~~ at end of format string ~s" fmt))
+                 (let ([c (string-ref fmt i)])
+                  (cond
+                    [($char= c #\~) 
+                     (write-char #\~ p)
+                     (f (fxadd1 i) args)]
+                    [($char= c #\a)
+                     (when (null? args)
+                       (error who "insufficient arguments"))
+                     (display (car args) p)
+                     (f (fxadd1 i) (cdr args))]
+                    [($char= c #\s)
+                     (when (null? args)
+                       (error who "insufficient arguments"))
+                     (write (car args) p)
+                     (f (fxadd1 i) (cdr args))]
+                    [else
+                     (error who "invalid sequence ~~~a" c)])))]
+              [else 
+               (write-char c p)
+               (f (fxadd1 i) args)]))))))
+
+  (define fprintf
+    (lambda (port fmt . args)
+      (unless (output-port? port) 
+        (error 'fprintf "~s is not an output port" port))
+      (unless (string? fmt)
+        (error 'fprintf "~s is not a string" fmt))
+      (formatter 'fprintf port fmt args)))
+
+  (define printf
+    (lambda (fmt . args)
+      (unless (string? fmt)
+        (error 'printf "~s is not a string" fmt))
+      (formatter 'printf (current-output-port) fmt args)))
+
+  (define format
+    (lambda (fmt . args)
+      (unless (string? fmt)
+        (error 'format "~s is not a string" fmt))
+      (let ([p (open-output-string)])
+        (formatter 'format p fmt args)
+        (get-output-string p))))
+
+  (define print-error
+    (lambda (who fmt . args)
+      (unless (string? fmt)
+        (error 'print-error "~s is not a string" fmt))
+      (let ([p (standard-error-port)])
+        (if who
+            (fprintf p "Error in ~a: " who)
+            (fprintf p "Error: "))
+        (formatter 'print-error p fmt args)
+        (write-char #\. p)
+        (newline p))))
+
+  
+  ;;;
+  (primitive-set! 'format format)
+  (primitive-set! 'printf printf)
+  (primitive-set! 'fprintf fprintf)
+  (primitive-set! 'write 
+    (case-lambda
+      [(x) (write x (current-output-port))]
+      [(x p)
+       (unless (output-port? p) 
+         (error 'write "~s is not an output port" p))
+       (write x p)]))
+  (primitive-set! 'display 
+    (case-lambda
+      [(x) (display x (current-output-port))]
+      [(x p)
+       (unless (output-port? p) 
+         (error 'display "~s is not an output port" p))
+       (display x p)]))
+  (primitive-set! 'print-error print-error)
+  (primitive-set! 'current-error-handler
+    (make-parameter
+      (lambda args
+        (apply print-error args)
+        (display "exiting\n" (console-output-port))
+        (flush-output-port (console-output-port))
+        (exit -100))
+      (lambda (x)
+        (if (procedure? x)
+            x
+            (error 'current-error-handler "~s is not a procedure" x)))))
+  (primitive-set! 'error
+    (lambda args
+      (apply (current-error-handler) args)))) 
+

src/makepp.ss

@@ -0,0 +1,34 @@
+(define primitive-set! set-top-level-value!)
+(define chez-expand sc-expand)
+(define-syntax |#primitive|
+  (lambda (x)
+    (syntax-case x ()
+      [(_ n) #'n])))
+
+(printf "loading psyntax.pp ...\n")
+(load "psyntax-7.1.pp")
+
+(current-expand 
+  (lambda (x . args)
+    (apply chez-expand (sc-expand x) args)))
+
+(printf "loading psyntax.ss ...\n")
+(load "psyntax-7.1.ss")
+(current-expand
+  (lambda (x . args)
+    (apply chez-expand (sc-expand x) args)))
+
+(printf "making xpsyntax.pp ...\n")
+
+(with-output-to-file "xpsyntax.pp"
+  (lambda ()
+    (load "psyntax-7.1.ss"
+      (lambda (x)
+        (parameterize ([print-gensym #f]
+                       [print-graph #f]
+                       [expand-mode 'bootstrap]
+                       [print-vector-length #f])
+          (pretty-print (sc-expand x))
+          (newline)))))
+  'replace)
+

src/runtime/Makefile

@@ -1,37 +1,40 @@
 
+#CFLAGS = -Wall -DNDEBUG -O3
+CFLAGS = -Wall -g
+LDFLAGS = -g -ldl -luuid -rdynamic
 all: ikarus
 
 ikarus: ikarus-collect.o ikarus-runtime.o ikarus-main.o ikarus-fasl.o \
   ikarus-exec.o ikarus-print.o ikarus-enter.s ikarus-symbol-table.o  \
-  ikarus-hash-tables.o
+  ikarus-weak-pairs.o
-	gcc -g -Wall -ldl -luuid -rdynamic -o ikarus \
+	gcc  $(LDFLAGS) -o ikarus \
 	ikarus-main.o ikarus-runtime.o \
 	ikarus-fasl.o ikarus-exec.o ikarus-print.o ikarus-enter.s \
-	ikarus-symbol-table.o ikarus-collect.o ikarus-hash-tables.o
+	ikarus-symbol-table.o ikarus-collect.o ikarus-weak-pairs.o
 
 ikarus-main.o: ikarus-main.c ikarus.h
-	gcc -Wall -g -c ikarus-main.c
+	gcc $(CFLAGS) -c ikarus-main.c
 
 ikarus-runtime.o: ikarus-runtime.c ikarus.h
-	gcc -Wall -g -c ikarus-runtime.c
+	gcc $(CFLAGS) -c ikarus-runtime.c
 
 ikarus-fasl.o: ikarus-fasl.c ikarus.h
-	gcc -Wall -g -c ikarus-fasl.c
+	gcc $(CFLAGS) -c ikarus-fasl.c
 
 ikarus-exec.o: ikarus-exec.c ikarus.h
-	gcc -Wall -g -c ikarus-exec.c
+	gcc $(CFLAGS) -c ikarus-exec.c
 
 ikarus-print.o: ikarus-print.c ikarus.h
-	gcc -Wall -g -c ikarus-print.c
+	gcc $(CFLAGS) -c ikarus-print.c
 
 ikarus-collect.o: ikarus-collect.c ikarus.h
-	gcc -Wall -g -c ikarus-collect.c
+	gcc $(CFLAGS) -c ikarus-collect.c
+
+ikarus-weak-pairs.o: ikarus-weak-pairs.c ikarus.h
+	gcc $(CFLAGS) -c ikarus-weak-pairs.c
 
 ikarus-symbol-table.o: ikarus-symbol-table.c ikarus.h
-	gcc -Wall -g -c ikarus-symbol-table.c
+	gcc $(CFLAGS) -c ikarus-symbol-table.c
-
-ikarus-hash-tables.o: ikarus-hash-tables.c ikarus.h
-	gcc -Wall -g -c ikarus-hash-tables.c
 
 ikarus.h: ikarus-data.h
 	touch ikarus.h

src/runtime/ikarus-data.h

@@ -73,6 +73,8 @@
 
 #define null_object       ((ikp)0x4F)
 #define void_object       ((ikp)0x7F)
+#define bwp_object        ((ikp)0x8F)
+
 #define unbound_object    ((ikp)0x6F)
 #define IK_CHAR_TAG       0x0F
 #define IK_CHAR_MASK      0xFF
@@ -184,4 +186,15 @@
 #define off_htable_size  (disp_htable_size  - vector_tag) 
 #define off_htable_mem   (disp_htable_mem   - vector_tag) 
 
+#define disp_tcbucket_tconc  0
+#define disp_tcbucket_key    4
+#define disp_tcbucket_val    8
+#define disp_tcbucket_next  12
+#define tcbucket_size 16
+#define off_tcbucket_tconc (disp_tcbucket_tconc - vector_tag)
+#define off_tcbucket_key   (disp_tcbucket_key   - vector_tag)
+#define off_tcbucket_val   (disp_tcbucket_val   - vector_tag)
+#define off_tcbucket_next  (disp_tcbucket_next  - vector_tag)
+
+
 #endif

src/runtime/ikarus-enter.s

@@ -1,8 +1,10 @@
 
 .text
-.align 8
 .globl ik_asm_enter
 .globl ik_underflow_handler
+.globl ik_foreign_call
+.globl ik_asm_reenter
+.align 8
 ik_asm_enter:
   # ignored value is the third arg 12(%esp)
   # code is the second arg  8(%esp)
@@ -46,7 +48,6 @@ L_multivalue_underflow:
   addl $4, %esp
   jmp L_do_underflow
 
-.globl ik_asm_reenter
 .align 8
 ik_asm_reenter:
   # argc is at 12(%esp)
@@ -71,4 +72,25 @@ L_multi_reentry:
   jmp *-9(%ebx)
 
 
+.align 8
+ik_foreign_call:
+  movl %esp, 8(%esi)     # (movl fpr (pcb-ref 'frame-pointer))
+  movl %ebp, 0(%esi)     # (movl apr (pcb-ref 'allocation-pointer))
+  movl %esp, %ebx        # (movl fpr ebx)
+  movl 24(%esi), %esp    # (movl (pcb-ref 'system-stack) esp)
+  pushl %esi             # (pushl pcr)
+  cmpl $0, %eax          # (cmpl (int 0) eax)
+  je L_set               # (je (label Lset))
+L_loop:                  # (label Lloop)
+  movl (%ebx,%eax), %ecx # (movl (mem ebx eax) ecx)
+  pushl %ecx             # (pushl ecx)
+  addl $4, %eax          # (addl (int 4) eax)
+  cmpl $0, %eax          # (cmpl (int 0) eax)
+  jne L_loop             # (jne (label Lloop))
+L_set:                   # (label Lset)
+  call *%edi             # (call cpr)
+  movl 8(%esi), %esp     # (movl (pcb-ref 'frame-pointer) fpr)
+  movl 0(%esi), %ebp     # (movl (pcb-ref 'allocation-pointer) apr)
+  ret                    # (ret)))
+
 

src/runtime/ikarus-exec.c

@@ -32,6 +32,9 @@ ikp ik_exec_code(ikpcb* pcb, ikp code_ptr){
       nk->size = k->size - framesize;
       k->size = framesize;
       k->next = vector_tag + (ikp)nk;
+      /* record side effect */
+      unsigned int idx = ((unsigned int)(&k->next)) >> pageshift;
+      pcb->dirty_vector[idx] = -1;
     }
     pcb->next_k = k->next;
     ikp fbase = pcb->frame_base - wordsize;

src/runtime/ikarus-fasl.c

@@ -91,40 +91,18 @@ void ik_fasl_load(ikpcb* pcb, char* fasl_file){
 }
 
 
-static void
-ik_link_dl(ikdl* x, ikdl* target){
-  ikdl* next = target->next;
-  x->next = next;
-  x->prev = target;
-  target->next = x;
-  next->prev = x;
-}
-
-static ikp
-ik_allocate_code(int size, ikpcb* pcb){
-  int memreq = align_to_next_page(size + sizeof(ikcode_preheader));
-  ikp mem = ik_mmap(memreq);
-  ikcodes* p = ik_malloc(sizeof(ikcodes));
-  p->code_object = mem + sizeof(ikcode_preheader);
-  p->attr = ikcode_live;
-  p->base = mem;
-  p->size = memreq;
-  ik_link_dl(&(p->dl), &pcb->codes);
-  ref(mem, 0) = (ikp) p;
-  return mem + sizeof(ikcode_preheader);
-}
 
 static ikp 
 ik_make_code(int code_size, int reloc_size, ikp closure_size, ikpcb* pcb){
   int required_memory = 
-    align(code_size + reloc_size + disp_code_data);
+    align_to_next_page(code_size + reloc_size + disp_code_data);
-
+  ikp mem = ik_mmap_code(required_memory, 0, pcb);
-  ikp mem = ik_allocate_code(required_memory, pcb);
+  ref(mem, 0) = code_tag;
-  REF(mem, 0) = IK_CODE_SEC_TAG;
+  ref(mem, disp_code_code_size) = (ikp) code_size;
-  REF(mem, IK_DISP_CODE_CODE_SIZE) = (ikp) code_size;
+  ref(mem, disp_code_reloc_size) = (ikp) reloc_size;
-  REF(mem, IK_DISP_CODE_RELOC_SIZE) = (ikp) reloc_size;
+  ref(mem, disp_code_closure_size) = closure_size;
-  REF(mem, IK_DISP_CODE_CLOSURE_SIZE) = closure_size;
+  ref(mem,disp_code_data+code_size+reloc_size) = 0;
-  return (ikp)(mem+IK_CODE_PRI_TAG);
+  return (ikp)(mem+vector_tag);
 }
 
 static char fasl_read_byte(fasl_port* p){
@@ -147,26 +125,13 @@ static void fasl_read_buf(fasl_port* p, void* buf, int n){
     exit(-1);
   }
 }
-
-static void
-ik_set_car(ikp x, ikp v){
-  REF(x, IK_OFF_CAR) = v;
-}
-
-static void
-ik_set_cdr(ikp x, ikp v){
-  REF(x, IK_OFF_CDR) = v;
-}
-
-
-
 typedef struct{
   int code_size;
   int reloc_size;
   ikp closure_size;
 } code_header;
 
-#define wordsize 4
+
 
 static ikp do_read(ikpcb* pcb, fasl_port* p){
   char c = fasl_read_byte(p);
@@ -277,8 +242,8 @@ static ikp do_read(ikpcb* pcb, fasl_port* p){
     if(put_mark_index){
       p->marks[put_mark_index] = pair;
     }
-    ik_set_car(pair, do_read(pcb, p));
+    ref(pair, off_car) = do_read(pcb, p);
-    ik_set_cdr(pair, do_read(pcb, p));
+    ref(pair, off_cdr) = do_read(pcb, p);
     return pair;
   }
   else if(c == 'M'){

src/runtime/ikarus-runtime.c

@@ -15,6 +15,111 @@
 
 int total_allocated_pages = 0;
 
+#define segment_size  (pagesize*pagesize/wordsize)
+#define segment_shift (pageshift+pageshift-wordshift)
+#define segment_index(x) (((unsigned int)(x)) >> segment_shift)
+
+static void
+extend_table_maybe(unsigned char*p,  int size, ikpcb* pcb){
+  assert(size == align_to_next_page(size));
+  unsigned char* q = p + size;
+  if(p < pcb->memory_base){
+    int new_lo = segment_index(p);
+    int old_lo = segment_index(pcb->memory_base);
+    int hi = segment_index(pcb->memory_end);
+    int new_vec_size = (hi - new_lo) * pagesize;
+    int old_vec_size = (hi - old_lo) * pagesize;
+    unsigned char* v = ik_mmap(new_vec_size);
+    bzero(v, new_vec_size - old_vec_size);
+    memcpy(v+new_vec_size-old_vec_size, pcb->dirty_vector_base, old_vec_size);
+    ik_munmap(pcb->dirty_vector_base, old_vec_size);
+    pcb->dirty_vector_base = (unsigned int*) v;
+    pcb->dirty_vector = (unsigned int*)(v - new_lo * pagesize);
+    unsigned char* s = ik_mmap(new_vec_size);
+    bzero(s, new_vec_size - old_vec_size);
+    memcpy(s+new_vec_size-old_vec_size, pcb->segment_vector_base, old_vec_size);
+    ik_munmap(pcb->segment_vector_base, old_vec_size);
+    pcb->segment_vector_base = (unsigned int*) s;
+    pcb->segment_vector = (unsigned int*)(s - new_lo * pagesize);
+    pcb->memory_base = (unsigned char*)(new_lo * segment_size);
+  } 
+  else if (q > pcb->memory_end){
+    fprintf(stderr, "must extend segment table upwards!\n");
+    fprintf(stderr, "mem: 0x%08x ... 0x%08x\n", 
+        (int)pcb->memory_base, (int)pcb->memory_end-1);
+    fprintf(stderr, "new: 0x%08x ... 0x%08x\n",
+        (int)p, (int)q-1);
+    exit(-1);
+  }
+}
+
+
+static void
+set_segment_type(unsigned char* base, int size, unsigned int type, ikpcb* pcb){
+  assert(base >= pcb->memory_base);
+  assert((base+size) <= pcb->memory_end);
+  assert(size == align_to_next_page(size));
+  unsigned int* p = pcb->segment_vector + page_index(base);
+  unsigned int* q = p + page_index(size);
+  while(p < q){
+    *p = type;
+    p++;
+  }
+}
+
+void
+ik_munmap_from_segment(unsigned char* base, int size, ikpcb* pcb){
+  assert(base >= pcb->memory_base);
+  assert((base+size) <= pcb->memory_end);
+  assert(size == align_to_next_page(size));
+  unsigned int* p = pcb->segment_vector + page_index(base);
+  unsigned int* s = pcb->dirty_vector + page_index(base);
+  unsigned int* q = p + page_index(size);
+  while(p < q){
+    assert(*p != hole_mt);
+    *p = hole_mt; /* holes */
+    *s = 0;  
+    p++; s++;
+  }
+  ik_munmap(base, size);
+}
+
+
+
+void* 
+ik_mmap_typed(int size, unsigned int type, ikpcb* pcb){
+  unsigned char* p = ik_mmap(size);
+  extend_table_maybe(p, size, pcb);
+  set_segment_type(p, size, type, pcb);
+  return p;
+}
+
+void* 
+ik_mmap_ptr(int size, int gen, ikpcb* pcb){
+  return ik_mmap_typed(size, pointers_mt | gen, pcb);
+}
+
+void* 
+ik_mmap_data(int size, int gen, ikpcb* pcb){
+  return ik_mmap_typed(size, data_mt | gen, pcb);
+}
+
+void* 
+ik_mmap_code(int size, int gen, ikpcb* pcb){
+  return ik_mmap_typed(size, code_mt | gen, pcb);
+}
+
+
+void* 
+ik_mmap_mixed(int size, ikpcb* pcb){
+  assert(0);
+  return 0;
+}
+
+
+
+
+
 void* 
 ik_mmap(int size){
   int pages = (size + pagesize - 1) / pagesize;
@@ -117,6 +222,40 @@ ikpcb* ik_make_pcb(){
   codes->next = codes;
   codes->prev = codes;
 
+  {
+    /* compute extent of heap and stack */
+    unsigned char* lo_mem;
+    unsigned char* hi_mem;
+    if(pcb->heap_base < pcb->stack_base){
+      lo_mem = pcb->heap_base - pagesize;
+      hi_mem = pcb->stack_base + pcb->stack_size + pagesize;
+    } else {
+      lo_mem = pcb->stack_base - pagesize;
+      hi_mem = pcb->heap_base + pcb->heap_size + pagesize;
+    }
+
+    int lo_seg = segment_index(lo_mem);
+    int hi_seg = segment_index(hi_mem+segment_size-1);
+    int vec_size = (hi_seg - lo_seg) * pagesize;
+    char* dvec = ik_mmap(vec_size);
+    bzero(dvec, vec_size);
+    pcb->dirty_vector_base = (unsigned int*) (dvec);
+    pcb->dirty_vector = (unsigned int*) (dvec - lo_seg * pagesize);
+    char* svec = ik_mmap(vec_size);
+    bzero(svec, vec_size);
+    pcb->segment_vector_base = (unsigned int*) (svec);
+    pcb->segment_vector = (unsigned int*) (svec - lo_seg * pagesize);
+    pcb->memory_base = (unsigned char*)(lo_seg * segment_size);
+    pcb->memory_end = (unsigned char*)(hi_seg * segment_size);
+    set_segment_type(pcb->heap_base-pagesize, 
+        pcb->heap_size+2*pagesize, 
+        mainheap_mt,
+        pcb);
+    set_segment_type(pcb->stack_base-pagesize, 
+        pcb->stack_size+2*pagesize, 
+        mainstack_mt,
+        pcb);
+  }
   /* initialize base rtd */
   {
     ikp s = ik_cstring_to_symbol("$base-rtd", pcb);
@@ -133,6 +272,7 @@ ikpcb* ik_make_pcb(){
 }
 
 void ik_delete_pcb(ikpcb* pcb){
+  assert(0);
   free(pcb);
 }
 
@@ -159,7 +299,7 @@ ik_alloc(ikpcb* pcb, int size){
     int new_size = (size > IK_HEAP_EXT_SIZE) ? size : IK_HEAP_EXT_SIZE;
     new_size += 2 * 4096;
     new_size = align_to_next_page(new_size);
-    ap = ik_mmap(new_size);
+    ap = ik_mmap_mixed(new_size, pcb);
     pcb->heap_base = ap;
     pcb->heap_size = new_size;
     pcb->allocation_redline = ap + new_size - 2 * 4096;
@@ -169,6 +309,8 @@ ik_alloc(ikpcb* pcb, int size){
   }
 }
 
+
+
 void ik_error(ikp args){
   fprintf(stderr, "Error: ");
   ik_fprint(stderr, args);
@@ -275,3 +417,59 @@ ikp
 ik_system(ikp str){
   return fix(system(string_data(str)));
 }
+
+static char*
+mtname(unsigned int n){
+  if(n == mainheap_type)  { return "HEAP_T"; }
+  if(n == mainstack_type) { return "STAK_T"; }
+  if(n == pointers_type)  { return "PTER_T"; }
+  if(n == data_type)      { return "DATA_T"; }
+  if(n == code_type)      { return "CODE_T"; }
+  if(n == hole_type)      { return "      "; }
+  return "WHAT_T";
+}
+
+ikp
+ik_dump_metatable(ikpcb* pcb){
+  unsigned int* s = pcb->segment_vector_base;
+  unsigned char* p = pcb->memory_base;
+  unsigned char* hi = pcb->memory_end;
+  while(p < hi){
+    unsigned int t = *s & type_mask;
+    unsigned char* start = p;
+    p += pagesize;
+    s++;
+    while((p < hi) && ((*s & type_mask) == t)){
+      p += pagesize;
+      s++;
+    }
+    fprintf(stderr, "0x%08x + %5d pages = %s\n", 
+        (int) start,
+        ((int)p-(int)start)/pagesize,
+        mtname(t));
+  }
+  return void_object;
+}
+
+ikp
+ik_dump_dirty_vector(ikpcb* pcb){
+  unsigned int* s = pcb->dirty_vector_base;
+  unsigned char* p = pcb->memory_base;
+  unsigned char* hi = pcb->memory_end;
+  while(p < hi){
+    unsigned int t = *s;
+    unsigned char* start = p;
+    p += pagesize;
+    s++;
+    while((p < hi) && (*s == t)){
+      p += pagesize;
+      s++;
+    }
+    fprintf(stderr, "0x%08x + %5d pages = 0x%08x\n", 
+        (int) start,
+        ((int)p-(int)start)/pagesize,
+        t);
+  }
+  return void_object;
+}
+

src/runtime/ikarus-weak-pairs.c

@@ -0,0 +1,37 @@
+
+#include "ikarus.h"
+
+ikp
+ikrt_weak_cons(ikp a, ikp d, ikpcb* pcb){
+  ikp ap = pcb->weak_pairs_ap;
+  ikp nap = ap + pair_size;
+  ikp p;
+  if(nap > pcb->weak_pairs_ep){
+    ikp mem = ik_mmap_typed(pagesize, weak_pairs_mt, pcb);
+    pcb->weak_pairs_ap = mem + pair_size;
+    pcb->weak_pairs_ep = mem + pagesize;
+    p = mem + pair_tag;
+  }
+  else {
+    pcb->weak_pairs_ap = nap;
+    p = ap + pair_tag;
+  }
+  ref(p, off_car) = a;
+  ref(p, off_cdr) = d;
+  return p;
+}
+
+ikp
+ikrt_is_weak_pair(ikp x, ikpcb* pcb){
+  if(tagof(x) != pair_tag){
+    return false_object;
+  }
+  unsigned int t = pcb->segment_vector[page_index(x)];
+  if((t & type_mask) == weak_pairs_type){
+    return true_object;
+  } else {
+    return false_object;
+  }
+}
+
+

src/runtime/ikarus.h

@@ -8,6 +8,41 @@ extern int total_allocated_pages;
 extern int total_malloced;
 extern int hash_table_count;
 
+#define cardsize 512
+#define cards_per_page 8
+
+#define old_gen_mask    0x00000007
+#define new_gen_mask    0x00000008
+#define gen_mask        0x0000000F
+#define new_gen_tag     0x00000008
+#define meta_dirty_mask 0x000000F0
+#define type_mask       0x00000F00
+#define scannable_mask  0x0000F000
+#define dealloc_mask    0x000F0000
+#define meta_dirty_shift 4
+
+#define hole_type       0x00000000
+#define mainheap_type   0x00000100
+#define mainstack_type  0x00000200
+#define pointers_type   0x00000300
+#define data_type       0x00000400
+#define code_type       0x00000500
+#define weak_pairs_type 0x00000600
+
+#define scannable_tag   0x00001000
+#define unscannable_tag 0x00000000
+
+#define dealloc_tag     0x00010000
+#define retain_tag      0x00000000
+
+#define hole_mt         (hole_type       | unscannable_tag | retain_tag)
+#define mainheap_mt     (mainheap_type   | unscannable_tag | retain_tag)
+#define mainstack_mt    (mainstack_type  | unscannable_tag | retain_tag)
+#define pointers_mt     (pointers_type   | scannable_tag   | dealloc_tag)
+#define data_mt         (data_type       | unscannable_tag | dealloc_tag)
+#define code_mt         (code_type       | scannable_tag   | dealloc_tag)
+#define weak_pairs_mt   (weak_pairs_type | scannable_tag   | dealloc_tag)
+
 
 static int 
 inthash(int key) {
@@ -37,30 +72,11 @@ typedef struct ikdl{ /* double-link */
   struct ikdl* next;
 } ikdl;
 
-
-#define ikcode_dead    ((unsigned int) 0x0000)
-#define ikcode_live    ((unsigned int) 0x0001)
-#define ikcode_queued  ((unsigned int) 0x0002 | ikcode_live)
-#define ikcode_scanned ((unsigned int) 0x0004 | ikcode_live)
-
-typedef struct ikcodes{ /* a doubly-linked list of code objects */
-  ikdl dl;
-  ikp code_object;
-  unsigned int attr;
-  ikp base;
-  int size;
-} ikcodes;
-
 typedef struct ikhashtables{
   ikp ht;
   struct ikhashtables* next;
 } ikhashtables;
 
-typedef struct{
-  ikcodes* link;
-  int padding; /* for 8-byte alignment */
-} ikcode_preheader;
-
 typedef struct ikbucket{
   ikp key;
   ikp val;
@@ -82,8 +98,13 @@ typedef struct {
   ikp   frame_redline;                /* offset = 16 */
   ikp   next_k;                       /* offset = 20 */
   void* system_stack;                 /* offset = 24 */
+  unsigned int* dirty_vector;         /* offset = 28 */
+
   /* the rest are not used by any scheme code        */
   /* they only support the runtime system (gc, etc.) */
+  unsigned int* segment_vector; 
+  ikp weak_pairs_ap;
+  ikp weak_pairs_ep;
   ikp   heap_base; 
   int   heap_size;
   ikp   stack_base;
@@ -92,6 +113,11 @@ typedef struct {
   ikdl codes;
   ikhashtables* hash_tables;
   ikoblist*   oblist;
+  unsigned int* dirty_vector_base;
+  unsigned int* segment_vector_base;
+  unsigned char* memory_base;
+  unsigned char* memory_end;
+  int collection_id;
 } ikpcb;
 
 
@@ -100,7 +126,13 @@ void* ik_malloc(int);
 void ik_free(void*, int);
 
 void* ik_mmap(int);
+void* ik_mmap_typed(int size, unsigned int type, ikpcb*);
+void* ik_mmap_ptr(int size, int gen, ikpcb*);
+void* ik_mmap_data(int size, int gen, ikpcb*);
+void* ik_mmap_code(int size, int gen, ikpcb*);
+void* ik_mmap_mixed(int size, ikpcb*);
 void ik_munmap(void*, int);
+void ik_munmap_from_segment(unsigned char*, int, ikpcb*);
 ikpcb* ik_make_pcb();
 void ik_delete_pcb(ikpcb*);
 
@@ -120,7 +152,9 @@ ikp ik_underflow_handler(ikpcb*);
 ikp ik_alloc(ikpcb* pcb, int size);
 #include "ikarus-data.h"
 #define wordsize 4
+#define wordshift 2
 #define pagesize 4096
 #define ik_eof_p(x) ((x) == ik_eof_object)
+#define page_index(x) (((unsigned int)(x)) >> pageshift)
 
 #endif