steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor

db4
Doug Coleman 2009-05-06 23:56:19 -05:00
parent 70469af0e2 741e97e57e
commit 42a86854a5
37 changed files with 356 additions and 271 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

198
basis/bootstrap/image/image.factor
View File

@ -9,7 +9,7 @@ classes.builtin classes.tuple classes.tuple.private vocabs
vocabs.loader source-files definitions debugger quotations.private
sequences.private combinators math.order math.private accessors
slots.private generic.single.private compiler.units compiler.constants
fry ;
fry bootstrap.image.syntax ;
IN: bootstrap.image
: arch ( os cpu -- arch )
@ -93,24 +93,19 @@ CONSTANT: -1-offset 9
SYMBOL: sub-primitives
SYMBOL: jit-define-rc
SYMBOL: jit-define-rt
SYMBOL: jit-define-offset
SYMBOL: jit-relocations
: compute-offset ( -- offset )
building get length jit-define-rc get rc-absolute-cell = bootstrap-cell 4 ? - ;
: compute-offset ( rc -- offset )
[ building get length ] dip rc-absolute-cell = bootstrap-cell 4 ? - ;
: jit-rel ( rc rt -- )
jit-define-rt set
jit-define-rc set
compute-offset jit-define-offset set ;
over compute-offset 3array jit-relocations get push-all ;
: make-jit ( quot -- quad )
: make-jit ( quot -- jit-data )
[
V{ } clone jit-relocations set
call( -- )
jit-define-rc get
jit-define-rt get
jit-define-offset get 3array
jit-relocations get >array
] B{ } make prefix ;
: jit-define ( quot name -- )
@ -128,98 +123,59 @@ SYMBOL: big-endian
! Bootstrap architecture name
SYMBOL: architecture
! Bootstrap global namesapce
SYMBOL: bootstrap-global
RESET
! Boot quotation, set in stage1.factor
SYMBOL: bootstrap-boot-quot
USERENV: bootstrap-boot-quot 20
! Bootstrap global namesapce
USERENV: bootstrap-global 21
! JIT parameters
SYMBOL: jit-prolog
SYMBOL: jit-primitive-word
SYMBOL: jit-primitive
SYMBOL: jit-word-jump
SYMBOL: jit-word-call
SYMBOL: jit-push-immediate
SYMBOL: jit-if-word
SYMBOL: jit-if-1
SYMBOL: jit-if-2
SYMBOL: jit-dip-word
SYMBOL: jit-dip
SYMBOL: jit-2dip-word
SYMBOL: jit-2dip
SYMBOL: jit-3dip-word
SYMBOL: jit-3dip
SYMBOL: jit-execute-word
SYMBOL: jit-execute-jump
SYMBOL: jit-execute-call
SYMBOL: jit-epilog
SYMBOL: jit-return
SYMBOL: jit-profiling
SYMBOL: jit-save-stack
USERENV: jit-prolog 23
USERENV: jit-primitive-word 24
USERENV: jit-primitive 25
USERENV: jit-word-jump 26
USERENV: jit-word-call 27
USERENV: jit-word-special 28
USERENV: jit-if-word 29
USERENV: jit-if 30
USERENV: jit-epilog 31
USERENV: jit-return 32
USERENV: jit-profiling 33
USERENV: jit-push-immediate 34
USERENV: jit-dip-word 35
USERENV: jit-dip 36
USERENV: jit-2dip-word 37
USERENV: jit-2dip 38
USERENV: jit-3dip-word 39
USERENV: jit-3dip 40
USERENV: jit-execute-word 41
USERENV: jit-execute-jump 42
USERENV: jit-execute-call 43
! PIC stubs
SYMBOL: pic-load
SYMBOL: pic-tag
SYMBOL: pic-hi-tag
SYMBOL: pic-tuple
SYMBOL: pic-hi-tag-tuple
SYMBOL: pic-check-tag
SYMBOL: pic-check
SYMBOL: pic-hit
SYMBOL: pic-miss-word
USERENV: pic-load 47
USERENV: pic-tag 48
USERENV: pic-hi-tag 49
USERENV: pic-tuple 50
USERENV: pic-hi-tag-tuple 51
USERENV: pic-check-tag 52
USERENV: pic-check 53
USERENV: pic-hit 54
USERENV: pic-miss-word 55
USERENV: pic-miss-tail-word 56
! Megamorphic dispatch
SYMBOL: mega-lookup
SYMBOL: mega-lookup-word
SYMBOL: mega-miss-word
USERENV: mega-lookup 57
USERENV: mega-lookup-word 58
USERENV: mega-miss-word 59
! Default definition for undefined words
SYMBOL: undefined-quot
: userenvs ( -- assoc )
H{
{ bootstrap-boot-quot 20 }
{ bootstrap-global 21 }
{ jit-prolog 23 }
{ jit-primitive-word 24 }
{ jit-primitive 25 }
{ jit-word-jump 26 }
{ jit-word-call 27 }
{ jit-if-word 28 }
{ jit-if-1 29 }
{ jit-if-2 30 }
{ jit-epilog 33 }
{ jit-return 34 }
{ jit-profiling 35 }
{ jit-push-immediate 36 }
{ jit-save-stack 38 }
{ jit-dip-word 39 }
{ jit-dip 40 }
{ jit-2dip-word 41 }
{ jit-2dip 42 }
{ jit-3dip-word 43 }
{ jit-3dip 44 }
{ jit-execute-word 45 }
{ jit-execute-jump 46 }
{ jit-execute-call 47 }
{ pic-load 48 }
{ pic-tag 49 }
{ pic-hi-tag 50 }
{ pic-tuple 51 }
{ pic-hi-tag-tuple 52 }
{ pic-check-tag 53 }
{ pic-check 54 }
{ pic-hit 55 }
{ pic-miss-word 56 }
{ mega-lookup 57 }
{ mega-lookup-word 58 }
{ mega-miss-word 59 }
{ undefined-quot 60 }
} ; inline
USERENV: undefined-quot 60
: userenv-offset ( symbol -- n )
userenvs at header-size + ;
userenvs get at header-size + ;
: emit ( cell -- ) image get push ;
@ -351,7 +307,8 @@ M: f '
[ vocabulary>> , ]
[ def>> , ]
[ props>> , ]
[ direct-entry-def>> , ] ! direct-entry-def
[ pic-def>> , ]
[ pic-tail-def>> , ]
[ drop 0 , ] ! count
[ word-sub-primitive , ]
[ drop 0 , ] ! xt
@ -510,11 +467,7 @@ M: quotation '
class<=-cache class-not-cache classes-intersect-cache
class-and-cache class-or-cache next-method-quot-cache
} [ H{ } clone ] H{ } map>assoc assoc-union
bootstrap-global set
bootstrap-global emit-userenv ;
: emit-boot-quot ( -- )
bootstrap-boot-quot emit-userenv ;
bootstrap-global set ;
: emit-jit-data ( -- )
\ if jit-if-word set
@ -524,46 +477,13 @@ M: quotation '
\ 3dip jit-3dip-word set
\ (execute) jit-execute-word set
\ inline-cache-miss \ pic-miss-word set
\ inline-cache-miss-tail \ pic-miss-tail-word set
\ mega-cache-lookup \ mega-lookup-word set
\ mega-cache-miss \ mega-miss-word set
[ undefined ] undefined-quot set
{
jit-prolog
jit-primitive-word
jit-primitive
jit-word-jump
jit-word-call
jit-push-immediate
jit-if-word
jit-if-1
jit-if-2
jit-dip-word
jit-dip
jit-2dip-word
jit-2dip
jit-3dip-word
jit-3dip
jit-execute-word
jit-execute-jump
jit-execute-call
jit-epilog
jit-return
jit-profiling
jit-save-stack
pic-load
pic-tag
pic-hi-tag
pic-tuple
pic-hi-tag-tuple
pic-check-tag
pic-check
pic-hit
pic-miss-word
mega-lookup
mega-lookup-word
mega-miss-word
undefined-quot
} [ emit-userenv ] each ;
[ undefined ] undefined-quot set ;
: emit-userenvs ( -- )
userenvs get keys [ emit-userenv ] each ;
: fixup-header ( -- )
heap-size data-heap-size-offset fixup ;
@ -580,8 +500,8 @@ M: quotation '
emit-jit-data
"Serializing global namespace..." print flush
emit-global
"Serializing boot quotation..." print flush
emit-boot-quot
"Serializing user environment..." print flush
emit-userenvs
"Performing word fixups..." print flush
fixup-words
"Performing header fixups..." print flush

1
basis/bootstrap/image/syntax/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

14
basis/bootstrap/image/syntax/syntax.factor Normal file
View File

@ -0,0 +1,14 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: parser kernel namespaces assocs words.symbol ;
IN: bootstrap.image.syntax
SYMBOL: userenvs
SYNTAX: RESET H{ } clone userenvs set-global ;
SYNTAX: USERENV:
CREATE-WORD scan-word
[ swap userenvs get set-at ]
[ drop define-symbol ]
2bi ;

3
basis/compiler/codegen/fixup/fixup.factor
View File

@ -59,6 +59,9 @@ SYMBOL: literal-table
: rel-word-pic ( word class -- )
[ add-literal ] dip rt-xt-pic rel-fixup ;
: rel-word-pic-tail ( word class -- )
[ add-literal ] dip rt-xt-pic-tail rel-fixup ;
: rel-primitive ( word class -- )
[ def>> first add-literal ] dip rt-primitive rel-fixup ;

24
basis/compiler/constants/constants.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: math kernel layouts system strings words quotations byte-arrays
alien arrays ;
alien arrays literals sequences ;
IN: compiler.constants
! These constants must match vm/memory.h
@ -14,14 +14,14 @@ CONSTANT: deck-bits 18
: float-offset ( -- n ) 8 float tag-number - ; inline
: string-offset ( -- n ) 4 bootstrap-cells string tag-number - ; inline
: string-aux-offset ( -- n ) 2 bootstrap-cells string tag-number - ; inline
: profile-count-offset ( -- n ) 7 bootstrap-cells \ word tag-number - ; inline
: profile-count-offset ( -- n ) 8 bootstrap-cells \ word tag-number - ; inline
: byte-array-offset ( -- n ) 2 bootstrap-cells byte-array tag-number - ; inline
: alien-offset ( -- n ) 3 bootstrap-cells alien tag-number - ; inline
: underlying-alien-offset ( -- n ) bootstrap-cell alien tag-number - ; inline
: tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ; inline
: word-xt-offset ( -- n ) 9 bootstrap-cells \ word tag-number - ; inline
: word-xt-offset ( -- n ) 10 bootstrap-cells \ word tag-number - ; inline
: quot-xt-offset ( -- n ) 5 bootstrap-cells quotation tag-number - ; inline
: word-code-offset ( -- n ) 10 bootstrap-cells \ word tag-number - ; inline
: word-code-offset ( -- n ) 11 bootstrap-cells \ word tag-number - ; inline
: array-start-offset ( -- n ) 2 bootstrap-cells array tag-number - ; inline
: compiled-header-size ( -- n ) 4 bootstrap-cells ; inline
@ -43,14 +43,12 @@ CONSTANT: rt-dlsym 1
CONSTANT: rt-dispatch 2
CONSTANT: rt-xt 3
CONSTANT: rt-xt-pic 4
CONSTANT: rt-here 5
CONSTANT: rt-this 6
CONSTANT: rt-immediate 7
CONSTANT: rt-stack-chain 8
CONSTANT: rt-untagged 9
CONSTANT: rt-xt-pic-tail 5
CONSTANT: rt-here 6
CONSTANT: rt-this 7
CONSTANT: rt-immediate 8
CONSTANT: rt-stack-chain 9
CONSTANT: rt-untagged 10
: rc-absolute? ( n -- ? )
[ rc-absolute-ppc-2/2 = ]
[ rc-absolute-cell = ]
[ rc-absolute = ]
tri or or ;
${ rc-absolute-ppc-2/2 rc-absolute-cell rc-absolute } member? ;

8
basis/cpu/ppc/bootstrap.factor
View File

@ -50,9 +50,6 @@ CONSTANT: rs-reg 14
0 6 LOAD32 rc-absolute-ppc-2/2 rt-stack-chain jit-rel
7 6 0 LWZ
1 7 0 STW
] jit-save-stack jit-define
[
0 6 LOAD32 rc-absolute-ppc-2/2 rt-primitive jit-rel
6 MTCTR
BCTR
@ -68,11 +65,8 @@ CONSTANT: rs-reg 14
0 3 \ f tag-number CMPI
2 BEQ
0 B rc-relative-ppc-3 rt-xt jit-rel
] jit-if-1 jit-define
[
0 B rc-relative-ppc-3 rt-xt jit-rel
] jit-if-2 jit-define
] jit-if jit-define
: jit->r ( -- )
4 ds-reg 0 LWZ

6
basis/cpu/ppc/ppc.factor
View File

@ -114,7 +114,11 @@ M: ppc stack-frame-size ( stack-frame -- i )
4 cells align ;
M: ppc %call ( word -- ) 0 BL rc-relative-ppc-3 rel-word-pic ;
M: ppc %jump ( word -- ) 0 B rc-relative-ppc-3 rel-word ;
M: ppc %jump ( word -- )
0 3 LOAD32 rc-absolute-ppc-2/2 rel-here
0 B rc-relative-ppc-3 rel-word-pic-tail ;
M: ppc %jump-label ( label -- ) B ;
M: ppc %return ( -- ) BLR ;

2
basis/cpu/x86/32/32.factor
View File

@ -42,6 +42,8 @@ M:: x86.32 %dispatch ( src temp offset -- )
M: x86.32 param-reg-1 EAX ;
M: x86.32 param-reg-2 EDX ;
M: x86.32 pic-tail-reg EBX ;
M: x86.32 reserved-area-size 0 ;
M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ;

6
basis/cpu/x86/32/bootstrap.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2007 Slava Pestov.
! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image.private kernel namespaces system
cpu.x86.assembler layouts vocabs parser compiler.constants ;
@ -26,9 +26,7 @@ IN: bootstrap.x86
temp0 0 [] MOV rc-absolute-cell rt-stack-chain jit-rel
! save stack pointer
temp0 [] stack-reg MOV
] jit-save-stack jit-define
[
! call the primitive
0 JMP rc-relative rt-primitive jit-rel
] jit-primitive jit-define

2
basis/cpu/x86/64/64.factor
View File

@ -39,6 +39,8 @@ M: x86.64 param-reg-1 int-regs param-regs first ;
M: x86.64 param-reg-2 int-regs param-regs second ;
: param-reg-3 ( -- reg ) int-regs param-regs third ; inline
M: x86.64 pic-tail-reg RBX ;
M: int-regs return-reg drop RAX ;
M: float-regs return-reg drop XMM0 ;

5
basis/cpu/x86/64/bootstrap.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2007 Slava Pestov.
! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image.private kernel namespaces system
cpu.x86.assembler layouts vocabs parser compiler.constants math ;
@ -25,9 +25,6 @@ IN: bootstrap.x86
temp0 temp0 [] MOV
! save stack pointer
temp0 [] stack-reg MOV
] jit-save-stack jit-define
[
! load XT
temp1 0 MOV rc-absolute-cell rt-primitive jit-rel
! go

14
basis/cpu/x86/bootstrap.factor
View File

@ -42,13 +42,18 @@ big-endian off
] jit-push-immediate jit-define
[
0 JMP rc-relative rt-xt jit-rel
temp3 0 MOV rc-absolute-cell rt-here jit-rel
0 JMP rc-relative rt-xt-pic-tail jit-rel
] jit-word-jump jit-define
[
0 CALL rc-relative rt-xt-pic jit-rel
] jit-word-call jit-define
[
0 JMP rc-relative rt-xt jit-rel
] jit-word-special jit-define
[
! load boolean
temp0 ds-reg [] MOV
@ -58,12 +63,9 @@ big-endian off
temp0 \ f tag-number CMP
! jump to true branch if not equal
0 JNE rc-relative rt-xt jit-rel
] jit-if-1 jit-define
[
! jump to false branch if equal
0 JMP rc-relative rt-xt jit-rel
] jit-if-2 jit-define
] jit-if jit-define
: jit->r ( -- )
rs-reg bootstrap-cell ADD
@ -152,6 +154,8 @@ big-endian off
! ! ! Polymorphic inline caches
! The PIC and megamorphic code stubs are not permitted to touch temp3.
! Load a value from a stack position
[
temp1 ds-reg HEX: ffffffff [+] MOV rc-absolute rt-untagged jit-rel

13
basis/cpu/x86/x86.factor
View File

@ -23,6 +23,8 @@ HOOK: temp-reg-2 cpu ( -- reg )
HOOK: param-reg-1 cpu ( -- reg )
HOOK: param-reg-2 cpu ( -- reg )
HOOK: pic-tail-reg cpu ( -- reg )
M: x86 %load-immediate MOV ;
M: x86 %load-reference swap 0 MOV rc-absolute-cell rel-immediate ;
@ -58,8 +60,17 @@ M: x86 stack-frame-size ( stack-frame -- i )
align-stack ;
M: x86 %call ( word -- ) 0 CALL rc-relative rel-word-pic ;
M: x86 %jump ( word -- ) 0 JMP rc-relative rel-word ;
: xt-tail-pic-offset ( -- n )
#! See the comment in vm/cpu-x86.hpp
cell 4 + 1 + ; inline
M: x86 %jump ( word -- )
pic-tail-reg 0 MOV xt-tail-pic-offset rc-absolute-cell rel-here
0 JMP rc-relative rel-word-pic-tail ;
M: x86 %jump-label ( label -- ) 0 JMP rc-relative label-fixup ;
M: x86 %return ( -- ) 0 RET ;
: code-alignment ( align -- n )

30
basis/tools/trace/trace-tests.factor
View File

@ -1,4 +1,30 @@
IN: tools.trace.tests
USING: tools.trace tools.test sequences ;
USING: tools.trace tools.test tools.continuations kernel math combinators
sequences ;
[ { 3 2 1 } ] [ { 1 2 3 } [ reverse ] trace ] unit-test
[ { 3 2 1 } ] [ { 1 2 3 } [ reverse ] trace ] unit-test
GENERIC: method-breakpoint-test ( x -- y )
TUPLE: method-breakpoint-tuple ;
M: method-breakpoint-tuple method-breakpoint-test break drop 1 2 + ;
\ method-breakpoint-test don't-step-into
[ 3 ]
[ [ T{ method-breakpoint-tuple } method-breakpoint-test ] trace ] unit-test
: case-breakpoint-test ( -- x )
5 { [ break 1 + ] } case ;
\ case-breakpoint-test don't-step-into
[ 6 ] [ [ case-breakpoint-test ] trace ] unit-test
: call(-breakpoint-test ( -- x )
[ break 1 ] call( -- x ) 2 + ;
\ call(-breakpoint-test don't-step-into
[ 3 ] [ [ call(-breakpoint-test ] trace ] unit-test

35
basis/tools/trace/trace.factor
View File

@ -4,19 +4,21 @@ USING: concurrency.promises models tools.continuations kernel
sequences concurrency.messaging locals continuations threads
namespaces namespaces.private make assocs accessors io strings
prettyprint math math.parser words effects summary io.styles classes
generic.math combinators.short-circuit ;
generic.math combinators.short-circuit kernel.private quotations ;
IN: tools.trace
: callstack-depth ( callstack -- n )
callstack>array length 2/ ;
SYMBOL: end
SYMBOL: exclude-vocabs
SYMBOL: include-vocabs
exclude-vocabs { "math" "accessors" } swap set-global
<PRIVATE
: callstack-depth ( callstack -- n )
callstack>array length 2/ ;
SYMBOL: end
: include? ( vocab -- ? )
include-vocabs get dup [ member? ] [ 2drop t ] if ;
@ -65,15 +67,20 @@ M: trace-step summary
[ CHAR: \s <string> write ]
[ number>string write ": " write ] bi ;
: trace-into? ( continuation -- ? )
continuation-current into? ;
: trace-step ( continuation -- continuation' )
dup continuation-current end eq? [
[ print-depth ]
[ print-step ]
[
dup continuation-current into?
[ continuation-step-into ] [ continuation-step ] if
] tri
] unless ;
dup call>> innermost-frame-executing quotation? [
dup continuation-current end eq? [
[ print-depth ]
[ print-step ]
[ dup trace-into? [ continuation-step-into ] [ continuation-step ] if ]
tri
] unless
] when ;
PRIVATE>
: trace ( quot -- data )
[ [ trace-step ] break-hook ] dip

4
basis/ui/ui.factor
View File

@ -145,7 +145,9 @@ SYMBOL: ui-thread
PRIVATE>
: find-window ( quot -- world )
[ windows get values ] dip '[ gadget-child @ ] find-last nip ; inline
[ windows get values ] dip
'[ dup children>> [ ] [ nip first ] if-empty @ ]
find-last nip ; inline
: ui-running? ( -- ? )
\ ui-running get-global ;

4
core/bootstrap/primitives.factor
View File

@ -231,7 +231,8 @@ bi
"vocabulary"
{ "def" { "quotation" "quotations" } initial: [ ] }
"props"
{ "direct-entry-def" }
"pic-def"
"pic-tail-def"
{ "counter" { "fixnum" "math" } }
{ "sub-primitive" read-only }
} define-builtin
@ -505,6 +506,7 @@ tuple
{ "load-locals" "locals.backend" (( ... n -- )) }
{ "check-datastack" "kernel.private" (( array in# out# -- ? )) }
{ "inline-cache-miss" "generic.single.private" (( generic methods index cache -- )) }
{ "inline-cache-miss-tail" "generic.single.private" (( generic methods index cache -- )) }
{ "mega-cache-miss" "generic.single.private" (( methods index cache -- method )) }
{ "lookup-method" "generic.single.private" (( object methods -- method )) }
{ "reset-dispatch-stats" "generic.single" (( -- )) }

2
core/generic/hook/hook.factor
View File

@ -17,8 +17,6 @@ M: hook-combination picker
M: hook-combination dispatch# drop 0 ;
M: hook-combination inline-cache-quot 2drop f ;
M: hook-combination mega-cache-quot
1quotation picker [ lookup-method (execute) ] surround ;

2
core/generic/single/single-tests.factor
View File

@ -273,5 +273,5 @@ M: growable call-next-hooker call-next-method "growable " prepend ;
[ ] [ "IN: generic.single.tests GENERIC: xyz ( a -- b )" eval( -- ) ] unit-test
[ ] [ "IN: generic.single.tests MATH: xyz ( a b -- c )" eval( -- ) ] unit-test
[ f ] [ "xyz" "generic.single.tests" lookup direct-entry-def>> ] unit-test
[ f ] [ "xyz" "generic.single.tests" lookup pic-def>> ] unit-test
[ f ] [ "xyz" "generic.single.tests" lookup "decision-tree" word-prop ] unit-test

8
core/generic/single/single.factor
View File

@ -238,10 +238,14 @@ M: f compile-engine ;
[ <engine> compile-engine ] bi
] tri ;
HOOK: inline-cache-quot combination ( word methods -- quot/f )
HOOK: inline-cache-quots combination ( word methods -- pic-quot/f pic-tail-quot/f )
M: single-combination inline-cache-quots 2drop f f ;
: define-inline-cache-quot ( word methods -- )
[ drop ] [ inline-cache-quot ] 2bi >>direct-entry-def drop ;
[ drop ] [ inline-cache-quots ] 2bi
[ >>pic-def ] [ >>pic-tail-def ] bi*
drop ;
HOOK: mega-cache-quot combination ( methods -- quot/f )

13
core/generic/standard/standard.factor
View File

@ -3,7 +3,7 @@
USING: accessors definitions generic generic.single kernel
namespaces words math math.order combinators sequences
generic.single.private quotations kernel.private
assocs arrays layouts ;
assocs arrays layouts make ;
IN: generic.standard
TUPLE: standard-combination < single-combination # ;
@ -38,17 +38,22 @@ M: standard-generic effective-method
[ datastack ] dip [ "combination" word-prop #>> swap <reversed> nth ] keep
(effective-method) ;
M: standard-combination inline-cache-quot ( word methods -- )
: inline-cache-quot ( word methods miss-word -- quot )
[ [ literalize , ] [ , ] [ combination get #>> , { } , , ] tri* ] [ ] make ;
M: standard-combination inline-cache-quots
#! Direct calls to the generic word (not tail calls or indirect calls)
#! will jump to the inline cache entry point instead of the megamorphic
#! dispatch entry point.
combination get #>> [ { } inline-cache-miss ] 3curry [ ] like ;
[ \ inline-cache-miss inline-cache-quot ]
[ \ inline-cache-miss-tail inline-cache-quot ]
2bi ;
: make-empty-cache ( -- array )
mega-cache-size get f <array> ;
M: standard-combination mega-cache-quot
combination get #>> make-empty-cache [ mega-cache-lookup ] 3curry [ ] like ;
combination get #>> make-empty-cache \ mega-cache-lookup [ ] 4sequence ;
M: standard-generic definer drop \ GENERIC# f ;

3
core/words/words.factor
View File

@ -155,7 +155,8 @@ M: word reset-word
[ subwords forget-all ]
[ reset-word ]
[
f >>direct-entry-def
f >>pic-def
f >>pic-tail-def
{
"methods"
"combination"

57
vm/code_block.cpp
View File

@ -27,7 +27,8 @@ void iterate_relocations(code_block *compiled, relocation_iterator iter)
{
case RT_PRIMITIVE:
case RT_XT:
case RT_XT_DIRECT:
case RT_XT_PIC:
case RT_XT_PIC_TAIL:
case RT_IMMEDIATE:
case RT_HERE:
case RT_UNTAGGED:
@ -171,9 +172,8 @@ void *object_xt(cell obj)
}
}
void *word_direct_xt(word *w)
static void *xt_pic(word *w, cell tagged_quot)
{
cell tagged_quot = w->direct_entry_def;
if(tagged_quot == F || max_pic_size == 0)
return w->xt;
else
@ -186,20 +186,42 @@ void *word_direct_xt(word *w)
}
}
void *word_xt_pic(word *w)
{
return xt_pic(w,w->pic_def);
}
void *word_xt_pic_tail(word *w)
{
return xt_pic(w,w->pic_tail_def);
}
void update_word_references_step(relocation_entry rel, cell index, code_block *compiled)
{
relocation_type type = REL_TYPE(rel);
if(type == RT_XT || type == RT_XT_DIRECT)
if(type == RT_XT || type == RT_XT_PIC || type == RT_XT_PIC_TAIL)
{
cell offset = REL_OFFSET(rel) + (cell)(compiled + 1);
array *literals = untag<array>(compiled->literals);
cell obj = array_nth(literals,index);
void *xt;
if(type == RT_XT)
switch(type)
{
case RT_XT:
xt = object_xt(obj);
else
xt = word_direct_xt(untag<word>(obj));
break;
case RT_XT_PIC:
xt = word_xt_pic(untag<word>(obj));
break;
case RT_XT_PIC_TAIL:
xt = word_xt_pic_tail(untag<word>(obj));
break;
default:
critical_error("Oops",type);
xt = NULL;
break;
}
store_address_in_code_block(REL_CLASS(rel),offset,(cell)xt);
}
@ -367,25 +389,30 @@ void relocate_code_block_step(relocation_entry rel, cell index, code_block *comp
array *literals = untag<array>(compiled->literals);
fixnum absolute_value;
#define ARG array_nth(literals,index)
switch(REL_TYPE(rel))
{
case RT_PRIMITIVE:
absolute_value = (cell)primitives[untag_fixnum(array_nth(literals,index))];
absolute_value = (cell)primitives[untag_fixnum(ARG)];
break;
case RT_DLSYM:
absolute_value = (cell)get_rel_symbol(literals,index);
break;
case RT_IMMEDIATE:
absolute_value = array_nth(literals,index);
absolute_value = ARG;
break;
case RT_XT:
absolute_value = (cell)object_xt(array_nth(literals,index));
absolute_value = (cell)object_xt(ARG);
break;
case RT_XT_DIRECT:
absolute_value = (cell)word_direct_xt(untag<word>(array_nth(literals,index)));
case RT_XT_PIC:
absolute_value = (cell)word_xt_pic(untag<word>(ARG));
break;
case RT_XT_PIC_TAIL:
absolute_value = (cell)word_xt_pic_tail(untag<word>(ARG));
break;
case RT_HERE:
absolute_value = offset + (short)untag_fixnum(array_nth(literals,index));
absolute_value = offset + (short)untag_fixnum(ARG);
break;
case RT_THIS:
absolute_value = (cell)(compiled + 1);
@ -394,13 +421,15 @@ void relocate_code_block_step(relocation_entry rel, cell index, code_block *comp
absolute_value = (cell)&stack_chain;
break;
case RT_UNTAGGED:
absolute_value = untag_fixnum(array_nth(literals,index));
absolute_value = untag_fixnum(ARG);
break;
default:
critical_error("Bad rel type",rel);
return; /* Can't happen */
}
#undef ARG
store_address_in_code_block(REL_CLASS(rel),offset,absolute_value);
}

8
vm/code_block.hpp
View File

@ -8,10 +8,12 @@ enum relocation_type {
RT_DLSYM,
/* a pointer to a compiled word reference */
RT_DISPATCH,
/* a word's general entry point XT */
/* a word or quotation's general entry point */
RT_XT,
/* a word's direct entry point XT */
RT_XT_DIRECT,
/* a word's PIC entry point */
RT_XT_PIC,
/* a word's tail-call PIC entry point */
RT_XT_PIC_TAIL,
/* current offset */
RT_HERE,
/* current code block */

4
vm/code_heap.cpp
View File

@ -26,8 +26,8 @@ void jit_compile_word(cell word_, cell def_, bool relocate)
word->code = def->code;
if(word->direct_entry_def != F)
jit_compile(word->direct_entry_def,relocate);
if(word->pic_def != F) jit_compile(word->pic_def,relocate);
if(word->pic_tail_def != F) jit_compile(word->pic_tail_def,relocate);
}
/* Apply a function to every code block */

5
vm/cpu-x86.32.S
View File

@ -60,9 +60,10 @@ DEF(bool,check_sse2,(void)):
ret
DEF(F_FASTCALL void,primitive_inline_cache_miss,(void)):
mov (%esp),%eax
mov (%esp),%ebx
DEF(F_FASTCALL void,primitive_inline_cache_miss_tail,(void)):
sub $8,%esp
push %eax
push %ebx
call MANGLE(inline_cache_miss)
add $12,%esp
jmp *%eax

4
vm/cpu-x86.64.S
View File

@ -73,8 +73,10 @@ DEF(void,set_callstack,(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, voi
ret /* return _with new stack_ */
DEF(F_FASTCALL void,primitive_inline_cache_miss,(void)):
mov (%rsp),ARG0
mov (%rsp),%rbx
DEF(F_FASTCALL void,primitive_inline_cache_miss_tail,(void)):
sub $STACK_PADDING,%rsp
mov %rbx,ARG0
call MANGLE(inline_cache_miss)
add $STACK_PADDING,%rsp
jmp *%rax

31
vm/cpu-x86.hpp
View File

@ -7,15 +7,29 @@ namespace factor
inline static void flush_icache(cell start, cell len) {}
/* In the instruction sequence:
MOV EBX,...
JMP blah
the offset from the immediate operand to MOV to the instruction after
the jump is a cell for the immediate operand, 4 bytes for the JMP
destination, and one byte for the JMP opcode. */
static const fixnum xt_tail_pic_offset = sizeof(cell) + 4 + 1;
static const unsigned char call_opcode = 0xe8;
static const unsigned char jmp_opcode = 0xe9;
inline static unsigned char call_site_opcode(cell return_address)
{
return *(unsigned char *)(return_address - 5);
}
inline static void check_call_site(cell return_address)
{
/* An x86 CALL instruction looks like so:
|e8|..|..|..|..|
where the ... are a PC-relative jump address.
The return_address points to right after the
instruction. */
#ifdef FACTOR_DEBUG
assert(*(unsigned char *)(return_address - 5) == 0xe8);
unsigned char opcode = call_site_opcode(return_address);
assert(opcode == call_opcode || opcode == jmp_opcode);
#endif
}
@ -31,6 +45,11 @@ inline static void set_call_target(cell return_address, void *target)
*(int *)(return_address - 4) = ((cell)target - return_address);
}
inline static bool tail_call_site_p(cell return_address)
{
return call_site_opcode(return_address) == jmp_opcode;
}
/* Defined in assembly */
VM_ASM_API void c_to_factor(cell quot);
VM_ASM_API void throw_impl(cell quot, stack_frame *rewind_to);

35
vm/inline_cache.cpp
View File

@ -86,7 +86,11 @@ struct inline_cache_jit : public jit {
inline_cache_jit(cell generic_word_) : jit(PIC_TYPE,generic_word_) {};
void emit_check(cell klass);
void compile_inline_cache(fixnum index, cell generic_word_, cell methods_, cell cache_entries_);
void compile_inline_cache(fixnum index,
cell generic_word_,
cell methods_,
cell cache_entries_,
bool tail_call_p);
};
void inline_cache_jit::emit_check(cell klass)
@ -102,7 +106,11 @@ void inline_cache_jit::emit_check(cell klass)
/* index: 0 = top of stack, 1 = item underneath, etc
cache_entries: array of class/method pairs */
void inline_cache_jit::compile_inline_cache(fixnum index, cell generic_word_, cell methods_, cell cache_entries_)
void inline_cache_jit::compile_inline_cache(fixnum index,
cell generic_word_,
cell methods_,
cell cache_entries_,
bool tail_call_p)
{
gc_root<word> generic_word(generic_word_);
gc_root<array> methods(methods_);
@ -136,20 +144,25 @@ void inline_cache_jit::compile_inline_cache(fixnum index, cell generic_word_, ce
push(methods.value());
push(tag_fixnum(index));
push(cache_entries.value());
word_jump(userenv[PIC_MISS_WORD]);
word_special(userenv[tail_call_p ? PIC_MISS_TAIL_WORD : PIC_MISS_WORD]);
}
static code_block *compile_inline_cache(fixnum index,
cell generic_word_,
cell methods_,
cell cache_entries_)
cell generic_word_,
cell methods_,
cell cache_entries_,
bool tail_call_p)
{
gc_root<word> generic_word(generic_word_);
gc_root<array> methods(methods_);
gc_root<array> cache_entries(cache_entries_);
inline_cache_jit jit(generic_word.value());
jit.compile_inline_cache(index,generic_word.value(),methods.value(),cache_entries.value());
jit.compile_inline_cache(index,
generic_word.value(),
methods.value(),
cache_entries.value(),
tail_call_p);
code_block *code = jit.to_code_block();
relocate_code_block(code);
return code;
@ -227,14 +240,18 @@ void *inline_cache_miss(cell return_address)
xt = compile_inline_cache(index,
generic_word.value(),
methods.value(),
new_cache_entries.value()) + 1;
new_cache_entries.value(),
tail_call_site_p(return_address))->xt();
}
/* Install the new stub. */
set_call_target(return_address,xt);
#ifdef PIC_DEBUG
printf("Updated call site 0x%lx with 0x%lx\n",return_address,(cell)xt);
printf("Updated %s call site 0x%lx with 0x%lx\n",
tail_call_site_p(return_address) ? "tail" : "non-tail",
return_address,
(cell)xt);
#endif
return xt;

3
vm/inline_cache.hpp
View File

@ -8,7 +8,8 @@ void init_inline_caching(int max_size);
PRIMITIVE(reset_inline_cache_stats);
PRIMITIVE(inline_cache_stats);
PRIMITIVE(inline_cache_miss);
PRIMITIVE(inline_cache_miss_tail);
extern "C" void *inline_cache_miss(cell return_address);
VM_C_API void *inline_cache_miss(cell return_address);
}

29
vm/jit.cpp
View File

@ -23,24 +23,21 @@ jit::jit(cell type_, cell owner_)
if(stack_traces_p()) literal(owner.value());
}
relocation_entry jit::rel_to_emit(cell code_template, bool *rel_p)
void jit::emit_relocation(cell code_template_)
{
array *quadruple = untag<array>(code_template);
cell rel_class = array_nth(quadruple,1);
cell rel_type = array_nth(quadruple,2);
cell offset = array_nth(quadruple,3);
gc_root<array> code_template(code_template_);
cell capacity = array_capacity(code_template.untagged());
for(cell i = 1; i < capacity; i += 3)
{
cell rel_class = array_nth(code_template.untagged(),i);
cell rel_type = array_nth(code_template.untagged(),i + 1);
cell offset = array_nth(code_template.untagged(),i + 2);
if(rel_class == F)
{
*rel_p = false;
return 0;
}
else
{
*rel_p = true;
return (untag_fixnum(rel_type) << 28)
relocation_entry new_entry
= (untag_fixnum(rel_type) << 28)
| (untag_fixnum(rel_class) << 24)
| ((code.count + untag_fixnum(offset)));
relocation.append_bytes(&new_entry,sizeof(relocation_entry));
}
}
@ -49,9 +46,7 @@ void jit::emit(cell code_template_)
{
gc_root<array> code_template(code_template_);
bool rel_p;
relocation_entry rel = rel_to_emit(code_template.value(),&rel_p);
if(rel_p) relocation.append_bytes(&rel,sizeof(relocation_entry));
emit_relocation(code_template.value());
gc_root<byte_array> insns(array_nth(code_template.untagged(),0));

12
vm/jit.hpp
View File

@ -14,7 +14,7 @@ struct jit {
jit(cell jit_type, cell owner);
void compute_position(cell offset);
relocation_entry rel_to_emit(cell code_template, bool *rel_p);
void emit_relocation(cell code_template);
void emit(cell code_template);
void literal(cell literal) { literals.add(literal); }
@ -25,17 +25,23 @@ struct jit {
}
void word_jump(cell word) {
emit_with(userenv[JIT_WORD_JUMP],word);
literal(tag_fixnum(xt_tail_pic_offset));
literal(word);
emit(userenv[JIT_WORD_JUMP]);
}
void word_call(cell word) {
emit_with(userenv[JIT_WORD_CALL],word);
}
void word_special(cell word) {
emit_with(userenv[JIT_WORD_SPECIAL],word);
}
void emit_subprimitive(cell word_) {
gc_root<word> word(word_);
gc_root<array> code_template(word->subprimitive);
if(array_nth(code_template.untagged(),1) != F) literal(T);
if(array_capacity(code_template.untagged()) > 1) literal(T);
emit(code_template.value());
}

4
vm/layouts.hpp
View File

@ -229,7 +229,9 @@ struct word : public object {
/* TAGGED property assoc for library code */
cell props;
/* TAGGED alternative entry point for direct non-tail calls. Used for inline caching */
cell direct_entry_def;
cell pic_def;
/* TAGGED alternative entry point for direct tail calls. Used for inline caching */
cell pic_tail_def;
/* TAGGED call count for profiling */
cell counter;
/* TAGGED machine code for sub-primitive */

1
vm/primitives.cpp
View File

@ -147,6 +147,7 @@ const primitive_type primitives[] = {
primitive_load_locals,
primitive_check_datastack,
primitive_inline_cache_miss,
primitive_inline_cache_miss_tail,
primitive_mega_cache_miss,
primitive_lookup_method,
primitive_reset_dispatch_stats,

24
vm/quotations.cpp
View File

@ -152,7 +152,23 @@ void quotation_jit::iterate_quotation()
{
if(stack_frame) emit(userenv[JIT_EPILOG]);
tail_call = true;
word_jump(obj.value());
/* Inline cache misses are special-cased.
The calling convention for tail
calls stores the address of the next
instruction in a register. However,
PIC miss stubs themselves tail-call
the inline cache miss primitive, and
we don't want to clobber the saved
address. */
if(obj.value() == userenv[PIC_MISS_WORD]
|| obj.value() == userenv[PIC_MISS_TAIL_WORD])
{
word_special(obj.value());
}
else
{
word_jump(obj.value());
}
}
else
word_call(obj.value());
@ -165,7 +181,6 @@ void quotation_jit::iterate_quotation()
/* Primitive calls */
if(primitive_call_p(i))
{
emit(userenv[JIT_SAVE_STACK]);
emit_with(userenv[JIT_PRIMITIVE],obj.value());
i++;
@ -187,8 +202,9 @@ void quotation_jit::iterate_quotation()
jit_compile(array_nth(elements.untagged(),i + 1),relocate);
}
emit_with(userenv[JIT_IF_1],array_nth(elements.untagged(),i));
emit_with(userenv[JIT_IF_2],array_nth(elements.untagged(),i + 1));
literal(array_nth(elements.untagged(),i));
literal(array_nth(elements.untagged(),i + 1));
emit(userenv[JIT_IF]);
i += 2;

10
vm/run.hpp
View File

@ -41,14 +41,13 @@ enum special_object {
JIT_PRIMITIVE,
JIT_WORD_JUMP,
JIT_WORD_CALL,
JIT_WORD_SPECIAL,
JIT_IF_WORD,
JIT_IF_1,
JIT_IF_2,
JIT_EPILOG = 33,
JIT_IF,
JIT_EPILOG,
JIT_RETURN,
JIT_PROFILING,
JIT_PUSH_IMMEDIATE,
JIT_SAVE_STACK = 38,
JIT_DIP_WORD,
JIT_DIP,
JIT_2DIP_WORD,
@ -60,7 +59,7 @@ enum special_object {
JIT_EXECUTE_CALL,
/* Polymorphic inline cache generation in inline_cache.c */
PIC_LOAD = 48,
PIC_LOAD = 47,
PIC_TAG,
PIC_HI_TAG,
PIC_TUPLE,
@ -69,6 +68,7 @@ enum special_object {
PIC_CHECK,
PIC_HIT,
PIC_MISS_WORD,
PIC_MISS_TAIL_WORD,
/* Megamorphic cache generation in dispatch.c */
MEGA_LOOKUP = 57,

3
vm/words.cpp
View File

@ -16,7 +16,8 @@ word *allot_word(cell vocab_, cell name_)
new_word->def = userenv[UNDEFINED_ENV];
new_word->props = F;
new_word->counter = tag_fixnum(0);
new_word->direct_entry_def = F;
new_word->pic_def = F;
new_word->pic_tail_def = F;
new_word->subprimitive = F;
new_word->profiling = NULL;
new_word->code = NULL;