gengc and relocation fixes; inference cleanups
Slava Pestov
parent
43a19be01f
commit
3ece9e9b88
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 -- )
|
||||
|
|
|
|||
|
|
@ -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 ] ] ]
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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, ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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,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? [
|
||||
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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");
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
Loading…
Reference in New Issue