* Fixed bug in collecting bignums.

* time-it now displays the number of collections and bytes
  allocated.

bin/ikarus-collect.c

@@ -289,6 +289,18 @@ static void fix_new_pages(gc_t* gc);
 ikpcb* 
 ik_collect(int mem_req, ikpcb* pcb){
 
+  { /* ACCOUNTING */
+    int bytes = ((int)pcb->allocation_pointer) -
+                ((int)pcb->heap_base);
+    int minor = bytes + pcb->allocation_count_minor;
+    while(minor >= most_bytes_in_minor){
+      minor -= most_bytes_in_minor;
+      pcb->allocation_count_major++;
+    }
+    pcb->allocation_count_minor = minor;
+  }
+
+
   struct rusage t0, t1;
    
   getrusage(RUSAGE_SELF, &t0);
@@ -1027,9 +1039,9 @@ add_object_proc(gc_t* gc, ikp x)
       int len = ((unsigned int)fst) >> bignum_length_shift;
       int memreq = align(disp_bignum_data + len*wordsize);
       ikp new = gc_alloc_new_data(memreq, gen, gc) + vector_tag;
-      memcpy(new-vector_tag, x, memreq);
-      ref(x, 0) = forward_ptr;
-      ref(x, wordsize) = new;
+      memcpy(new-vector_tag, x-vector_tag, memreq);
+      ref(x, -vector_tag) = forward_ptr;
+      ref(x, wordsize-vector_tag) = new;
       return new;
     }
     else {

bin/ikarus-runtime.c

@@ -369,6 +369,18 @@ ik_alloc(ikpcb* pcb, int size){
       p->next = pcb->heap_pages;
       pcb->heap_pages = p;
     }
+
+    { /* ACCOUNTING */
+      int bytes = ((int)pcb->allocation_pointer) -
+                  ((int)pcb->heap_base);
+      int minor = bytes + pcb->allocation_count_minor;
+      while(minor >= most_bytes_in_minor){
+        minor -= most_bytes_in_minor;
+        pcb->allocation_count_major++;
+      }
+      pcb->allocation_count_minor = minor;
+    }
+
     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);
@@ -875,8 +887,21 @@ ikrt_stats_now(ikp t, ikpcb* pcb){
   ref(t, off_record_data + 3 * wordsize) = fix(r.ru_stime.tv_usec);
   ref(t, off_record_data + 4 * wordsize) = fix(s.tv_sec);
   ref(t, off_record_data + 5 * wordsize) = fix(s.tv_usec);
+  ref(t, off_record_data + 6 * wordsize) = fix(pcb->collection_id);
   return void_object;
 }
 
+ikp
+ikrt_bytes_allocated(ikpcb* pcb){
+  int bytes_in_heap = ((int) pcb->allocation_pointer) -
+                      ((int) pcb->heap_base);
+  int bytes = bytes_in_heap + pcb->allocation_count_minor;
+  return fix(bytes);
+}
 
 
+ikp
+ikrt_bytes_allocated_major(ikpcb* pcb){
+  return fix(pcb->allocation_count_major);
+}
+

bin/ikarus.h

@@ -12,6 +12,8 @@ extern int hash_table_count;
 #define cardsize 512
 #define cards_per_page 8
 
+#define most_bytes_in_minor 0x10000000
+
 #define old_gen_mask    0x00000007
 #define new_gen_mask    0x00000008
 #define gen_mask        0x0000000F
@@ -132,6 +134,8 @@ typedef struct ikpcb{
   unsigned char* memory_base;
   unsigned char* memory_end;
   int collection_id;
+  int allocation_count_minor;
+  int allocation_count_major;
   struct timeval collect_utime;
   struct timeval collect_stime;
   

src/libcompile.ss

@@ -4888,7 +4888,7 @@
           (for-each 
             (lambda (ls)
               (newline)
-              (for-each (lambda (x) (printf "    ~s\n" x)) (cdr ls)))
+              (for-each (lambda (x) (printf "    ~s\n" x)) ls))
             ls*)))
       (let ([code* (list*->code* 
                       (lambda (x)

src/libtimers.ss

@@ -1,15 +1,16 @@
 
 (let ()
   (define-record stats 
-    (user-secs user-usecs sys-secs sys-usecs real-secs real-usecs))
+    (user-secs user-usecs sys-secs sys-usecs real-secs real-usecs
+     collection-id))
 
   (define (mk-stats)
-    (make-stats #f #f #f #f #f #f))
+    (make-stats #f #f #f #f #f #f #f))
 
   (define (set-stats! t)
     (foreign-call "ikrt_stats_now" t))
 
-  (define (print-stats message t1 t0)
+  (define (print-stats message bytes t1 t0)
     (define (print-time msg secs usecs)
       (if (fx< usecs 0)
           (print-time msg (fx- secs 1) (fx+ usecs 1000000))
@@ -22,6 +23,13 @@
     (if message
         (printf "running stats for ~a:\n" message)
         (printf "running stats:\n"))
+    (let ([collections 
+           (fx- (stats-collection-id t1) (stats-collection-id t0))])
+      (case collections
+        [(0) (display "    no collections\n")]
+        [(1) (display "    1 collection\n")]
+        [else (printf "    ~a collections\n" collections)]))
+
     (print-time "user" 
         (fx- (stats-user-secs t1) (stats-user-secs t0))
         (fx- (stats-user-usecs t1) (stats-user-usecs t0)))
@@ -30,7 +38,8 @@
         (fx- (stats-sys-usecs t1) (stats-sys-usecs t0)))
     (print-time "real" 
         (fx- (stats-real-secs t1) (stats-real-secs t0))
-        (fx- (stats-real-usecs t1) (stats-real-usecs t0))))
+        (fx- (stats-real-usecs t1) (stats-real-usecs t0)))
+    (printf "    ~a bytes allocated\n" bytes))
 
   (define time-it
     (case-lambda
@@ -39,20 +48,36 @@
       [(proc message)
        (unless (procedure? proc)
          (error 'time-it "~s is not a procedure" proc))
-       (let* ([t1 (mk-stats)]
-              [t0 (mk-stats)])
+       (let* ([t0 (mk-stats)]
+              [t1 (mk-stats)]
+              [bytes-min (bytes-minor)]
+              [bytes-maj (bytes-major)])
          (set-stats! t0)
          (call-with-values proc
            (case-lambda
              [(v)
               (set-stats! t1)
-              (print-stats message t1 t0)
+              (print-stats message 
+                           (diff-bytes bytes-min bytes-maj 
+                              (bytes-minor) (bytes-major))
+                           t1 t0)
               v]
              [v*
               (set-stats! t1)
-              (print-stats message t1 t0)
+              (print-stats message 
+                           (diff-bytes bytes-min bytes-maj 
+                              (bytes-minor) (bytes-major))
+                           t1 t0)
               (apply values v*)])))]))
                        
+
+  (define (bytes-minor)
+    (foreign-call "ikrt_bytes_allocated"))
+  (define (bytes-major)
+    (foreign-call "ikrt_bytes_allocated_major"))
+  (define (diff-bytes mnr0 mjr0 mnr1 mjr1)
+    (+ (fx- mnr1 mnr0) (* (fx- mjr1 mjr0) #x10000000)))
+
   (primitive-set! 'time-it time-it)
 
 )