gengc and relocation fixes; inference cleanups

diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt
index f35bff470ca130cbd6da5e59068c95ea90db2bc4..db8266ccce0a6fb31d5f5672c73bd423a9b49e69 100644 (file)
--- a/TODO.FACTOR.txt
+++ b/TODO.FACTOR.txt
@@ -6,6 +6,7 @@
 <magnus--> http://www.caddr.com/macho/archives/sbcl-devel/2005-3/4764.html\r
 <magnus--> http://clozure.com/cgi-bin/viewcvs.cgi/ccl/lisp-kernel/lisp-exceptions.c?rev=1.9&content-type=text/vnd.viewcvs-markup\r
 \r
+\r
 - alien-global type wrong\r
 - simplifier:\r
   - dead loads not optimized out\r
@@ -15,7 +16,6 @@
 - tiled window manager\r
 - c primitive arrays: or just specialized arrays\r
   float, complex, byte, char, cell...\r
-- generational gc\r
 - add a socket timeout\r
 - virtual hosts\r
 - keep alive\r

diff --git a/library/alien/compiler.factor b/library/alien/compiler.factor
index 61fdd2944756b68fdbcaf431de14a648b6b8d0e2..8e58366f217dc6d89c33c5b6b708de25d2c77ddb 100644 (file)
--- a/library/alien/compiler.factor
+++ b/library/alien/compiler.factor
@@ -77,10 +77,10 @@ SYMBOL: alien-parameters
 
 : infer-alien-invoke ( -- )
     \ alien-invoke "infer-effect" word-prop car ensure-d
-    pop-literal
-    pop-literal >r
-    pop-literal
-    pop-literal -rot
+    pop-literal nip
+    pop-literal nip >r
+    pop-literal nip
+    pop-literal nip -rot
     r> swap alien-invoke-node ;
 
 : parameters [ alien-parameters get reverse ] bind ;
@@ -138,9 +138,9 @@ SYMBOL: alien-parameters
 
 : infer-alien-global ( -- )
     \ alien-global "infer-effect" word-prop car ensure-d
-    pop-literal
-    pop-literal
-    pop-literal -rot
+    pop-literal nip
+    pop-literal nip
+    pop-literal nip -rot
     alien-global-node ;
 
 : linearize-alien-global ( node -- )

diff --git a/library/bootstrap/primitives.factor b/library/bootstrap/primitives.factor
index 3c1d2213c1b8680c1bd9e87bb380bca9bf895259..a809827b6d1542db6761bd4931d00180a1f22e55 100644 (file)
--- a/library/bootstrap/primitives.factor
+++ b/library/bootstrap/primitives.factor
@@ -38,7 +38,7 @@ vocabularies get [
     set-stack-effect ;
 
 2 [
-    [ "execute" "words"                       " word -- " ]
+    [ "execute" "words"                       [ [ word ] [ ] ] ]
     [ "call" "kernel"                         [ [ general-list ] [ ] ] ]
     [ "ifte" "kernel"                         [ [ object general-list general-list ] [ ] ] ]
     [ "cons" "lists"                          [ [ object object ] [ cons ] ] ]

diff --git a/library/compiler/compiler.factor b/library/compiler/compiler.factor
index a644816a66afedc698cd36cf46d76281bb531bd3..b409c33fbcec11e038a1f77e5d6e1f45f38e1756 100644 (file)
--- a/library/compiler/compiler.factor
+++ b/library/compiler/compiler.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 IN: compiler
 USING: compiler-backend compiler-frontend errors inference
-kernel lists namespaces prettyprint stdio words ;
+kernel lists math namespaces prettyprint stdio words ;
 
 : supported-cpu? ( -- ? )
     cpu "unknown" = not ;

diff --git a/library/compiler/relocate.factor b/library/compiler/relocate.factor
index 0c60384eb5bac1ea22b3acb19d1264026da9b172..be6e1535b798bf8b1dde4592f65ce86c26beb113 100644 (file)
--- a/library/compiler/relocate.factor
+++ b/library/compiler/relocate.factor
@@ -21,9 +21,8 @@ SYMBOL: relocation-table
     1 rel-type, relocating cons intern-literal rel, ;
 
 : rel-address ( rel/abs 16/16 -- )
-    #! Relocate address just compiled. If flag is true,
-    #! relative, and there is nothing to do.
-    over [ 2drop ] [ 2 rel-type, relocating 0 rel, ] ifte ;
+    #! Relocate address just compiled.
+    over 1 = [ 2drop ] [ 2 rel-type, relocating 0 rel, ] ifte ;
 
 : rel-word ( word rel/abs 16/16 -- )
     pick primitive? [
@@ -31,3 +30,9 @@ SYMBOL: relocation-table
     ] [
         rot drop rel-address
     ] ifte ;
+
+: rel-userenv ( n 16/16 -- )
+    0 swap 3 rel-type, relocating rel, ;
+
+: rel-cards ( 16/16 -- )
+    0 swap 4 rel-type, compiled-offset cell 2 * - rel, 0 rel, ;

diff --git a/library/compiler/x86/slots.factor b/library/compiler/x86/slots.factor
index 7cb4b5a6e75a24e00b12de8b59ecffc00e670e6b..6b4678df4a8ed7cf06536391429e53396a024446 100644 (file)
--- a/library/compiler/x86/slots.factor
+++ b/library/compiler/x86/slots.factor
@@ -32,7 +32,8 @@ M: %fast-slot generate-node ( vop -- )
 : write-barrier ( reg -- )
     #! Mark the card pointed to by vreg.
     dup card-bits SHR
-    card-offset 2list card-mark OR ;
+    card-offset 2list card-mark OR
+    0 rel-cards ;
 
 M: %set-slot generate-node ( vop -- )
     #! the untagged object is in vop-dest, the new value is in
@@ -59,7 +60,10 @@ M: %fast-set-slot generate-node ( vop -- )
     cell * "userenv" f dlsym + ;
 
 M: %getenv generate-node ( vop -- )
-    dup vop-dest v>operand swap vop-literal userenv@ unit MOV ;
+    dup vop-dest v>operand swap vop-literal
+    [ userenv@ unit MOV ] keep 0 rel-userenv ;
 
 M: %setenv generate-node ( vop -- )
-    dup vop-literal userenv@ unit swap vop-source v>operand MOV ;
+    dup vop-literal
+    [ userenv@ unit swap vop-source v>operand MOV ] keep
+    0 rel-userenv ;

diff --git a/library/inference/branches.factor b/library/inference/branches.factor
index 8c3693ee8ba2558dc21f5dd49c3eeb00d019288c..f0abfd21d7f58282c52f6089a0c2f38a4467a20c 100644 (file)
--- a/library/inference/branches.factor
+++ b/library/inference/branches.factor
@@ -119,7 +119,7 @@ SYMBOL: cloned
     #! for the given branch.
     [
         [
-            branches-can-fail? [
+            inferring-base-case get [
                 [ infer-branch , ] [ [ drop ] when ] catch
             ] [
                 infer-branch ,
@@ -127,15 +127,14 @@ SYMBOL: cloned
         ] each
     ] make-list ;
 
-: unify-dataflow ( inputs instruction effectlist -- )
+: unify-dataflow ( input instruction effectlist -- )
     [ [ get-dataflow ] bind ] map
-    swap dataflow, [ node-consume-d set ] bind ;
+    swap dataflow, [ unit node-consume-d set ] bind ;
 
-: infer-branches ( inputs instruction branchlist -- )
+: infer-branches ( input instruction branchlist -- )
     #! Recursive stack effect inference is done here. If one of
     #! the branches has an undecidable stack effect, we set the
-    #! base case to this stack effect and try again. The inputs
-    #! parameter is a vector.
+    #! base case to this stack effect and try again.
     (infer-branches) dup unify-effects unify-dataflow ;
 
 : (with-block) ( [[ label quot ]] quot -- node )
@@ -159,39 +158,10 @@ SYMBOL: cloned
         r> call
     ] (with-block) ;
 
-: infer-quot-value ( value -- )
-    gensym dup pick literal-value cons [
-        drop
-        dup value-recursion recursive-state set
-        literal-value dup infer-quot
-    ] with-block drop handle-terminator ;
-
-: boolean-value? ( value -- ? )
-    #! Return if the value's boolean valuation is known.
-    value-class
-    dup \ f = swap
-    builtin-supertypes
-    \ f builtin-supertypes intersection not
-    or ;
-
-: boolean-value ( value -- ? )
-    #! Only valid if boolean? returns true.
-    value-class \ f = not ;
-
-: static-branch? ( value -- ? )
-    drop f ;
-!    boolean-value? branches-can-fail? not and ;
-
-: static-ifte ( true false -- )
-    #! If the branch taken is statically known, just infer
-    #! along that branch.
-    dataflow-drop, pop-d boolean-value [ drop ] [ nip ] ifte
-    infer-quot-value ;
-
 : dynamic-ifte ( true false -- )
     #! If branch taken is computed, infer along both paths and
     #! unify.
-    2list >r 1 meta-d get vector-tail* \ ifte r>
+    2list >r peek-d \ ifte r>
     pop-d [
         dup \ general-t <class-tie> ,
         \ f <class-tie> ,
@@ -203,11 +173,7 @@ SYMBOL: cloned
     [ object general-list general-list ] ensure-d
     dataflow-drop, pop-d
     dataflow-drop, pop-d swap
-    peek-d static-branch? [
-        static-ifte
-    ] [
-        dynamic-ifte
-    ] ifte ;
+    dynamic-ifte ;
 
 \ ifte [ infer-ifte ] "infer" set-word-prop
 
@@ -220,19 +186,11 @@ SYMBOL: cloned
     0 recursive-state get <literal>
     [ set-value-literal-ties ] keep ;
 
-: static-dispatch? ( -- )
-    peek-d literal? branches-can-fail? not and ;
-
 USE: kernel-internals
 
-: static-dispatch ( vtable -- )
-    >r pop-literal r>
-    dup literal-value swap value-recursion
-    >r nth r> <literal> infer-quot-value ;
-
 : dynamic-dispatch ( vtable -- )
-    >r 1 meta-d get vector-tail* \ dispatch r>
-    vtable>list 
+    >r peek-d \ dispatch r>
+    vtable>list
     pop-d <dispatch-index>
     over length [ <literal-tie> ] project-with
     zip infer-branches ;
@@ -240,12 +198,7 @@ USE: kernel-internals
 : infer-dispatch ( -- )
     #! Infer effects for all branches, unify.
     [ object vector ] ensure-d
-    dataflow-drop, pop-d  static-dispatch? [
-        static-dispatch
-    ] [
-        dynamic-dispatch
-    ] ifte ;
+    dataflow-drop, pop-d dynamic-dispatch ;
 
 \ dispatch [ infer-dispatch ] "infer" set-word-prop
-\ dispatch [ [ fixnum vector ] [ ] ]
-"infer-effect" set-word-prop
+\ dispatch [ [ fixnum vector ] [ ] ] "infer-effect" set-word-prop

diff --git a/library/inference/inference.factor b/library/inference/inference.factor
index f89dca665537073560234ea096aad1c519fee54f..e3533ca165bae2124e2a1988cade781e760f1e06 100644 (file)
--- a/library/inference/inference.factor
+++ b/library/inference/inference.factor
@@ -4,14 +4,9 @@ IN: inference
 USING: errors generic interpreter kernel lists math namespaces
 prettyprint sequences strings unparser vectors words ;
 
-: max-recursion 0 ;
-
-! This variable takes a value from 0 up to max-recursion.
+! This variable takes a boolean value.
 SYMBOL: inferring-base-case
 
-: branches-can-fail? ( -- ? )
-    inferring-base-case get max-recursion > ;
-
 ! Word properties that affect inference:
 ! - infer-effect -- must be set. controls number of inputs
 ! expected, and number of outputs produced.
@@ -82,8 +77,8 @@ M: computed literal-value ( value -- )
 : value-types ( value -- list )
     value-class builtin-supertypes ;
 
-: pop-literal ( -- obj )
-    dataflow-drop, pop-d literal-value ;
+: pop-literal ( -- rstate obj )
+    dataflow-drop, pop-d dup value-recursion swap literal-value ;
 
 : (ensure-types) ( typelist n stack -- )
     pick [
@@ -129,7 +124,7 @@ M: computed literal-value ( value -- )
     0 <vector> d-in set
     recursive-state set
     dataflow-graph off
-    0 inferring-base-case set ;
+    inferring-base-case off ;
 
 GENERIC: apply-object
 

diff --git a/library/inference/types.factor b/library/inference/types.factor
index b23fda7797f2396acfbfab5cb217ff376636c3f9..c84c5766a41fdde84187aeaecbc3f3cd3f501fda 100644 (file)
--- a/library/inference/types.factor
+++ b/library/inference/types.factor
@@ -10,11 +10,7 @@ stdio prettyprint ;
     [ tuck builtin-type <class-tie> cons ] project-with
     [ cdr class-tie-class ] subset ;
 
-: literal-type ( -- )
-    dataflow-drop, pop-d value-types car
-    apply-literal ;
-
-: computed-type ( -- )
+: infer-type ( -- )
     \ type #call dataflow, [
         peek-d type-value-map >r
         1 0 node-inputs
@@ -25,6 +21,5 @@ stdio prettyprint ;
     ] bind ;
 
 \ type [
-    [ object ] ensure-d
-    literal-type? [ literal-type ] [ computed-type ] ifte
+    [ object ] ensure-d infer-type
 ] "infer" set-word-prop

diff --git a/library/inference/words.factor b/library/inference/words.factor
index e9d2ecb7f5bba703cb3acbe0a1a850b8d6e96462..b1cfa1d80028ada9c23bf9340aa94ad7bb92a5e6 100644 (file)
--- a/library/inference/words.factor
+++ b/library/inference/words.factor
@@ -52,7 +52,7 @@ hashtables parser prettyprint ;
         ] with-scope consume/produce
     ] [
         [
-            >r branches-can-fail? [
+            >r inferring-base-case get [
                 drop
             ] [
                 t "no-effect" set-word-prop
@@ -100,29 +100,12 @@ M: compound apply-word ( word -- )
         apply-default
     ] ifte ;
 
-: literal-type? ( -- ? )
-    peek-d value-types dup length 1 = >r [ tuple ] = not r> and ;
-
-: dynamic-dispatch-warning ( word -- )
-    "Dynamic dispatch for " swap word-name cat2
-    inference-warning ;
-
-! M: generic apply-word ( word -- )
-!     #! If the type of the value at the top of the stack is
-!     #! known, inline the method body.
-!     [ object ] ensure-d
-!    literal-type? branches-can-fail? not and [
-!        inline-compound 2drop
-!    ] [
-!        dup dynamic-dispatch-warning apply-default ;
-!    ] ifte ;
-
 : with-recursion ( quot -- )
     [
-        inferring-base-case [ 1 + ] change
+        inferring-base-case on
         call
     ] [
-        inferring-base-case [ 1 - ] change
+        inferring-base-case off
         rethrow
     ] catch ;
 
@@ -143,14 +126,10 @@ M: compound apply-word ( word -- )
     #! Handle a recursive call, by either applying a previously
     #! inferred base case, or raising an error. If the recursive
     #! call is to a local block, emit a label call node.
-    inferring-base-case get max-recursion > [
+    inferring-base-case get [
         drop no-base-case
     ] [
-        inferring-base-case get max-recursion = [
-            base-case
-        ] [
-            [ drop inline-compound 2drop ] with-recursion
-        ] ifte
+        base-case
     ] ifte ;
 
 M: word apply-object ( word -- )
@@ -161,11 +140,20 @@ M: word apply-object ( word -- )
         apply-word
     ] ifte* ;
 
-: infer-call ( -- )
-    [ general-list ] ensure-d
-    dataflow-drop, pop-d infer-quot-value ;
+: infer-quot-value ( rstate quot -- )
+    gensym dup pick cons [
+        drop
+        swap recursive-state set
+        dup infer-quot
+    ] with-block drop handle-terminator ;
+
+\ call [
+    [ general-list ] ensure-d pop-literal infer-quot-value
+] "infer" set-word-prop
 
-\ call [ infer-call ] "infer" set-word-prop
+\ execute [
+    [ word ] ensure-d pop-literal unit infer-quot-value
+] "infer" set-word-prop
 
 ! These hacks will go away soon
 \ * [ [ number number ] [ number ] ] "infer-effect" set-word-prop

diff --git a/native/cards.c b/native/cards.c
index f3d40435bc181d8ace0f23002389cd551aa11cb2..c490c753ab9dd0cee651bf222b0533138c611867 100644 (file)
--- a/native/cards.c
+++ b/native/cards.c
@@ -11,7 +11,7 @@ INLINE void collect_card(CARD *ptr, CELL here)
        if(offset == 0x7f)
        {
                if(c == 0xff)
-                       critical_error("bad card",c);
+                       critical_error("bad card",ptr);
                else
                        return;
        }

diff --git a/native/cards.h b/native/cards.h
index 3be9ff21905eae70438e3d6436ae76c6d9154b40..f1e4bcab7af192a6b78d737bb14f90f7eb3a56a3 100644 (file)
--- a/native/cards.h
+++ b/native/cards.h
@@ -42,8 +42,10 @@ INLINE u8 card_base(CARD c)
        return c & CARD_BASE_MASK;
 }
 
-#define ADDR_TO_CARD(a) (CARD*)((((CELL)a-heap_start)>>CARD_BITS)+(CELL)cards)
-#define CARD_TO_ADDR(c) (CELL*)((((CELL)c-(CELL)cards)<<CARD_BITS)+heap_start)
+CELL cards_offset;
+
+#define ADDR_TO_CARD(a) (CARD*)(((CELL)a >> CARD_BITS) + cards_offset)
+#define CARD_TO_ADDR(c) (CELL*)(((CELL)c - cards_offset)<<CARD_BITS)
 
 /* this is an inefficient write barrier. compiled definitions use a more
 efficient one hand-coded in assembly. the write barrier must be called

diff --git a/native/debug.c b/native/debug.c
index 0d03a048afe2e0f181c4fe41a7e58443780e3fa2..472ae28e0a463196e9ae1ab11aaa60452d73c04a 100644 (file)
--- a/native/debug.c
+++ b/native/debug.c
@@ -218,6 +218,9 @@ void dump_generations(void)
 
 void factorbug(void)
 {
+       fcntl(0,F_SETFL,0);
+       fcntl(1,F_SETFL,0);
+
        fprintf(stderr,"Factor low-level debugger\n");
        fprintf(stderr,"d <addr> <count> -- dump memory\n");
        fprintf(stderr,". <addr>         -- print object at <addr>\n");

diff --git a/native/factor.c b/native/factor.c
index 0ea1881cea1c52e13e7a5327a2fea24c9a3e5667..67c784b097a8f8a485bf41a76fa9070837bbd6be 100644 (file)
--- a/native/factor.c
+++ b/native/factor.c
@@ -17,7 +17,7 @@ void init_factor(char* image, CELL ds_size, CELL cs_size,
        userenv[CPU_ENV] = tag_object(from_c_string(FACTOR_CPU_STRING));
        userenv[OS_ENV] = tag_object(from_c_string(FACTOR_OS_STRING));
        userenv[GEN_ENV] = tag_fixnum(GC_GENERATIONS);
-       userenv[CARD_OFF_ENV] = tag_cell((CELL)cards - (heap_start >> CARD_BITS));
+       userenv[CARD_OFF_ENV] = tag_cell(cards_offset);
 }
 
 INLINE bool factor_arg(const char* str, const char* arg, CELL* value)

diff --git a/native/gc.c b/native/gc.c
index e9e8dbb12a831c9b896d2070fb9283a6550091f2..620c8134918dc81587a3cca0f252f382faaf9940 100644 (file)
--- a/native/gc.c
+++ b/native/gc.c
@@ -32,6 +32,7 @@ void init_arena(CELL young_size, CELL aging_size)
 
        cards = alloc_guarded(cards_size);
        cards_end = cards + cards_size;
+       cards_offset = (CELL)cards - (heap_start >> CARD_BITS);
 
        alloter = heap_start;
 

diff --git a/native/relocate.c b/native/relocate.c
index 066e2b307befa83395124de626f004097ef921ec..4470821534e771cf8e05b2dc0214b49c7a77f228 100644 (file)
--- a/native/relocate.c
+++ b/native/relocate.c
@@ -102,9 +102,9 @@ INLINE CELL compute_code_rel(F_REL *rel, CELL original)
        case F_ABSOLUTE:
                return original + (compiling.base - code_relocation_base);
        case F_USERENV:
-               return (CELL)&userenv;
+               return (CELL)&userenv[rel->argument];
        case F_CARDS:
-               return ((CELL)cards - heap_start);
+               return cards_offset;
        default:
                critical_error("Unsupported rel",rel->type);
                return -1;
@@ -132,6 +132,8 @@ INLINE CELL relocate_code_next(CELL relocating)
                CELL original;
                CELL new_value;
 
+               code_fixup(&rel->offset);
+               
                if(REL_16_16(rel))
                        original = reloc_get_16_16(rel->offset);
                else
@@ -139,7 +141,6 @@ INLINE CELL relocate_code_next(CELL relocating)
 
                /* to_c_string can fill up the heap */
                maybe_garbage_collection();
-               code_fixup(&rel->offset);
                new_value = compute_code_rel(rel,original);
 
                if(REL_RELATIVE(rel))