diff --exclude '*.[0-9]' --exclude '*.info' --exclude {arch} --exclude '*.in' --exclude '*.m4' --exclude 'config*' -urN guile-core--boehm-gc--1.9--patch-47/gcbench.scm guile-core--boehm-gc-hwn/gcbench.scm --- guile-core--boehm-gc--1.9--patch-47/gcbench.scm 1970-01-01 01:00:00.000000000 +0100 +++ guile-core--boehm-gc-hwn/gcbench.scm 2006-10-18 16:08:16.000000000 +0200 @@ -0,0 +1,210 @@ +; This is adapted from a benchmark written by John Ellis and Pete Kovac +; of Post Communications. +; It was modified by Hans Boehm of Silicon Graphics. +; It was translated into Scheme by William D Clinger of Northeastern Univ; +; the Scheme version uses (RUN-BENCHMARK ) +; Last modified 30 May 1997. +; +; This is no substitute for real applications. No actual application +; is likely to behave in exactly this way. However, this benchmark was +; designed to be more representative of real applications than other +; Java GC benchmarks of which we are aware. +; It attempts to model those properties of allocation requests that +; are important to current GC techniques. +; It is designed to be used either to obtain a single overall performance +; number, or to give a more detailed estimate of how collector +; performance varies with object lifetimes. It prints the time +; required to allocate and collect balanced binary trees of various +; sizes. Smaller trees result in shorter object lifetimes. Each cycle +; allocates roughly the same amount of memory. +; Two data structures are kept around during the entire process, so +; that the measured performance is representative of applications +; that maintain some live in-memory data. One of these is a tree +; containing many pointers. The other is a large array containing +; double precision floating point numbers. Both should be of comparable +; size. +; +; The results are only really meaningful together with a specification +; of how much memory was used. It is possible to trade memory for +; better time performance. This benchmark should be run in a 32 MB +; heap, though we don't currently know how to enforce that uniformly. + +; In the Java version, this routine prints the heap size and the amount +; of free memory. There is no portable way to do this in Scheme; each +; implementation needs its own version. + +(use-modules (ice-9 syncase)) + +(define (PrintDiagnostics) + (display " Total memory available= ???????? bytes") + (display " Free memory= ???????? bytes") + (newline)) + + + +(define (run-benchmark str thu) + (display str) + (thu)) +; Should we implement a Java class as procedures or hygienic macros? +; Take your pick. + +(define-syntax let-class + (syntax-rules + () + + ;; Put this rule first to implement a class using procedures. + ((let-class (((method . args) . method-body) ...) . body) + (let () (define (method . args) . method-body) ... . body)) + + + ;; Put this rule first to implement a class using hygienic macros. + ((let-class (((method . args) . method-body) ...) . body) + (letrec-syntax ((method (syntax-rules () ((method . args) (begin . method-body)))) + ...) + . body)) + + + )) + + +(define (gcbench kStretchTreeDepth) + + ; Nodes used by a tree of a given size + (define (TreeSize i) + (- (expt 2 (+ i 1)) 1)) + + ; Number of iterations to use for a given tree depth + (define (NumIters i) + (quotient (* 2 (TreeSize kStretchTreeDepth)) + (TreeSize i))) + + ; Parameters are determined by kStretchTreeDepth. + ; In Boehm's version the parameters were fixed as follows: + ; public static final int kStretchTreeDepth = 18; // about 16Mb + ; public static final int kLongLivedTreeDepth = 16; // about 4Mb + ; public static final int kArraySize = 500000; // about 4Mb + ; public static final int kMinTreeDepth = 4; + ; public static final int kMaxTreeDepth = 16; + ; In Larceny the storage numbers above would be 12 Mby, 3 Mby, 6 Mby. + + (let* ((kLongLivedTreeDepth (- kStretchTreeDepth 2)) + (kArraySize (* 4 (TreeSize kLongLivedTreeDepth))) + (kMinTreeDepth 4) + (kMaxTreeDepth kLongLivedTreeDepth)) + + ; Elements 3 and 4 of the allocated vectors are useless. + + (let-class (((make-node l r) + (let ((v (make-empty-node))) + (vector-set! v 0 l) + (vector-set! v 1 r) + v)) + ((make-empty-node) (make-vector 4 0)) + ((node.left node) (vector-ref node 0)) + ((node.right node) (vector-ref node 1)) + ((node.left-set! node x) (vector-set! node 0 x)) + ((node.right-set! node x) (vector-set! node 1 x))) + + ; Build tree top down, assigning to older objects. + (define (Populate iDepth thisNode) + (if (<= iDepth 0) + #f + (let ((iDepth (- iDepth 1))) + (node.left-set! thisNode (make-empty-node)) + (node.right-set! thisNode (make-empty-node)) + (Populate iDepth (node.left thisNode)) + (Populate iDepth (node.right thisNode))))) + + ; Build tree bottom-up + (define (MakeTree iDepth) + (if (<= iDepth 0) + (make-empty-node) + (make-node (MakeTree (- iDepth 1)) + (MakeTree (- iDepth 1))))) + + (define (TimeConstruction depth) + (let ((iNumIters (NumIters depth))) + (display (string-append "Creating " + (number->string iNumIters) + " trees of depth " + (number->string depth))) + (newline) + (run-benchmark "GCBench: Top down construction" + (lambda () + (do ((i 0 (+ i 1))) + ((>= i iNumIters)) + (Populate depth (make-empty-node))))) + (run-benchmark "GCBench: Bottom up construction" + (lambda () + (do ((i 0 (+ i 1))) + ((>= i iNumIters)) + (MakeTree depth)))))) + + (define (main) + (display "Garbage Collector Test") + (newline) + (display (string-append + " Stretching memory with a binary tree of depth " + (number->string kStretchTreeDepth))) + (newline) + (run-benchmark "GCBench: Main" + (lambda () + ; Stretch the memory space quickly + (MakeTree kStretchTreeDepth) + + ; Create a long lived object + (display (string-append + " Creating a long-lived binary tree of depth " + (number->string kLongLivedTreeDepth))) + (newline) + (let ((longLivedTree (make-empty-node))) + (Populate kLongLivedTreeDepth longLivedTree) + + ; Create long-lived array, filling half of it + (display (string-append + " Creating a long-lived array of " + (number->string kArraySize) + " inexact reals")) + (newline) + (let ((array (make-vector kArraySize 0.0))) + (do ((i 0 (+ i 1))) + ((>= i (quotient kArraySize 2))) + (vector-set! array i (/ 1.0 (exact->inexact i)))) + (PrintDiagnostics) + + (do ((d kMinTreeDepth (+ d 2))) + ((> d kMaxTreeDepth)) + (TimeConstruction d)) + + (if (or (eq? longLivedTree '()) + (let ((n (min 1000 + (- (quotient (vector-length array) + 2) + 1)))) + (not (= (vector-ref array n) + (/ 1.0 (exact->inexact +n)))))) + (begin (display "Failed") (newline))) + ; fake reference to LongLivedTree + ; and array + ; to keep them from being optimized away + )))) + (PrintDiagnostics)) + + (main)))) + +(define (gc-benchmark . rest) + (let ((k (if (null? rest) 18 (car rest)))) + (display "The garbage collector should touch about ") + (display (expt 2 (- k 13))) + (display " megabytes of heap storage.") + (newline) + (display "The use of more or less memory will skew the results.") + (newline) + (run-benchmark (string-append "GCBench" (number->string k)) + (lambda () (gcbench k))))) + + + +(gc-benchmark ) +(display (gc-stats)) diff --exclude '*.[0-9]' --exclude '*.info' --exclude {arch} --exclude '*.in' --exclude '*.m4' --exclude 'config*' -urN guile-core--boehm-gc--1.9--patch-47/libguile/ChangeLog guile-core--boehm-gc-hwn/libguile/ChangeLog --- guile-core--boehm-gc--1.9--patch-47/libguile/ChangeLog 2006-10-18 16:30:09.000000000 +0200 +++ guile-core--boehm-gc-hwn/libguile/ChangeLog 2006-10-18 14:16:24.000000000 +0200 @@ -1,3 +1,11 @@ +2006-10-18 Han-Wen Nienhuys + + * smob.h (SCM_NEWSMOB): use scm_tagged_cell + + * gc.c (scm_init_boehm_gc): new function. + + * inline.h (scm_tagged_cell): new function. + 2006-08-28 Neil Jerram * backtrace.c (scm_display_backtrace_with_highlights): Minor diff --exclude '*.[0-9]' --exclude '*.info' --exclude {arch} --exclude '*.in' --exclude '*.m4' --exclude 'config*' -urN guile-core--boehm-gc--1.9--patch-47/libguile/conv-integer.i.c guile-core--boehm-gc-hwn/libguile/conv-integer.i.c --- guile-core--boehm-gc--1.9--patch-47/libguile/conv-integer.i.c 2006-10-18 16:30:09.000000000 +0200 +++ guile-core--boehm-gc-hwn/libguile/conv-integer.i.c 2006-10-18 15:58:18.000000000 +0200 @@ -117,7 +117,7 @@ return scm_i_long2big (val); else { - SCM z = scm_double_cell (scm_tc16_big, 0, 0, 0); + SCM z = scm_i_masked_double_cell (scm_tc16_big, 0, 0, 0, scm_i_double_cell_descriptor_0111); mpz_init (SCM_I_BIG_MPZ (z)); if (val < 0) { diff --exclude '*.[0-9]' --exclude '*.info' --exclude {arch} --exclude '*.in' --exclude '*.m4' --exclude 'config*' -urN guile-core--boehm-gc--1.9--patch-47/libguile/conv-uinteger.i.c guile-core--boehm-gc-hwn/libguile/conv-uinteger.i.c --- guile-core--boehm-gc--1.9--patch-47/libguile/conv-uinteger.i.c 2006-10-18 16:30:09.000000000 +0200 +++ guile-core--boehm-gc-hwn/libguile/conv-uinteger.i.c 2006-10-18 16:01:17.000000000 +0200 @@ -101,7 +101,7 @@ return scm_i_ulong2big (val); else { - SCM z = scm_double_cell (scm_tc16_big, 0, 0, 0); + SCM z = scm_i_masked_double_cell (scm_tc16_big, 0, 0, 0, scm_i_double_cell_descriptor_0111); mpz_init (SCM_I_BIG_MPZ (z)); mpz_import (SCM_I_BIG_MPZ (z), 1, 1, sizeof (TYPE), 0, 0, &val); return z; diff --exclude '*.[0-9]' --exclude '*.info' --exclude {arch} --exclude '*.in' --exclude '*.m4' --exclude 'config*' -urN guile-core--boehm-gc--1.9--patch-47/libguile/debug.c guile-core--boehm-gc-hwn/libguile/debug.c --- guile-core--boehm-gc--1.9--patch-47/libguile/debug.c 2006-10-18 16:30:09.000000000 +0200 +++ guile-core--boehm-gc-hwn/libguile/debug.c 2006-10-18 15:39:23.000000000 +0200 @@ -501,7 +501,7 @@ SCM scm_make_debugobj (scm_t_debug_frame *frame) { - return scm_cell (scm_tc16_debugobj, (scm_t_bits) frame); + return scm_tagged_cell (scm_tc16_debugobj, (scm_t_bits) frame); } diff --exclude '*.[0-9]' --exclude '*.info' --exclude {arch} --exclude '*.in' --exclude '*.m4' --exclude 'config*' -urN guile-core--boehm-gc--1.9--patch-47/libguile/eval.c guile-core--boehm-gc-hwn/libguile/eval.c --- guile-core--boehm-gc--1.9--patch-47/libguile/eval.c 2006-10-18 16:30:09.000000000 +0200 +++ guile-core--boehm-gc-hwn/libguile/eval.c 2006-10-18 15:40:01.000000000 +0200 @@ -5543,6 +5543,11 @@ { SCM z; SCM closcar = scm_cons (code, SCM_EOL); + + /* + tricky: car of the object is also marked, although appears as + non-pointer + */ z = scm_cell (SCM_UNPACK (closcar) + scm_tc3_closure, (scm_t_bits) env); scm_remember_upto_here (closcar); return z; diff --exclude '*.[0-9]' --exclude '*.info' --exclude {arch} --exclude '*.in' --exclude '*.m4' --exclude 'config*' -urN guile-core--boehm-gc--1.9--patch-47/libguile/gc.c guile-core--boehm-gc-hwn/libguile/gc.c --- guile-core--boehm-gc--1.9--patch-47/libguile/gc.c 2006-10-18 16:30:09.000000000 +0200 +++ guile-core--boehm-gc-hwn/libguile/gc.c 2006-10-18 16:21:32.000000000 +0200 @@ -55,8 +55,6 @@ #include "libguile/gc.h" #include "libguile/dynwind.h" -#include - #ifdef GUILE_DEBUG_MALLOC #include "libguile/debug-malloc.h" #endif @@ -227,7 +225,7 @@ unsigned long scm_gc_malloc_collected; unsigned long scm_gc_ports_collected; unsigned long scm_gc_time_taken = 0; -static unsigned long t_before_gc; +unsigned long t_before_gc; unsigned long scm_gc_mark_time_taken = 0; unsigned long scm_gc_times = 0; unsigned long scm_gc_cells_swept = 0; @@ -256,8 +254,6 @@ SCM_SYMBOL (sym_protected_objects, "protected-objects"); - - /* Number of calls to SCM_NEWCELL since startup. */ unsigned scm_newcell_count; unsigned scm_newcell2_count; @@ -529,20 +525,6 @@ SCM scm_gc_protect_object (SCM obj) { - SCM handle; - - /* This critical section barrier will be replaced by a mutex. */ - /* njrev: Indeed; if my comment above is correct, there is the same - critsec/mutex inconsistency here. */ - SCM_CRITICAL_SECTION_START; - - handle = scm_hashq_create_handle_x (scm_protects, obj, scm_from_int (0)); - SCM_SETCDR (handle, scm_sum (SCM_CDR (handle), scm_from_int (1))); - - protected_obj_count ++; - - SCM_CRITICAL_SECTION_END; - return obj; } @@ -554,37 +536,6 @@ SCM scm_gc_unprotect_object (SCM obj) { - SCM handle; - - /* This critical section barrier will be replaced by a mutex. */ - /* njrev: and again. */ - SCM_CRITICAL_SECTION_START; - - if (scm_gc_running_p) - { - fprintf (stderr, "scm_unprotect_object called during GC.\n"); - abort (); - } - - handle = scm_hashq_get_handle (scm_protects, obj); - - if (scm_is_false (handle)) - { - fprintf (stderr, "scm_unprotect_object called on unprotected object\n"); - abort (); - } - else - { - SCM count = scm_difference (SCM_CDR (handle), scm_from_int (1)); - if (scm_is_eq (count, scm_from_int (0))) - scm_hashq_remove_x (scm_protects, obj); - else - SCM_SETCDR (handle, count); - } - protected_obj_count --; - - SCM_CRITICAL_SECTION_END; - return obj; } @@ -869,6 +820,62 @@ +GC_descr scm_i_tagged_cell_descriptor; +GC_descr scm_i_double_cell_descriptor_1111; +GC_descr scm_i_double_cell_descriptor_0111; /* tag in 1st word */ +GC_descr scm_i_double_cell_descriptor_0110; +GC_descr scm_i_double_cell_descriptor_0100; +GC_descr scm_i_double_cell_descriptor_0101; +GC_descr scm_i_double_cell_descriptor_0011; +GC_descr scm_i_double_cell_descriptor_0001; +GC_descr scm_i_double_cell_descriptor_0000; + +void +scm_init_boehm_gc () +{ + GC_word cell_bitmap[GC_BITMAP_SIZE(scm_t_cell)] = {0}; + GC_set_bit(cell_bitmap, GC_WORD_OFFSET(scm_t_cell, word_1)); + + scm_i_tagged_cell_descriptor = GC_make_descriptor(cell_bitmap, GC_WORD_LEN(scm_t_cell)); + + + /* double cells. */ + GC_word dcell_bitmap[GC_BITMAP_SIZE(scm_t_double_cell)] = {0}; + + scm_i_double_cell_descriptor_0000 = GC_make_descriptor(dcell_bitmap, GC_WORD_LEN(scm_t_double_cell)); + + GC_set_bit(dcell_bitmap, GC_WORD_OFFSET(scm_t_double_cell, word_3)); + scm_i_double_cell_descriptor_0001 = GC_make_descriptor(dcell_bitmap, GC_WORD_LEN(scm_t_double_cell)); + + GC_set_bit(dcell_bitmap, GC_WORD_OFFSET(scm_t_double_cell, word_2)); + scm_i_double_cell_descriptor_0011 = GC_make_descriptor(dcell_bitmap, GC_WORD_LEN(scm_t_double_cell)); + + GC_set_bit(dcell_bitmap, GC_WORD_OFFSET(scm_t_double_cell, word_1)); + scm_i_double_cell_descriptor_0111 = GC_make_descriptor(dcell_bitmap, GC_WORD_LEN(scm_t_double_cell)); + + GC_set_bit(dcell_bitmap, GC_WORD_OFFSET(scm_t_double_cell, word_0)); + scm_i_double_cell_descriptor_1111 = GC_make_descriptor(dcell_bitmap, GC_WORD_LEN(scm_t_double_cell)); + + + GC_word dcell2_bitmap[GC_BITMAP_SIZE(scm_t_double_cell)] = {0}; + GC_set_bit(dcell2_bitmap, GC_WORD_OFFSET(scm_t_double_cell, word_1)); + scm_i_double_cell_descriptor_0100 = GC_make_descriptor(dcell2_bitmap, GC_WORD_LEN(scm_t_double_cell)); + + GC_set_bit(dcell2_bitmap, GC_WORD_OFFSET(scm_t_double_cell, word_2)); + scm_i_double_cell_descriptor_0110 = GC_make_descriptor(dcell2_bitmap, GC_WORD_LEN(scm_t_double_cell)); + + GC_word dcell3_bitmap[GC_BITMAP_SIZE(scm_t_double_cell)] = {0}; + GC_set_bit(dcell3_bitmap, GC_WORD_OFFSET(scm_t_double_cell, word_1)); + GC_set_bit(dcell3_bitmap, GC_WORD_OFFSET(scm_t_double_cell, word_3)); + scm_i_double_cell_descriptor_0101 = GC_make_descriptor(dcell3_bitmap, GC_WORD_LEN(scm_t_double_cell)); + + + + + /* add further masks here. */ + +} + void scm_init_gc () { @@ -903,3 +910,6 @@ c-file-style: "gnu" End: */ + +#include "inline.ic" + diff --exclude '*.[0-9]' --exclude '*.info' --exclude {arch} --exclude '*.in' --exclude '*.m4' --exclude 'config*' -urN guile-core--boehm-gc--1.9--patch-47/libguile/gc.h guile-core--boehm-gc-hwn/libguile/gc.h --- guile-core--boehm-gc--1.9--patch-47/libguile/gc.h 2006-10-18 16:30:09.000000000 +0200 +++ guile-core--boehm-gc-hwn/libguile/gc.h 2006-10-18 16:05:45.000000000 +0200 @@ -27,6 +27,8 @@ #include "libguile/hooks.h" #include "libguile/threads.h" +#include + typedef struct scm_t_cell { @@ -34,6 +36,14 @@ SCM word_1; } scm_t_cell; +typedef struct scm_t_double_cell +{ + SCM word_0; + SCM word_1; + SCM word_2; + SCM word_3; +} scm_t_double_cell; + /* Cray machines have pointers that are incremented once for each * word, rather than each byte, the 3 most significant bits encode the * byte within the word. The following macros deal with this by @@ -207,6 +217,19 @@ SCM_API SCM scm_set_debug_cell_accesses_x (SCM flag); +SCM_API SCM scm_cell (scm_t_bits car, scm_t_bits cdr); +SCM_API SCM scm_tagged_cell (scm_t_bits car, scm_t_bits cdr); +SCM_API SCM scm_tagged_cell2 (scm_t_bits car, scm_t_bits cdr); +SCM_API SCM scm_double_cell (scm_t_bits car, scm_t_bits cbr, + scm_t_bits ccr, scm_t_bits cdr); + +SCM_API SCM scm_i_masked_double_cell (scm_t_bits car, scm_t_bits cbr, + scm_t_bits ccr, scm_t_bits cdr, GC_descr mask); + +SCM_API SCM scm_i_masked_double_cell2 (scm_t_bits car, scm_t_bits cbr, + scm_t_bits ccr, scm_t_bits cdr, GC_descr mask); + + SCM_API SCM scm_object_address (SCM obj); SCM_API SCM scm_gc_enable (void); SCM_API SCM scm_gc_disable (void); @@ -277,6 +300,7 @@ SCM_API int scm_init_storage (void); SCM_API void *scm_get_stack_base (void); SCM_API void scm_init_gc (void); +SCM_API void scm_init_boehm_gc (void); #if SCM_ENABLE_DEPRECATED == 1 diff --exclude '*.[0-9]' --exclude '*.info' --exclude {arch} --exclude '*.in' --exclude '*.m4' --exclude 'config*' -urN guile-core--boehm-gc--1.9--patch-47/libguile/init.c guile-core--boehm-gc-hwn/libguile/init.c --- guile-core--boehm-gc--1.9--patch-47/libguile/init.c 2006-10-18 16:30:09.000000000 +0200 +++ guile-core--boehm-gc-hwn/libguile/init.c 2006-10-18 14:04:23.000000000 +0200 @@ -417,6 +417,7 @@ "but doesn't seem to here.\n"); } + scm_init_boehm_gc (); scm_storage_prehistory (); scm_threads_prehistory (base); scm_ports_prehistory (); diff --exclude '*.[0-9]' --exclude '*.info' --exclude {arch} --exclude '*.in' --exclude '*.m4' --exclude 'config*' -urN guile-core--boehm-gc--1.9--patch-47/libguile/inline.h guile-core--boehm-gc-hwn/libguile/inline.h --- guile-core--boehm-gc--1.9--patch-47/libguile/inline.h 2006-10-18 16:30:09.000000000 +0200 +++ guile-core--boehm-gc-hwn/libguile/inline.h 2006-10-18 16:18:42.000000000 +0200 @@ -39,15 +39,21 @@ #include +#include -SCM_API SCM scm_cell (scm_t_bits car, scm_t_bits cdr); -SCM_API SCM scm_double_cell (scm_t_bits car, scm_t_bits cbr, - scm_t_bits ccr, scm_t_bits cdr); +extern GC_descr scm_i_tagged_cell_descriptor; +extern GC_descr scm_i_double_cell_descriptor_1111; +extern GC_descr scm_i_double_cell_descriptor_0111; /* tag in 1st word */ +extern GC_descr scm_i_double_cell_descriptor_0011; +extern GC_descr scm_i_double_cell_descriptor_0110; +extern GC_descr scm_i_double_cell_descriptor_0100; +extern GC_descr scm_i_double_cell_descriptor_0101; +extern GC_descr scm_i_double_cell_descriptor_0001; +extern GC_descr scm_i_double_cell_descriptor_0000; -SCM_API SCM scm_array_handle_ref (scm_t_array_handle *h, ssize_t pos); -SCM_API void scm_array_handle_set (scm_t_array_handle *h, ssize_t pos, SCM val); +#if 1 #if defined SCM_C_INLINE || defined SCM_INLINE_C_INCLUDING_INLINE_H /* either inlining, or being included from inline.c. We use (and @@ -55,148 +61,14 @@ introduce any extraneous symbols into the public namespace. We only need SCM_C_INLINE to be seen publically . */ -extern unsigned scm_newcell2_count; -extern unsigned scm_newcell_count; -#if defined SCM_C_INLINE && ! defined SCM_INLINE_C_INCLUDING_INLINE_H -/* definitely inlining */ -#ifdef __GNUC__ -extern +#include "inline.ic" #else -static -#endif -SCM_C_INLINE -#endif - -SCM -scm_cell (scm_t_bits car, scm_t_bits cdr) -{ - SCM cell = SCM_PACK ((scm_t_bits) (GC_MALLOC (sizeof (scm_t_cell)))); - - /* Initialize the type slot last so that the cell is ignored by the GC - until it is completely initialized. This is only relevant when the GC - can actually run during this code, which it can't since the GC only runs - when all other threads are stopped. */ - SCM_GC_SET_CELL_WORD (cell, 1, cdr); - SCM_GC_SET_CELL_WORD (cell, 0, car); - - return cell; -} - -#if defined SCM_C_INLINE && ! defined SCM_INLINE_C_INCLUDING_INLINE_H -/* definitely inlining */ -#ifdef __GNUC__ -extern -#else -static -#endif -SCM_C_INLINE -#endif -SCM -scm_double_cell (scm_t_bits car, scm_t_bits cbr, - scm_t_bits ccr, scm_t_bits cdr) -{ - SCM z; - - z = SCM_PACK ((scm_t_bits) (GC_malloc (2 * sizeof (scm_t_cell)))); - /* Initialize the type slot last so that the cell is ignored by the - GC until it is completely initialized. This is only relevant - when the GC can actually run during this code, which it can't - since the GC only runs when all other threads are stopped. - */ - SCM_GC_SET_CELL_WORD (z, 1, cbr); - SCM_GC_SET_CELL_WORD (z, 2, ccr); - SCM_GC_SET_CELL_WORD (z, 3, cdr); - SCM_GC_SET_CELL_WORD (z, 0, car); - - /* When this function is inlined, it's possible that the last - SCM_GC_SET_CELL_WORD above will be adjacent to a following - initialization of z. E.g., it occurred in scm_make_real. GCC - from around version 3 (e.g., certainly 3.2) began taking - advantage of strict C aliasing rules which say that it's OK to - interchange the initialization above and the one below when the - pointer types appear to differ sufficiently. We don't want that, - of course. GCC allows this behaviour to be disabled with the - -fno-strict-aliasing option, but would also need to be supplied - by Guile users. Instead, the following statements prevent the - reordering. - */ -#ifdef __GNUC__ - __asm__ volatile ("" : : : "memory"); -#else - /* portable version, just in case any other compiler does the same - thing. */ - scm_remember_upto_here_1 (z); -#endif - return z; -} +/*nothing.*/ + +#endif /* SCM_C_INLINE || defined SCM_INLINE_C_INCLUDING_INLINE_H */ +#endif /*0*/ -#if defined SCM_C_INLINE && ! defined SCM_INLINE_C_INCLUDING_INLINE_H -/* definitely inlining */ -#ifdef __GNUC__ -extern -#else -static -#endif -SCM_C_INLINE #endif -SCM -scm_array_handle_ref (scm_t_array_handle *h, ssize_t p) -{ - return h->ref (h, p); -} - -#if defined SCM_C_INLINE && ! defined SCM_INLINE_C_INCLUDING_INLINE_H -/* definitely inlining */ -#ifdef __GNUC__ -extern -#else -static -#endif -SCM_C_INLINE -#endif -void -scm_array_handle_set (scm_t_array_handle *h, ssize_t p, SCM v) -{ - h->set (h, p, v); -} - -#if defined SCM_C_INLINE && ! defined SCM_INLINE_C_INCLUDING_INLINE_H -/* definitely inlining */ -#ifdef __GNUC__ -extern -#else -static -#endif -SCM_C_INLINE -#endif -int -scm_is_pair (SCM x) -{ - /* The following "workaround_for_gcc_295" avoids bad code generated by - i386 gcc 2.95.4 (the Debian packaged 2.95.4-24 at least). - - Under the default -O2 the inlined SCM_I_CONSP test gets "optimized" so - the fetch of the tag word from x is done before confirming it's a - non-immediate (SCM_NIMP). Needless to say that bombs badly if x is a - immediate. This was seen to afflict scm_srfi1_split_at and something - deep in the bowels of ceval(). In both cases segvs resulted from - deferencing a random immediate value. srfi-1.test exposes the problem - through a short list, the immediate being SCM_EOL in that case. - Something in syntax.test exposed the ceval() problem. - - Just "volatile SCM workaround_for_gcc_295 = lst" is enough to avoid the - problem, without even using that variable. The "w=w" is just to - prevent a warning about it being unused. - */ -#if defined (__GNUC__) && __GNUC__ == 2 && __GNUC_MINOR__ == 95 - volatile SCM workaround_for_gcc_295 = x; - workaround_for_gcc_295 = workaround_for_gcc_295; -#endif - - return SCM_I_CONSP (x); -} -#endif -#endif diff --exclude '*.[0-9]' --exclude '*.info' --exclude {arch} --exclude '*.in' --exclude '*.m4' --exclude 'config*' -urN guile-core--boehm-gc--1.9--patch-47/libguile/inline.ic guile-core--boehm-gc-hwn/libguile/inline.ic --- guile-core--boehm-gc--1.9--patch-47/libguile/inline.ic 1970-01-01 01:00:00.000000000 +0100 +++ guile-core--boehm-gc-hwn/libguile/inline.ic 2006-10-18 16:13:15.000000000 +0200 @@ -0,0 +1,229 @@ + +/* -*-c-*- */ +#ifndef INLINE_C_FILE +#define INLINE_C_FILE + +#ifdef INLINE_H_INLINE +#undef INLINE_H_INLINE +#endif + + +#if defined SCM_C_INLINE && ! defined SCM_INLINE_C_INCLUDING_INLINE_H + /* definitely inlining */ + #ifdef __GNUC__ + #define INLINE_H_INLINE extern SCM_C_INLINE + #else + #define INLINE_H_INLINE static SCM_C_INLINE + #endif +#else + #define INLINE_H_INLINE SCM_C_INLINE +#endif /* define SCM_C_INLINE && ! defined */ + + +extern unsigned scm_newcell2_count; +extern unsigned scm_newcell_count; + +INLINE_H_INLINE + +SCM +scm_cell (scm_t_bits car, scm_t_bits cdr) +{ + SCM cell = SCM_PACK ((scm_t_bits) (GC_MALLOC (sizeof (scm_t_cell)))); + + /* Initialize the type slot last so that the cell is ignored by the GC + until it is completely initialized. This is only relevant when the GC + can actually run during this code, which it can't since the GC only runs + when all other threads are stopped. */ + SCM_GC_SET_CELL_WORD (cell, 1, cdr); + SCM_GC_SET_CELL_WORD (cell, 0, car); + + return cell; +} + + + +INLINE_H_INLINE + +SCM +scm_tagged_cell (scm_t_bits car, scm_t_bits cdr) +{ + SCM cell = SCM_PACK ((scm_t_bits) (GC_malloc_explicitly_typed (sizeof (scm_t_cell), + scm_i_tagged_cell_descriptor))); + + /* Initialize the type slot last so that the cell is ignored by the GC + until it is completely initialized. This is only relevant when the GC + can actually run during this code, which it can't since the GC only runs + when all other threads are stopped. */ + SCM_GC_SET_CELL_WORD (cell, 1, cdr); + SCM_GC_SET_CELL_WORD (cell, 0, car); + + return cell; +} + + +/*debug*/ +INLINE_H_INLINE + +SCM +scm_tagged_cell2 (scm_t_bits car, scm_t_bits cdr) +{ + return scm_tagged_cell (car,cdr); +} + +/*debug*/ +INLINE_H_INLINE + +SCM +scm_i_masked_double_cell2 (scm_t_bits car, scm_t_bits cbr, + scm_t_bits ccr, scm_t_bits cdr, GC_descr mask) +{ + + SCM z; + z = SCM_PACK ((scm_t_bits) (GC_MALLOC (2 * sizeof (scm_t_cell) + ))); + + /* Initialize the type slot last so that the cell is ignored by the + GC until it is completely initialized. This is only relevant + when the GC can actually run during this code, which it can't + since the GC only runs when all other threads are stopped. + */ + SCM_GC_SET_CELL_WORD (z, 1, cbr); + SCM_GC_SET_CELL_WORD (z, 2, ccr); + SCM_GC_SET_CELL_WORD (z, 3, cdr); + SCM_GC_SET_CELL_WORD (z, 0, car); + +#ifdef __GNUC__ + __asm__ volatile ("" : : : "memory"); +#else + /* portable version, just in case any other compiler does the same + thing. */ + scm_remember_upto_here_1 (z); +#endif + return z; +} + +INLINE_H_INLINE + +SCM +scm_i_masked_double_cell (scm_t_bits car, scm_t_bits cbr, + scm_t_bits ccr, scm_t_bits cdr, GC_descr mask) +{ + SCM z; + z = SCM_PACK ((scm_t_bits) (GC_malloc_explicitly_typed (2 * sizeof (scm_t_cell), + mask + ))); + + /* Initialize the type slot last so that the cell is ignored by the + GC until it is completely initialized. This is only relevant + when the GC can actually run during this code, which it can't + since the GC only runs when all other threads are stopped. + */ + SCM_GC_SET_CELL_WORD (z, 1, cbr); + SCM_GC_SET_CELL_WORD (z, 2, ccr); + SCM_GC_SET_CELL_WORD (z, 3, cdr); + SCM_GC_SET_CELL_WORD (z, 0, car); + + /* When this function is inlined, it's possible that the last + SCM_GC_SET_CELL_WORD above will be adjacent to a following + initialization of z. E.g., it occurred in scm_make_real. GCC + from around version 3 (e.g., certainly 3.2) began taking + advantage of strict C aliasing rules which say that it's OK to + interchange the initialization above and the one below when the + pointer types appear to differ sufficiently. We don't want that, + of course. GCC allows this behaviour to be disabled with the + -fno-strict-aliasing option, but would also need to be supplied + by Guile users. Instead, the following statements prevent the + reordering. + */ +#ifdef __GNUC__ + __asm__ volatile ("" : : : "memory"); +#else + /* portable version, just in case any other compiler does the same + thing. */ + scm_remember_upto_here_1 (z); +#endif + + return z; +} + +INLINE_H_INLINE + +SCM +scm_array_handle_ref (scm_t_array_handle *h, ssize_t p) +{ + return h->ref (h, p); +} + +INLINE_H_INLINE + +SCM +scm_double_cell (scm_t_bits car, scm_t_bits cbr, + scm_t_bits ccr, scm_t_bits cdr) +{ + SCM z; + z = SCM_PACK ((scm_t_bits) (GC_MALLOC (2 * sizeof (scm_t_cell)))); + + /* Initialize the type slot last so that the cell is ignored by the + GC until it is completely initialized. This is only relevant + when the GC can actually run during this code, which it can't + since the GC only runs when all other threads are stopped. + */ + SCM_GC_SET_CELL_WORD (z, 1, cbr); + SCM_GC_SET_CELL_WORD (z, 2, ccr); + SCM_GC_SET_CELL_WORD (z, 3, cdr); + SCM_GC_SET_CELL_WORD (z, 0, car); + +#ifdef __GNUC__ + __asm__ volatile ("" : : : "memory"); +#else + /* portable version, just in case any other compiler does the same + thing. */ + scm_remember_upto_here_1 (z); +#endif + return z; +} + + +INLINE_H_INLINE + +void +scm_array_handle_set (scm_t_array_handle *h, ssize_t p, SCM v) +{ + h->set (h, p, v); +} + + +INLINE_H_INLINE + +int +scm_is_pair (SCM x) +{ + /* The following "workaround_for_gcc_295" avoids bad code generated by + i386 gcc 2.95.4 (the Debian packaged 2.95.4-24 at least). + + Under the default -O2 the inlined SCM_I_CONSP test gets "optimized" so + the fetch of the tag word from x is done before confirming it's a + non-immediate (SCM_NIMP). Needless to say that bombs badly if x is a + immediate. This was seen to afflict scm_srfi1_split_at and something + deep in the bowels of ceval(). In both cases segvs resulted from + deferencing a random immediate value. srfi-1.test exposes the problem + through a short list, the immediate being SCM_EOL in that case. + Something in syntax.test exposed the ceval() problem. + + Just "volatile SCM workaround_for_gcc_295 = lst" is enough to avoid the + problem, without even using that variable. The "w=w" is just to + prevent a warning about it being unused. + */ +#if defined (__GNUC__) && __GNUC__ == 2 && __GNUC_MINOR__ == 95 + volatile SCM workaround_for_gcc_295 = x; + workaround_for_gcc_295 = workaround_for_gcc_295; +#endif + + return SCM_I_CONSP (x); +} + + +#undef INLINE_H_INLINE + + +#endif /* INLINE_C_FILE */ diff --exclude '*.[0-9]' --exclude '*.info' --exclude {arch} --exclude '*.in' --exclude '*.m4' --exclude 'config*' -urN guile-core--boehm-gc--1.9--patch-47/libguile/numbers.c guile-core--boehm-gc-hwn/libguile/numbers.c --- guile-core--boehm-gc--1.9--patch-47/libguile/numbers.c 2006-10-18 16:30:09.000000000 +0200 +++ guile-core--boehm-gc-hwn/libguile/numbers.c 2006-10-18 16:01:31.000000000 +0200 @@ -160,7 +160,7 @@ scm_i_mkbig () { /* Return a newly created bignum. */ - SCM z = scm_double_cell (scm_tc16_big, 0, 0, 0); + SCM z = scm_i_masked_double_cell2 (scm_tc16_big, 0, 0, 0, scm_i_double_cell_descriptor_0111); mpz_init (SCM_I_BIG_MPZ (z)); return z; } @@ -169,7 +169,7 @@ scm_i_long2big (long x) { /* Return a newly created bignum initialized to X. */ - SCM z = scm_double_cell (scm_tc16_big, 0, 0, 0); + SCM z = scm_i_masked_double_cell (scm_tc16_big, 0, 0, 0, scm_i_double_cell_descriptor_0111); mpz_init_set_si (SCM_I_BIG_MPZ (z), x); return z; } @@ -178,7 +178,7 @@ scm_i_ulong2big (unsigned long x) { /* Return a newly created bignum initialized to X. */ - SCM z = scm_double_cell (scm_tc16_big, 0, 0, 0); + SCM z = scm_i_masked_double_cell (scm_tc16_big, 0, 0, 0, scm_i_double_cell_descriptor_0111); mpz_init_set_ui (SCM_I_BIG_MPZ (z), x); return z; } @@ -187,7 +187,7 @@ scm_i_clonebig (SCM src_big, int same_sign_p) { /* Copy src_big's value, negate it if same_sign_p is false, and return. */ - SCM z = scm_double_cell (scm_tc16_big, 0, 0, 0); + SCM z = scm_i_masked_double_cell (scm_tc16_big, 0, 0, 0, scm_i_double_cell_descriptor_0111); mpz_init_set (SCM_I_BIG_MPZ (z), SCM_I_BIG_MPZ (src_big)); if (!same_sign_p) mpz_neg (SCM_I_BIG_MPZ (z), SCM_I_BIG_MPZ (z)); @@ -208,7 +208,7 @@ scm_i_dbl2big (double d) { /* results are only defined if d is an integer */ - SCM z = scm_double_cell (scm_tc16_big, 0, 0, 0); + SCM z = scm_i_masked_double_cell (scm_tc16_big, 0, 0, 0, scm_i_double_cell_descriptor_0111); mpz_init_set_d (SCM_I_BIG_MPZ (z), d); return z; } @@ -338,7 +338,7 @@ } { - SCM z = scm_double_cell (scm_tc16_big, 0, 0, 0); + SCM z = scm_i_masked_double_cell (scm_tc16_big, 0, 0, 0, scm_i_double_cell_descriptor_0111); mpz_init_set (SCM_I_BIG_MPZ (z), b); return z; } @@ -424,10 +424,12 @@ } /* No, it's a proper fraction. + */ - return scm_double_cell (scm_tc16_fraction, - SCM_UNPACK (numerator), - SCM_UNPACK (denominator), 0); + return scm_i_masked_double_cell (scm_tc16_fraction, + SCM_UNPACK (numerator), + SCM_UNPACK (denominator), 0, + scm_i_double_cell_descriptor_0110); } #undef FUNC_NAME @@ -5886,7 +5888,7 @@ SCM scm_from_double (double val) { - SCM z = scm_double_cell (scm_tc16_real, 0, 0, 0); + SCM z = scm_i_masked_double_cell (scm_tc16_real, 0, 0, 0, scm_i_double_cell_descriptor_0000); SCM_REAL_VALUE (z) = val; return z; } diff --exclude '*.[0-9]' --exclude '*.info' --exclude {arch} --exclude '*.in' --exclude '*.m4' --exclude 'config*' -urN guile-core--boehm-gc--1.9--patch-47/libguile/procs.c guile-core--boehm-gc-hwn/libguile/procs.c --- guile-core--boehm-gc--1.9--patch-47/libguile/procs.c 2006-10-18 16:30:09.000000000 +0200 +++ guile-core--boehm-gc-hwn/libguile/procs.c 2006-10-18 16:04:32.000000000 +0200 @@ -61,7 +61,7 @@ } entry = scm_subr_table_size; - z = scm_cell ((entry << 8) + type, (scm_t_bits) fcn); + z = scm_tagged_cell ((entry << 8) + type, (scm_t_bits) fcn); scm_subr_table[entry].handle = z; scm_subr_table[entry].name = scm_from_locale_symbol (name); scm_subr_table[entry].generic = 0; @@ -122,7 +122,7 @@ for (i = 0; i < len; ++i) base [i] = SCM_UNPACK (SCM_UNSPECIFIED); - s = scm_cell (SCM_MAKE_CCLO_TAG (len), (scm_t_bits) base); + s = scm_tagged_cell (SCM_MAKE_CCLO_TAG (len), (scm_t_bits) base); SCM_SET_CCLO_SUBR (s, proc); return s; } @@ -282,9 +282,9 @@ { SCM_VALIDATE_PROC (1, procedure); SCM_VALIDATE_PROC (2, setter); - return scm_double_cell (scm_tc7_pws, - SCM_UNPACK (procedure), - SCM_UNPACK (setter), 0); + return scm_i_masked_double_cell (scm_tc7_pws, + SCM_UNPACK (procedure), + SCM_UNPACK (setter), 0, scm_i_double_cell_descriptor_0110); } #undef FUNC_NAME diff --exclude '*.[0-9]' --exclude '*.info' --exclude {arch} --exclude '*.in' --exclude '*.m4' --exclude 'config*' -urN guile-core--boehm-gc--1.9--patch-47/libguile/smob.h guile-core--boehm-gc-hwn/libguile/smob.h --- guile-core--boehm-gc--1.9--patch-47/libguile/smob.h 2006-10-18 16:30:09.000000000 +0200 +++ guile-core--boehm-gc-hwn/libguile/smob.h 2006-10-18 15:50:18.000000000 +0200 @@ -61,7 +61,7 @@ z = (scm_smobs[_smobnum].mark \ ? scm_i_new_smob_with_mark_proc ((tc), (scm_t_bits)(data), \ 0, 0) \ - : scm_cell (tc, (scm_t_bits)(data))); \ + : scm_tagged_cell (tc, (scm_t_bits)(data))); \ if (scm_smobs[_smobnum].free) \ { \ GC_finalization_proc _prev_finalizer; \ @@ -99,8 +99,8 @@ (scm_t_bits)(data2), \ (scm_t_bits)(data3)) \ : scm_double_cell ((tc), (scm_t_bits)(data1), \ - (scm_t_bits)(data2), \ - (scm_t_bits)(data3))); \ + (scm_t_bits)(data2), \ + (scm_t_bits)(data3))); \ if (scm_smobs[_smobnum].free) \ { \ GC_finalization_proc _prev_finalizer; \ diff --exclude '*.[0-9]' --exclude '*.info' --exclude {arch} --exclude '*.in' --exclude '*.m4' --exclude 'config*' -urN guile-core--boehm-gc--1.9--patch-47/libguile/strings.c guile-core--boehm-gc-hwn/libguile/strings.c --- guile-core--boehm-gc--1.9--patch-47/libguile/strings.c 2006-10-18 16:30:09.000000000 +0200 +++ guile-core--boehm-gc-hwn/libguile/strings.c 2006-10-18 16:18:42.000000000 +0200 @@ -110,15 +110,17 @@ if (len <= STRINGBUF_MAX_INLINE_LEN-1) { - return scm_double_cell (STRINGBUF_TAG | STRINGBUF_F_INLINE | (len << 16), - 0, 0, 0); + return scm_i_masked_double_cell (STRINGBUF_TAG | STRINGBUF_F_INLINE | (len << 16), + 0, 0, 0, + scm_i_double_cell_descriptor_0100); } else { char *mem = scm_gc_malloc_pointerless (len + 1, "string"); mem[len] = '\0'; - return scm_double_cell (STRINGBUF_TAG, (scm_t_bits) mem, - (scm_t_bits) len, (scm_t_bits) 0); + return scm_i_masked_double_cell (STRINGBUF_TAG, (scm_t_bits) mem, + (scm_t_bits) len, (scm_t_bits) 0, + scm_i_double_cell_descriptor_0100); } } @@ -129,8 +131,10 @@ { scm_gc_register_collectable_memory (str, len + 1, "stringbuf"); - return scm_double_cell (STRINGBUF_TAG, (scm_t_bits) str, - (scm_t_bits) len, (scm_t_bits) 0); + return scm_i_masked_double_cell (STRINGBUF_TAG, (scm_t_bits) str, + (scm_t_bits) len, (scm_t_bits) 0, + scm_i_double_cell_descriptor_0100 + ); } SCM @@ -430,8 +434,10 @@ SCM buf = make_stringbuf (len); memcpy (STRINGBUF_CHARS (buf), name, len); - return scm_double_cell (scm_tc7_symbol | flags, SCM_UNPACK (buf), - (scm_t_bits) hash, SCM_UNPACK (props)); + return scm_i_masked_double_cell (scm_tc7_symbol | flags, SCM_UNPACK (buf), + (scm_t_bits) hash, SCM_UNPACK (props), + scm_i_double_cell_descriptor_0101 + ); } /* Return a new symbol that uses the LEN bytes pointed to by NAME as its diff --exclude '*.[0-9]' --exclude '*.info' --exclude {arch} --exclude '*.in' --exclude '*.m4' --exclude 'config*' -urN guile-core--boehm-gc--1.9--patch-47/libguile/unif.h guile-core--boehm-gc-hwn/libguile/unif.h --- guile-core--boehm-gc--1.9--patch-47/libguile/unif.h 2006-10-18 16:30:09.000000000 +0200 +++ guile-core--boehm-gc-hwn/libguile/unif.h 2006-10-18 15:00:12.000000000 +0200 @@ -88,6 +88,13 @@ void *writable_elements; } scm_t_array_handle; +/* + proto for inline. + */ +SCM_API SCM scm_array_handle_ref (scm_t_array_handle *h, ssize_t pos); +SCM_API void scm_array_handle_set (scm_t_array_handle *h, ssize_t pos, SCM val); + + SCM_API void scm_array_get_handle (SCM array, scm_t_array_handle *h); SCM_API size_t scm_array_handle_rank (scm_t_array_handle *h); SCM_API scm_t_array_dim *scm_array_handle_dims (scm_t_array_handle *h); diff --exclude '*.[0-9]' --exclude '*.info' --exclude {arch} --exclude '*.in' --exclude '*.m4' --exclude 'config*' -urN guile-core--boehm-gc--1.9--patch-47/libguile/variable.c guile-core--boehm-gc-hwn/libguile/variable.c --- guile-core--boehm-gc--1.9--patch-47/libguile/variable.c 2006-10-18 16:30:09.000000000 +0200 +++ guile-core--boehm-gc-hwn/libguile/variable.c 2006-10-18 15:39:23.000000000 +0200 @@ -44,7 +44,7 @@ static SCM make_variable (SCM init) { - return scm_cell (scm_tc7_variable, SCM_UNPACK (init)); + return scm_tagged_cell (scm_tc7_variable, SCM_UNPACK (init)); } SCM_DEFINE (scm_make_variable, "make-variable", 1, 0, 0, diff --exclude '*.[0-9]' --exclude '*.info' --exclude {arch} --exclude '*.in' --exclude '*.m4' --exclude 'config*' -urN guile-core--boehm-gc--1.9--patch-47/libguile/vectors.c guile-core--boehm-gc-hwn/libguile/vectors.c --- guile-core--boehm-gc--1.9--patch-47/libguile/vectors.c 2006-10-18 16:30:09.000000000 +0200 +++ guile-core--boehm-gc-hwn/libguile/vectors.c 2006-10-18 15:39:23.000000000 +0200 @@ -348,7 +348,7 @@ else base = NULL; - v = scm_cell ((k << 8) | scm_tc7_vector, (scm_t_bits) base); + v = scm_tagged_cell ((k << 8) | scm_tc7_vector, (scm_t_bits) base); scm_remember_upto_here_1 (fill); return v;