From 3ece9e9b88ca49db6957d455804cf42a32e2db63 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 14 May 2005 04:23:00 +0000 Subject: [PATCH] gengc and relocation fixes; inference cleanups --- TODO.FACTOR.txt | 2 +- library/alien/compiler.factor | 14 +++--- library/bootstrap/primitives.factor | 2 +- library/compiler/compiler.factor | 2 +- library/compiler/relocate.factor | 11 +++-- library/compiler/x86/slots.factor | 10 +++-- library/inference/branches.factor | 69 +++++------------------------ library/inference/inference.factor | 13 ++---- library/inference/types.factor | 9 +--- library/inference/words.factor | 48 ++++++++------------ native/cards.c | 2 +- native/cards.h | 6 ++- native/debug.c | 3 ++ native/factor.c | 2 +- native/gc.c | 1 + native/relocate.c | 7 +-- 16 files changed, 74 insertions(+), 127 deletions(-) diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index f35bff470c..db8266ccce 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -6,6 +6,7 @@ http://www.caddr.com/macho/archives/sbcl-devel/2005-3/4764.html 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 diff --git a/library/alien/compiler.factor b/library/alien/compiler.factor index 61fdd29447..8e58366f21 100644 --- 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 3c1d2213c1..a809827b6d 100644 --- 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 a644816a66..b409c33fbc 100644 --- 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 0c60384eb5..be6e1535b7 100644 --- 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 7cb4b5a6e7..6b4678df4a 100644 --- 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 8c3693ee8b..f0abfd21d7 100644 --- 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 , \ f , @@ -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 [ 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> 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 over length [ ] 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 f89dca6655..e3533ca165 100644 --- 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 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 b23fda7797..c84c5766a4 100644 --- a/library/inference/types.factor +++ b/library/inference/types.factor @@ -10,11 +10,7 @@ stdio prettyprint ; [ tuck builtin-type 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 e9d2ecb7f5..b1cfa1d800 100644 --- 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 [ 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 diff --git a/native/cards.c b/native/cards.c index f3d40435bc..c490c753ab 100644 --- 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 3be9ff2190..f1e4bcab7a 100644 --- 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) + cards_offset) +#define CARD_TO_ADDR(c) (CELL*)(((CELL)c - cards_offset)< -- dump memory\n"); fprintf(stderr,". -- print object at \n"); diff --git a/native/factor.c b/native/factor.c index 0ea1881cea..67c784b097 100644 --- 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 e9e8dbb12a..620c813491 100644 --- 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 066e2b307b..4470821534 100644 --- 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))