gengc and relocation fixes; inference cleanups

TODO.FACTOR.txt

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

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 nip
-    pop-literal >r
+    pop-literal nip >r
-    pop-literal
+    pop-literal nip
-    pop-literal -rot
+    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 nip
-    pop-literal
+    pop-literal nip
-    pop-literal -rot
+    pop-literal nip -rot
     alien-global-node ;
 
 : linearize-alien-global ( node -- )

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 ] ] ]

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 ;

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,
+    #! Relocate address just compiled.
-    #! relative, and there is nothing to do.
+    over 1 = [ 2drop ] [ 2 rel-type, relocating 0 rel, ] ifte ;
-    over [ 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, ;

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 ;

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
+    #! base case to this stack effect and try again.
-    #! parameter is a vector.
     (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? [
+    dynamic-ifte ;
-        static-ifte
-    ] [
-        dynamic-ifte
-    ] ifte ;
 
 \ ifte [ infer-ifte ] "infer" set-word-prop
 
@@ -220,18 +186,10 @@ 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>
+    >r peek-d \ dispatch r>
     vtable>list
     pop-d <dispatch-index>
     over length [ <literal-tie> ] project-with
@@ -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? [
+    dataflow-drop, pop-d dynamic-dispatch ;
-        static-dispatch
-    ] [
-        dynamic-dispatch
-    ] ifte ;
 
 \ dispatch [ infer-dispatch ] "infer" set-word-prop
-\ dispatch [ [ fixnum vector ] [ ] ]
+\ dispatch [ [ fixnum vector ] [ ] ] "infer-effect" set-word-prop
-"infer-effect" set-word-prop

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 boolean value.
-
-! This variable takes a value from 0 up to max-recursion.
 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 )
+: pop-literal ( -- rstate obj )
-    dataflow-drop, pop-d literal-value ;
+    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
 

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 ( -- )
+: infer-type ( -- )
-    dataflow-drop, pop-d value-types car
-    apply-literal ;
-
-: computed-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
+    [ object ] ensure-d infer-type
-    literal-type? [ literal-type ] [ computed-type ] ifte
 ] "infer" set-word-prop

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
     ] ifte ;
 
 M: word apply-object ( word -- )
@@ -161,11 +140,20 @@ M: word apply-object ( word -- )
         apply-word
     ] ifte* ;
 
-: infer-call ( -- )
+: infer-quot-value ( rstate quot -- )
-    [ general-list ] ensure-d
+    gensym dup pick cons [
-    dataflow-drop, pop-d infer-quot-value ;
+        drop
+        swap recursive-state set
+        dup infer-quot
+    ] with-block drop handle-terminator ;
 
-\ call [ infer-call ] "infer" set-word-prop
+\ call [
+    [ general-list ] ensure-d pop-literal infer-quot-value
+] "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

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;
 	}

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)
+CELL cards_offset;
-#define CARD_TO_ADDR(c) (CELL*)((((CELL)c-(CELL)cards)<<CARD_BITS)+heap_start)
+
+#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

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");

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)

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;
 

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))