Non-optimizing compiler now inlow inlines some primitives, this improves bootstrap time

db4
Slava Pestov 2008-07-07 10:39:04 -05:00
parent b1e5346179
commit a8808b7087
15 changed files with 379 additions and 71 deletions

View File

@ -8,7 +8,7 @@ grouping growable classes classes.builtin classes.tuple
classes.tuple.private words.private io.binary io.files vocabs
vocabs.loader source-files definitions debugger
quotations.private sequences.private combinators
io.encodings.binary math.order accessors ;
io.encodings.binary math.order math.private accessors slots.private ;
IN: bootstrap.image
: my-arch ( -- arch )
@ -75,7 +75,7 @@ SYMBOL: objects
: data-base 1024 ; inline
: userenv-size 64 ; inline
: userenv-size 70 ; inline
: header-size 10 ; inline
@ -118,6 +118,29 @@ SYMBOL: jit-dispatch
SYMBOL: jit-epilog
SYMBOL: jit-return
SYMBOL: jit-profiling
SYMBOL: jit-tag
SYMBOL: jit-tag-word
SYMBOL: jit-eq?
SYMBOL: jit-eq?-word
SYMBOL: jit-slot
SYMBOL: jit-slot-word
SYMBOL: jit-declare-word
SYMBOL: jit-drop
SYMBOL: jit-drop-word
SYMBOL: jit-dup
SYMBOL: jit-dup-word
SYMBOL: jit->r
SYMBOL: jit->r-word
SYMBOL: jit-r>
SYMBOL: jit-r>-word
SYMBOL: jit-swap
SYMBOL: jit-swap-word
SYMBOL: jit-over
SYMBOL: jit-over-word
SYMBOL: jit-fixnum-fast
SYMBOL: jit-fixnum-fast-word
SYMBOL: jit-fixnum>=
SYMBOL: jit-fixnum>=-word
! Default definition for undefined words
SYMBOL: undefined-quot
@ -140,7 +163,30 @@ SYMBOL: undefined-quot
{ jit-epilog 33 }
{ jit-return 34 }
{ jit-profiling 35 }
{ undefined-quot 37 }
{ jit-tag 36 }
{ jit-tag-word 37 }
{ jit-eq? 38 }
{ jit-eq?-word 39 }
{ jit-slot 40 }
{ jit-slot-word 41 }
{ jit-declare-word 42 }
{ jit-drop 43 }
{ jit-drop-word 44 }
{ jit-dup 45 }
{ jit-dup-word 46 }
{ jit->r 47 }
{ jit->r-word 48 }
{ jit-r> 49 }
{ jit-r>-word 50 }
{ jit-swap 51 }
{ jit-swap-word 52 }
{ jit-over 53 }
{ jit-over-word 54 }
{ jit-fixnum-fast 55 }
{ jit-fixnum-fast-word 56 }
{ jit-fixnum>= 57 }
{ jit-fixnum>=-word 58 }
{ undefined-quot 60 }
} at header-size + ;
: emit ( cell -- ) image get push ;
@ -414,6 +460,18 @@ M: quotation '
\ if jit-if-word set
\ dispatch jit-dispatch-word set
\ do-primitive jit-primitive-word set
\ tag jit-tag-word set
\ eq? jit-eq?-word set
\ slot jit-slot-word set
\ declare jit-declare-word set
\ drop jit-drop-word set
\ dup jit-dup-word set
\ >r jit->r-word set
\ r> jit-r>-word set
\ swap jit-swap-word set
\ over jit-over-word set
\ fixnum-fast jit-fixnum-fast-word set
\ fixnum>= jit-fixnum>=-word set
[ undefined ] undefined-quot set
{
jit-code-format
@ -430,6 +488,27 @@ M: quotation '
jit-epilog
jit-return
jit-profiling
jit-tag
jit-tag-word
jit-eq?
jit-eq?-word
jit-slot
jit-slot-word
jit-declare-word
jit-drop
jit-drop-word
jit-dup
jit-dup-word
jit->r
jit->r-word
jit-r>
jit-r>-word
jit-swap
jit-swap-word
jit-fixnum-fast
jit-fixnum-fast-word
jit-fixnum>=
jit-fixnum>=-word
undefined-quot
} [ emit-userenv ] each ;

View File

@ -224,3 +224,6 @@ M: anonymous-union (flatten-class)
dup num-tags get >=
[ drop \ hi-tag tag-number ] when
] map prune ;
: class-tag ( class -- tag/f )
class-tags dup length 1 = [ first ] [ drop f ] if ;

View File

@ -11,6 +11,7 @@ IN: bootstrap.x86
: temp-reg ( -- reg ) EBX ;
: stack-reg ( -- reg ) ESP ;
: ds-reg ( -- reg ) ESI ;
: rs-reg ( -- reg ) EDI ;
: fixnum>slot@ ( -- ) arg0 1 SAR ;
: rex-length ( -- n ) 0 ;

View File

@ -11,6 +11,7 @@ IN: bootstrap.x86
: temp-reg ( -- reg ) RBX ;
: stack-reg ( -- reg ) RSP ;
: ds-reg ( -- reg ) R14 ;
: rs-reg ( -- reg ) R15 ;
: fixnum>slot@ ( -- ) ;
: rex-length ( -- n ) 1 ;

View File

@ -74,6 +74,90 @@ big-endian off
arg0 quot-xt-offset [+] JMP ! execute branch
] rc-absolute-cell rt-literal 1 rex-length + jit-dispatch jit-define
[
arg1 ds-reg [] MOV ! load from stack
arg1 tag-mask get AND ! compute tag
arg1 tag-bits get SHL ! tag the tag
ds-reg [] arg1 MOV ! push to stack
] f f f jit-tag jit-define
: jit-compare ( -- )
arg1 0 MOV ! load t
arg1 dup [] MOV
temp-reg \ f tag-number MOV ! load f
arg0 ds-reg [] MOV ! load first value
ds-reg bootstrap-cell SUB ! adjust stack pointer
ds-reg [] arg0 CMP ! compare with second value
;
[
jit-compare
arg1 temp-reg CMOVNE ! not equal?
ds-reg [] arg1 MOV ! store
] rc-absolute-cell rt-literal 1 rex-length + jit-eq? jit-define
[
arg0 ds-reg [] MOV ! load slot number
ds-reg bootstrap-cell SUB ! adjust stack pointer
arg1 ds-reg [] MOV ! load object
fixnum>slot@ ! turn slot number into offset
arg1 tag-bits get SHR ! mask off tag
arg1 tag-bits get SHL
arg0 arg1 arg0 [+] MOV ! load slot value
ds-reg [] arg0 MOV ! push to stack
] f f f jit-slot jit-define
[
ds-reg bootstrap-cell SUB
] f f f jit-drop jit-define
[
arg0 ds-reg [] MOV
ds-reg bootstrap-cell ADD
ds-reg [] arg0 MOV
] f f f jit-dup jit-define
[
rs-reg bootstrap-cell ADD
arg0 ds-reg [] MOV
ds-reg bootstrap-cell SUB
rs-reg [] arg0 MOV
] f f f jit->r jit-define
[
ds-reg bootstrap-cell ADD
arg0 rs-reg [] MOV
rs-reg bootstrap-cell SUB
ds-reg [] arg0 MOV
] f f f jit-r> jit-define
[
arg0 ds-reg [] MOV
arg1 ds-reg bootstrap-cell neg [+] MOV
ds-reg bootstrap-cell neg [+] arg0 MOV
ds-reg [] arg1 MOV
] f f f jit-swap jit-define
[
arg0 ds-reg bootstrap-cell neg [+] MOV
ds-reg bootstrap-cell ADD
ds-reg [] arg0 MOV
] f f f jit-over jit-define
[
arg0 ds-reg [] MOV
ds-reg bootstrap-cell SUB
arg1 ds-reg [] MOV
arg1 arg0 SUB
ds-reg [] arg1 MOV
] f f f jit-fixnum-fast jit-define
[
jit-compare
arg1 temp-reg CMOVL ! not equal?
ds-reg [] arg1 MOV ! store
] rc-absolute-cell rt-literal 1 rex-length + jit-fixnum>= jit-define
[
stack-reg stack-frame-size bootstrap-cell - ADD ! unwind stack frame
] f f f jit-epilog jit-define

View File

@ -32,7 +32,7 @@ SYMBOL: compiling-loops
! Label of current word, after prologue, makes recursion faster
SYMBOL: current-label-start
: compiled-stack-traces? ( -- ? ) 36 getenv ;
: compiled-stack-traces? ( -- ? ) 59 getenv ;
: begin-compiling ( word label -- )
H{ } clone compiling-loops set

View File

@ -562,13 +562,10 @@ M: loc lazy-store
2drop t
] if ;
: class-tag ( class -- tag/f )
dup [ class-tags dup length 1 = [ first ] [ drop f ] if ] when ;
: class-matches? ( actual expected -- ? )
{
{ f [ drop t ] }
{ known-tag [ class-tag >boolean ] }
{ known-tag [ dup [ class-tag >boolean ] when ] }
[ class<= ]
} case ;
@ -639,7 +636,7 @@ PRIVATE>
[ second template-matches? ] find nip ;
: operand-tag ( operand -- tag/f )
operand-class class-tag ;
operand-class dup [ class-tag ] when ;
UNION: immediate fixnum POSTPONE: f ;

View File

@ -22,7 +22,11 @@ GENERIC: engine>quot ( engine -- quot )
: linear-dispatch-quot ( alist -- quot )
default get [ drop ] prepend swap
[ >r [ dupd eq? ] curry r> \ drop prefix ] assoc-map
[
[ [ dup ] swap [ eq? ] curry compose ]
[ [ drop ] prepose ]
bi* [ ] like
] assoc-map
alist>quot ;
: split-methods ( assoc class -- first second )

View File

@ -44,7 +44,7 @@ C: <hi-tag-dispatch-engine> hi-tag-dispatch-engine
"type" word-prop num-tags get - ;
: hi-tag-quot ( -- quot )
[ hi-tag ] num-tags get [ fixnum-fast ] curry compose ;
[ 0 slot ] num-tags get [ fixnum-fast ] curry compose ;
M: hi-tag-dispatch-engine engine>quot
methods>> engines>quots* [ >r hi-tag-number r> ] assoc-map

View File

@ -80,15 +80,17 @@ M: engine-word irrelevant? drop t ;
: array-nth% ( n -- ) 2 + , [ slot { word } declare ] % ;
: tuple-layout-superclasses ( obj -- array )
{ tuple } declare
1 slot { tuple-layout } declare
4 slot { array } declare ; inline
: tuple-layout-superclasses% ( -- )
[
{ tuple } declare
1 slot { tuple-layout } declare
4 slot { array } declare
] % ; inline
: tuple-dispatch-engine-body ( engine -- quot )
[
picker %
[ tuple-layout-superclasses ] %
tuple-layout-superclasses%
[ n>> array-nth% ]
[
methods>> [
@ -106,7 +108,7 @@ M: echelon-dispatch-engine engine>quot
] [
[
picker %
[ tuple-layout-superclasses ] %
tuple-layout-superclasses%
[ n>> array-nth% ]
[
methods>> [
@ -120,18 +122,24 @@ M: echelon-dispatch-engine engine>quot
: >=-case-quot ( alist -- quot )
default get [ drop ] prepend swap
[ >r [ dupd fixnum>= ] curry r> \ drop prefix ] assoc-map
[
[ [ dup ] swap [ fixnum>= ] curry compose ]
[ [ drop ] prepose ]
bi* [ ] like
] assoc-map
alist>quot ;
: tuple-layout-echelon ( obj -- array )
{ tuple } declare
1 slot { tuple-layout } declare
5 slot ; inline
: tuple-layout-echelon% ( -- )
[
{ tuple } declare
1 slot { tuple-layout } declare
5 slot
] % ; inline
M: tuple-dispatch-engine engine>quot
[
picker %
[ tuple-layout-echelon ] %
tuple-layout-echelon%
[
tuple assumed set
echelons>> dup empty? [

View File

@ -58,7 +58,7 @@ M: object init-io ;
: stdin-handle 11 getenv ;
: stdout-handle 12 getenv ;
: stderr-handle 38 getenv ;
: stderr-handle 61 getenv ;
M: object (init-stdio)
stdin-handle <c-reader>

View File

@ -15,7 +15,7 @@ id
continuation state runnable
mailbox variables sleep-entry ;
: self ( -- thread ) 40 getenv ; inline
: self ( -- thread ) 63 getenv ; inline
! Thread-local storage
: tnamespace ( -- assoc )
@ -30,7 +30,7 @@ mailbox variables sleep-entry ;
: tchange ( key quot -- )
tnamespace swap change-at ; inline
: threads 41 getenv ;
: threads 64 getenv ;
: thread ( id -- thread ) threads at ;
@ -53,7 +53,7 @@ mailbox variables sleep-entry ;
: unregister-thread ( thread -- )
check-registered id>> threads delete-at ;
: set-self ( thread -- ) 40 setenv ; inline
: set-self ( thread -- ) 63 setenv ; inline
PRIVATE>
@ -68,9 +68,9 @@ PRIVATE>
: <thread> ( quot name -- thread )
\ thread new-thread ;
: run-queue 42 getenv ;
: run-queue 65 getenv ;
: sleep-queue 43 getenv ;
: sleep-queue 66 getenv ;
: resume ( thread -- )
f >>state
@ -207,9 +207,9 @@ GENERIC: error-in-thread ( error thread -- )
<PRIVATE
: init-threads ( -- )
H{ } clone 41 setenv
<dlist> 42 setenv
<min-heap> 43 setenv
H{ } clone 64 setenv
<dlist> 65 setenv
<min-heap> 66 setenv
initial-thread global
[ drop f "Initial" <thread> ] cache
<box> >>continuation

View File

@ -27,6 +27,8 @@ typedef char F_SYMBOL;
#define OPEN_WRITE(path) fopen(path,"wb")
#define FPRINTF(stream,format,arg) fprintf(stream,format,arg)
void start_thread(void *(*start_routine)(void *));
void init_ffi(void);
void ffi_dlopen(F_DLL *dll);
void *ffi_dlsym(F_DLL *dll, F_SYMBOL *symbol);

View File

@ -25,6 +25,13 @@ bool jit_fast_dispatch_p(F_ARRAY *array, CELL i)
&& array_nth(array,i + 1) == userenv[JIT_DISPATCH_WORD];
}
bool jit_ignore_declare_p(F_ARRAY *array, CELL i)
{
return (i + 1) < array_capacity(array)
&& type_of(array_nth(array,i)) == ARRAY_TYPE
&& array_nth(array,i + 1) == userenv[JIT_DECLARE_WORD];
}
F_ARRAY *code_to_emit(CELL name)
{
return untag_object(array_nth(untag_object(userenv[name]),0));
@ -72,8 +79,24 @@ bool jit_stack_frame_p(F_ARRAY *array)
for(i = 0; i < length - 1; i++)
{
if(type_of(array_nth(array,i)) == WORD_TYPE)
return true;
CELL obj = array_nth(array,i);
if(type_of(obj) == WORD_TYPE)
{
if(obj != userenv[JIT_TAG_WORD]
&& obj != userenv[JIT_EQP_WORD]
&& obj != userenv[JIT_SLOT_WORD]
&& obj != userenv[JIT_DROP_WORD]
&& obj != userenv[JIT_DUP_WORD]
&& obj != userenv[JIT_TO_R_WORD]
&& obj != userenv[JIT_FROM_R_WORD]
&& obj != userenv[JIT_SWAP_WORD]
&& obj != userenv[JIT_OVER_WORD]
&& obj != userenv[JIT_FIXNUM_MINUS_WORD]
&& obj != userenv[JIT_FIXNUM_GE_WORD])
{
return true;
}
}
}
return false;
@ -131,24 +154,74 @@ void jit_compile(CELL quot, bool relocate)
switch(type_of(obj))
{
case WORD_TYPE:
/* Emit the epilog before the primitive call gate
so that we save the C stack pointer minus the
current stack frame. */
word = untag_object(obj);
GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
if(i == length - 1)
/* Intrinsics */
if(obj == userenv[JIT_TAG_WORD])
{
if(stack_frame)
EMIT(JIT_EPILOG,0);
EMIT(JIT_WORD_JUMP,literals_count - 1);
tail_call = true;
EMIT(JIT_TAG,0);
}
else if(obj == userenv[JIT_EQP_WORD])
{
GROWABLE_ARRAY_ADD(literals,T);
EMIT(JIT_EQP,literals_count - 1);
}
else if(obj == userenv[JIT_SLOT_WORD])
{
EMIT(JIT_SLOT,0);
}
else if(obj == userenv[JIT_DROP_WORD])
{
EMIT(JIT_DROP,0);
}
else if(obj == userenv[JIT_DUP_WORD])
{
EMIT(JIT_DUP,0);
}
else if(obj == userenv[JIT_TO_R_WORD])
{
EMIT(JIT_TO_R,0);
}
else if(obj == userenv[JIT_FROM_R_WORD])
{
EMIT(JIT_FROM_R,0);
}
else if(obj == userenv[JIT_SWAP_WORD])
{
EMIT(JIT_SWAP,0);
}
else if(obj == userenv[JIT_OVER_WORD])
{
EMIT(JIT_OVER,0);
}
else if(obj == userenv[JIT_FIXNUM_MINUS_WORD])
{
EMIT(JIT_FIXNUM_MINUS,0);
}
else if(obj == userenv[JIT_FIXNUM_GE_WORD])
{
GROWABLE_ARRAY_ADD(literals,T);
EMIT(JIT_FIXNUM_GE,literals_count - 1);
}
else
EMIT(JIT_WORD_CALL,literals_count - 1);
{
/* Emit the epilog before the primitive call gate
so that we save the C stack pointer minus the
current stack frame. */
word = untag_object(obj);
GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
if(i == length - 1)
{
if(stack_frame)
EMIT(JIT_EPILOG,0);
EMIT(JIT_WORD_JUMP,literals_count - 1);
tail_call = true;
}
else
EMIT(JIT_WORD_CALL,literals_count - 1);
}
break;
case WRAPPER_TYPE:
wrapper = untag_object(obj);
@ -194,6 +267,11 @@ void jit_compile(CELL quot, bool relocate)
tail_call = true;
break;
}
else if(jit_ignore_declare_p(untag_object(array),i))
{
i++;
break;
}
default:
GROWABLE_ARRAY_ADD(literals,obj);
EMIT(JIT_PUSH_LITERAL,literals_count - 1);
@ -261,24 +339,47 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset)
for(i = 0; i < length; i++)
{
CELL obj = array_nth(untag_object(array),i);
F_WORD *word;
switch(type_of(obj))
{
case WORD_TYPE:
word = untag_object(obj);
if(i == length - 1)
{
if(stack_frame)
COUNT(JIT_EPILOG,i);
COUNT(JIT_WORD_JUMP,i)
tail_call = true;
}
/* Intrinsics */
if(obj == userenv[JIT_TAG_WORD])
COUNT(JIT_TAG,i)
else if(obj == userenv[JIT_EQP_WORD])
COUNT(JIT_EQP,i)
else if(obj == userenv[JIT_SLOT_WORD])
COUNT(JIT_SLOT,i)
else if(obj == userenv[JIT_DROP_WORD])
COUNT(JIT_DROP,i)
else if(obj == userenv[JIT_DUP_WORD])
COUNT(JIT_DUP,i)
else if(obj == userenv[JIT_TO_R_WORD])
COUNT(JIT_TO_R,i)
else if(obj == userenv[JIT_FROM_R_WORD])
COUNT(JIT_FROM_R,i)
else if(obj == userenv[JIT_SWAP_WORD])
COUNT(JIT_SWAP,i)
else if(obj == userenv[JIT_OVER_WORD])
COUNT(JIT_OVER,i)
else if(obj == userenv[JIT_FIXNUM_MINUS_WORD])
COUNT(JIT_FIXNUM_MINUS,i)
else if(obj == userenv[JIT_FIXNUM_GE_WORD])
COUNT(JIT_FIXNUM_GE,i)
else
COUNT(JIT_WORD_CALL,i)
{
if(i == length - 1)
{
if(stack_frame)
COUNT(JIT_EPILOG,i);
COUNT(JIT_WORD_JUMP,i)
tail_call = true;
}
else
COUNT(JIT_WORD_CALL,i)
}
break;
case WRAPPER_TYPE:
COUNT(JIT_PUSH_LITERAL,i)
@ -319,6 +420,11 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset)
tail_call = true;
break;
}
if(jit_ignore_declare_p(untag_object(array),i))
{
i++;
break;
}
default:
COUNT(JIT_PUSH_LITERAL,i)
break;

View File

@ -1,4 +1,4 @@
#define USER_ENV 64
#define USER_ENV 70
typedef enum {
NAMESTACK_ENV, /* used by library only */
@ -47,20 +47,43 @@ typedef enum {
JIT_EPILOG,
JIT_RETURN,
JIT_PROFILING,
JIT_TAG,
JIT_TAG_WORD,
JIT_EQP,
JIT_EQP_WORD,
JIT_SLOT,
JIT_SLOT_WORD,
JIT_DECLARE_WORD,
JIT_DROP,
JIT_DROP_WORD,
JIT_DUP,
JIT_DUP_WORD,
JIT_TO_R,
JIT_TO_R_WORD,
JIT_FROM_R,
JIT_FROM_R_WORD,
JIT_SWAP,
JIT_SWAP_WORD,
JIT_OVER,
JIT_OVER_WORD,
JIT_FIXNUM_MINUS,
JIT_FIXNUM_MINUS_WORD,
JIT_FIXNUM_GE,
JIT_FIXNUM_GE_WORD,
STACK_TRACES_ENV = 36,
STACK_TRACES_ENV = 59,
UNDEFINED_ENV = 37, /* default quotation for undefined words */
UNDEFINED_ENV = 60, /* default quotation for undefined words */
STDERR_ENV = 38, /* stderr FILE* handle */
STDERR_ENV = 61, /* stderr FILE* handle */
STAGE2_ENV = 39, /* have we bootstrapped? */
STAGE2_ENV = 62, /* have we bootstrapped? */
CURRENT_THREAD_ENV = 40,
CURRENT_THREAD_ENV = 63,
THREADS_ENV = 41,
RUN_QUEUE_ENV = 42,
SLEEP_QUEUE_ENV = 43,
THREADS_ENV = 64,
RUN_QUEUE_ENV = 65,
SLEEP_QUEUE_ENV = 66,
} F_ENVTYPE;
#define FIRST_SAVE_ENV BOOT_ENV