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 vocabs.loader source-files definitions debugger quotations.private
sequences.private combinators math.order math.private accessors sequences.private combinators math.order math.private accessors
slots.private generic.single.private compiler.units compiler.constants slots.private generic.single.private compiler.units compiler.constants
fry ; fry bootstrap.image.syntax ;
IN: bootstrap.image IN: bootstrap.image
: arch ( os cpu -- arch ) : arch ( os cpu -- arch )
@ -93,24 +93,19 @@ CONSTANT: -1-offset 9
SYMBOL: sub-primitives SYMBOL: sub-primitives
SYMBOL: jit-define-rc SYMBOL: jit-relocations
SYMBOL: jit-define-rt
SYMBOL: jit-define-offset
: compute-offset ( -- offset ) : compute-offset ( rc -- offset )
building get length jit-define-rc get rc-absolute-cell = bootstrap-cell 4 ? - ; [ building get length ] dip rc-absolute-cell = bootstrap-cell 4 ? - ;
: jit-rel ( rc rt -- ) : jit-rel ( rc rt -- )
jit-define-rt set over compute-offset 3array jit-relocations get push-all ;
jit-define-rc set
compute-offset jit-define-offset set ;
: make-jit ( quot -- quad ) : make-jit ( quot -- jit-data )
[ [
V{ } clone jit-relocations set
call( -- ) call( -- )
jit-define-rc get jit-relocations get >array
jit-define-rt get
jit-define-offset get 3array
] B{ } make prefix ; ] B{ } make prefix ;
: jit-define ( quot name -- ) : jit-define ( quot name -- )
@ -128,98 +123,59 @@ SYMBOL: big-endian
! Bootstrap architecture name ! Bootstrap architecture name
SYMBOL: architecture SYMBOL: architecture
! Bootstrap global namesapce RESET
SYMBOL: bootstrap-global
! Boot quotation, set in stage1.factor ! Boot quotation, set in stage1.factor
SYMBOL: bootstrap-boot-quot USERENV: bootstrap-boot-quot 20
! Bootstrap global namesapce
USERENV: bootstrap-global 21
! JIT parameters ! JIT parameters
SYMBOL: jit-prolog USERENV: jit-prolog 23
SYMBOL: jit-primitive-word USERENV: jit-primitive-word 24
SYMBOL: jit-primitive USERENV: jit-primitive 25
SYMBOL: jit-word-jump USERENV: jit-word-jump 26
SYMBOL: jit-word-call USERENV: jit-word-call 27
SYMBOL: jit-push-immediate USERENV: jit-word-special 28
SYMBOL: jit-if-word USERENV: jit-if-word 29
SYMBOL: jit-if-1 USERENV: jit-if 30
SYMBOL: jit-if-2 USERENV: jit-epilog 31
SYMBOL: jit-dip-word USERENV: jit-return 32
SYMBOL: jit-dip USERENV: jit-profiling 33
SYMBOL: jit-2dip-word USERENV: jit-push-immediate 34
SYMBOL: jit-2dip USERENV: jit-dip-word 35
SYMBOL: jit-3dip-word USERENV: jit-dip 36
SYMBOL: jit-3dip USERENV: jit-2dip-word 37
SYMBOL: jit-execute-word USERENV: jit-2dip 38
SYMBOL: jit-execute-jump USERENV: jit-3dip-word 39
SYMBOL: jit-execute-call USERENV: jit-3dip 40
SYMBOL: jit-epilog USERENV: jit-execute-word 41
SYMBOL: jit-return USERENV: jit-execute-jump 42
SYMBOL: jit-profiling USERENV: jit-execute-call 43
SYMBOL: jit-save-stack
! PIC stubs ! PIC stubs
SYMBOL: pic-load USERENV: pic-load 47
SYMBOL: pic-tag USERENV: pic-tag 48
SYMBOL: pic-hi-tag USERENV: pic-hi-tag 49
SYMBOL: pic-tuple USERENV: pic-tuple 50
SYMBOL: pic-hi-tag-tuple USERENV: pic-hi-tag-tuple 51
SYMBOL: pic-check-tag USERENV: pic-check-tag 52
SYMBOL: pic-check USERENV: pic-check 53
SYMBOL: pic-hit USERENV: pic-hit 54
SYMBOL: pic-miss-word USERENV: pic-miss-word 55
USERENV: pic-miss-tail-word 56
! Megamorphic dispatch ! Megamorphic dispatch
SYMBOL: mega-lookup USERENV: mega-lookup 57
SYMBOL: mega-lookup-word USERENV: mega-lookup-word 58
SYMBOL: mega-miss-word USERENV: mega-miss-word 59
! Default definition for undefined words ! Default definition for undefined words
SYMBOL: undefined-quot USERENV: undefined-quot 60
: 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-offset ( symbol -- n ) : userenv-offset ( symbol -- n )
userenvs at header-size + ; userenvs get at header-size + ;
: emit ( cell -- ) image get push ; : emit ( cell -- ) image get push ;
@ -351,7 +307,8 @@ M: f '
[ vocabulary>> , ] [ vocabulary>> , ]
[ def>> , ] [ def>> , ]
[ props>> , ] [ props>> , ]
[ direct-entry-def>> , ] ! direct-entry-def [ pic-def>> , ]
[ pic-tail-def>> , ]
[ drop 0 , ] ! count [ drop 0 , ] ! count
[ word-sub-primitive , ] [ word-sub-primitive , ]
[ drop 0 , ] ! xt [ drop 0 , ] ! xt
@ -510,11 +467,7 @@ M: quotation '
class<=-cache class-not-cache classes-intersect-cache class<=-cache class-not-cache classes-intersect-cache
class-and-cache class-or-cache next-method-quot-cache class-and-cache class-or-cache next-method-quot-cache
} [ H{ } clone ] H{ } map>assoc assoc-union } [ H{ } clone ] H{ } map>assoc assoc-union
bootstrap-global set bootstrap-global set ;
bootstrap-global emit-userenv ;
: emit-boot-quot ( -- )
bootstrap-boot-quot emit-userenv ;
: emit-jit-data ( -- ) : emit-jit-data ( -- )
\ if jit-if-word set \ if jit-if-word set
@ -524,46 +477,13 @@ M: quotation '
\ 3dip jit-3dip-word set \ 3dip jit-3dip-word set
\ (execute) jit-execute-word set \ (execute) jit-execute-word set
\ inline-cache-miss \ pic-miss-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-lookup \ mega-lookup-word set
\ mega-cache-miss \ mega-miss-word set \ mega-cache-miss \ mega-miss-word set
[ undefined ] undefined-quot set [ undefined ] undefined-quot set ;
{
jit-prolog : emit-userenvs ( -- )
jit-primitive-word userenvs get keys [ emit-userenv ] each ;
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 ;
: fixup-header ( -- ) : fixup-header ( -- )
heap-size data-heap-size-offset fixup ; heap-size data-heap-size-offset fixup ;
@ -580,8 +500,8 @@ M: quotation '
emit-jit-data emit-jit-data
"Serializing global namespace..." print flush "Serializing global namespace..." print flush
emit-global emit-global
"Serializing boot quotation..." print flush "Serializing user environment..." print flush
emit-boot-quot emit-userenvs
"Performing word fixups..." print flush "Performing word fixups..." print flush
fixup-words fixup-words
"Performing header fixups..." print flush "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 -- ) : rel-word-pic ( word class -- )
[ add-literal ] dip rt-xt-pic rel-fixup ; [ 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 -- ) : rel-primitive ( word class -- )
[ def>> first add-literal ] dip rt-primitive rel-fixup ; [ 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. ! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: math kernel layouts system strings words quotations byte-arrays USING: math kernel layouts system strings words quotations byte-arrays
alien arrays ; alien arrays literals sequences ;
IN: compiler.constants IN: compiler.constants
! These constants must match vm/memory.h ! These constants must match vm/memory.h
@ -14,14 +14,14 @@ CONSTANT: deck-bits 18
: float-offset ( -- n ) 8 float tag-number - ; inline : float-offset ( -- n ) 8 float tag-number - ; inline
: string-offset ( -- n ) 4 bootstrap-cells string tag-number - ; inline : string-offset ( -- n ) 4 bootstrap-cells string tag-number - ; inline
: string-aux-offset ( -- n ) 2 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 : byte-array-offset ( -- n ) 2 bootstrap-cells byte-array tag-number - ; inline
: alien-offset ( -- n ) 3 bootstrap-cells alien tag-number - ; inline : alien-offset ( -- n ) 3 bootstrap-cells alien tag-number - ; inline
: underlying-alien-offset ( -- n ) bootstrap-cell alien tag-number - ; inline : underlying-alien-offset ( -- n ) bootstrap-cell alien tag-number - ; inline
: tuple-class-offset ( -- n ) bootstrap-cell tuple 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 : 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 : array-start-offset ( -- n ) 2 bootstrap-cells array tag-number - ; inline
: compiled-header-size ( -- n ) 4 bootstrap-cells ; inline : compiled-header-size ( -- n ) 4 bootstrap-cells ; inline
@ -43,14 +43,12 @@ CONSTANT: rt-dlsym 1
CONSTANT: rt-dispatch 2 CONSTANT: rt-dispatch 2
CONSTANT: rt-xt 3 CONSTANT: rt-xt 3
CONSTANT: rt-xt-pic 4 CONSTANT: rt-xt-pic 4
CONSTANT: rt-here 5 CONSTANT: rt-xt-pic-tail 5
CONSTANT: rt-this 6 CONSTANT: rt-here 6
CONSTANT: rt-immediate 7 CONSTANT: rt-this 7
CONSTANT: rt-stack-chain 8 CONSTANT: rt-immediate 8
CONSTANT: rt-untagged 9 CONSTANT: rt-stack-chain 9
CONSTANT: rt-untagged 10
: rc-absolute? ( n -- ? ) : rc-absolute? ( n -- ? )
[ rc-absolute-ppc-2/2 = ] ${ rc-absolute-ppc-2/2 rc-absolute-cell rc-absolute } member? ;
[ rc-absolute-cell = ]
[ rc-absolute = ]
tri or or ;

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 0 6 LOAD32 rc-absolute-ppc-2/2 rt-stack-chain jit-rel
7 6 0 LWZ 7 6 0 LWZ
1 7 0 STW 1 7 0 STW
] jit-save-stack jit-define
[
0 6 LOAD32 rc-absolute-ppc-2/2 rt-primitive jit-rel 0 6 LOAD32 rc-absolute-ppc-2/2 rt-primitive jit-rel
6 MTCTR 6 MTCTR
BCTR BCTR
@ -68,11 +65,8 @@ CONSTANT: rs-reg 14
0 3 \ f tag-number CMPI 0 3 \ f tag-number CMPI
2 BEQ 2 BEQ
0 B rc-relative-ppc-3 rt-xt jit-rel 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 0 B rc-relative-ppc-3 rt-xt jit-rel
] jit-if-2 jit-define ] jit-if jit-define
: jit->r ( -- ) : jit->r ( -- )
4 ds-reg 0 LWZ 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 ; 4 cells align ;
M: ppc %call ( word -- ) 0 BL rc-relative-ppc-3 rel-word-pic ; 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 %jump-label ( label -- ) B ;
M: ppc %return ( -- ) BLR ; 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-1 EAX ;
M: x86.32 param-reg-2 EDX ; M: x86.32 param-reg-2 EDX ;
M: x86.32 pic-tail-reg EBX ;
M: x86.32 reserved-area-size 0 ; M: x86.32 reserved-area-size 0 ;
M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ; 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. ! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image.private kernel namespaces system USING: bootstrap.image.private kernel namespaces system
cpu.x86.assembler layouts vocabs parser compiler.constants ; 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 temp0 0 [] MOV rc-absolute-cell rt-stack-chain jit-rel
! save stack pointer ! save stack pointer
temp0 [] stack-reg MOV temp0 [] stack-reg MOV
] jit-save-stack jit-define ! call the primitive
[
0 JMP rc-relative rt-primitive jit-rel 0 JMP rc-relative rt-primitive jit-rel
] jit-primitive jit-define ] 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 ; M: x86.64 param-reg-2 int-regs param-regs second ;
: param-reg-3 ( -- reg ) int-regs param-regs third ; inline : 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: int-regs return-reg drop RAX ;
M: float-regs return-reg drop XMM0 ; 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. ! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image.private kernel namespaces system USING: bootstrap.image.private kernel namespaces system
cpu.x86.assembler layouts vocabs parser compiler.constants math ; cpu.x86.assembler layouts vocabs parser compiler.constants math ;
@ -25,9 +25,6 @@ IN: bootstrap.x86
temp0 temp0 [] MOV temp0 temp0 [] MOV
! save stack pointer ! save stack pointer
temp0 [] stack-reg MOV temp0 [] stack-reg MOV
] jit-save-stack jit-define
[
! load XT ! load XT
temp1 0 MOV rc-absolute-cell rt-primitive jit-rel temp1 0 MOV rc-absolute-cell rt-primitive jit-rel
! go ! go

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

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

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

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

4
basis/ui/ui.factor
View File

@ -145,7 +145,9 @@ SYMBOL: ui-thread
PRIVATE> PRIVATE>
: find-window ( quot -- world ) : 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? ( -- ? )
\ ui-running get-global ; \ ui-running get-global ;

4
core/bootstrap/primitives.factor
View File

@ -231,7 +231,8 @@ bi
"vocabulary" "vocabulary"
{ "def" { "quotation" "quotations" } initial: [ ] } { "def" { "quotation" "quotations" } initial: [ ] }
"props" "props"
{ "direct-entry-def" } "pic-def"
"pic-tail-def"
{ "counter" { "fixnum" "math" } } { "counter" { "fixnum" "math" } }
{ "sub-primitive" read-only } { "sub-primitive" read-only }
} define-builtin } define-builtin
@ -505,6 +506,7 @@ tuple
{ "load-locals" "locals.backend" (( ... n -- )) } { "load-locals" "locals.backend" (( ... n -- )) }
{ "check-datastack" "kernel.private" (( array in# out# -- ? )) } { "check-datastack" "kernel.private" (( array in# out# -- ? )) }
{ "inline-cache-miss" "generic.single.private" (( generic methods index cache -- )) } { "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 )) } { "mega-cache-miss" "generic.single.private" (( methods index cache -- method )) }
{ "lookup-method" "generic.single.private" (( object methods -- method )) } { "lookup-method" "generic.single.private" (( object methods -- method )) }
{ "reset-dispatch-stats" "generic.single" (( -- )) } { "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 dispatch# drop 0 ;
M: hook-combination inline-cache-quot 2drop f ;
M: hook-combination mega-cache-quot M: hook-combination mega-cache-quot
1quotation picker [ lookup-method (execute) ] surround ; 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 GENERIC: xyz ( a -- b )" eval( -- ) ] unit-test
[ ] [ "IN: generic.single.tests MATH: xyz ( a b -- c )" 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 [ 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 [ <engine> compile-engine ] bi
] tri ; ] 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 -- ) : 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 ) 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 USING: accessors definitions generic generic.single kernel
namespaces words math math.order combinators sequences namespaces words math math.order combinators sequences
generic.single.private quotations kernel.private generic.single.private quotations kernel.private
assocs arrays layouts ; assocs arrays layouts make ;
IN: generic.standard IN: generic.standard
TUPLE: standard-combination < single-combination # ; TUPLE: standard-combination < single-combination # ;
@ -38,17 +38,22 @@ M: standard-generic effective-method
[ datastack ] dip [ "combination" word-prop #>> swap <reversed> nth ] keep [ datastack ] dip [ "combination" word-prop #>> swap <reversed> nth ] keep
(effective-method) ; (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) #! Direct calls to the generic word (not tail calls or indirect calls)
#! will jump to the inline cache entry point instead of the megamorphic #! will jump to the inline cache entry point instead of the megamorphic
#! dispatch entry point. #! 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 ) : make-empty-cache ( -- array )
mega-cache-size get f <array> ; mega-cache-size get f <array> ;
M: standard-combination mega-cache-quot 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 ; 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 ] [ subwords forget-all ]
[ reset-word ] [ reset-word ]
[ [
f >>direct-entry-def f >>pic-def
f >>pic-tail-def
{ {
"methods" "methods"
"combination" "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_PRIMITIVE:
case RT_XT: case RT_XT:
case RT_XT_DIRECT: case RT_XT_PIC:
case RT_XT_PIC_TAIL:
case RT_IMMEDIATE: case RT_IMMEDIATE:
case RT_HERE: case RT_HERE:
case RT_UNTAGGED: 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) if(tagged_quot == F || max_pic_size == 0)
return w->xt; return w->xt;
else 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) void update_word_references_step(relocation_entry rel, cell index, code_block *compiled)
{ {
relocation_type type = REL_TYPE(rel); 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); cell offset = REL_OFFSET(rel) + (cell)(compiled + 1);
array *literals = untag<array>(compiled->literals); array *literals = untag<array>(compiled->literals);
cell obj = array_nth(literals,index); cell obj = array_nth(literals,index);
void *xt; void *xt;
if(type == RT_XT) switch(type)
{
case RT_XT:
xt = object_xt(obj); xt = object_xt(obj);
else break;
xt = word_direct_xt(untag<word>(obj)); 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); 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); array *literals = untag<array>(compiled->literals);
fixnum absolute_value; fixnum absolute_value;
#define ARG array_nth(literals,index)
switch(REL_TYPE(rel)) switch(REL_TYPE(rel))
{ {
case RT_PRIMITIVE: case RT_PRIMITIVE:
absolute_value = (cell)primitives[untag_fixnum(array_nth(literals,index))]; absolute_value = (cell)primitives[untag_fixnum(ARG)];
break; break;
case RT_DLSYM: case RT_DLSYM:
absolute_value = (cell)get_rel_symbol(literals,index); absolute_value = (cell)get_rel_symbol(literals,index);
break; break;
case RT_IMMEDIATE: case RT_IMMEDIATE:
absolute_value = array_nth(literals,index); absolute_value = ARG;
break; break;
case RT_XT: case RT_XT:
absolute_value = (cell)object_xt(array_nth(literals,index)); absolute_value = (cell)object_xt(ARG);
break; break;
case RT_XT_DIRECT: case RT_XT_PIC:
absolute_value = (cell)word_direct_xt(untag<word>(array_nth(literals,index))); 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; break;
case RT_HERE: case RT_HERE:
absolute_value = offset + (short)untag_fixnum(array_nth(literals,index)); absolute_value = offset + (short)untag_fixnum(ARG);
break; break;
case RT_THIS: case RT_THIS:
absolute_value = (cell)(compiled + 1); 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; absolute_value = (cell)&stack_chain;
break; break;
case RT_UNTAGGED: case RT_UNTAGGED:
absolute_value = untag_fixnum(array_nth(literals,index)); absolute_value = untag_fixnum(ARG);
break; break;
default: default:
critical_error("Bad rel type",rel); critical_error("Bad rel type",rel);
return; /* Can't happen */ return; /* Can't happen */
} }
#undef ARG
store_address_in_code_block(REL_CLASS(rel),offset,absolute_value); 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, RT_DLSYM,
/* a pointer to a compiled word reference */ /* a pointer to a compiled word reference */
RT_DISPATCH, RT_DISPATCH,
/* a word's general entry point XT */ /* a word or quotation's general entry point */
RT_XT, RT_XT,
/* a word's direct entry point XT */ /* a word's PIC entry point */
RT_XT_DIRECT, RT_XT_PIC,
/* a word's tail-call PIC entry point */
RT_XT_PIC_TAIL,
/* current offset */ /* current offset */
RT_HERE, RT_HERE,
/* current code block */ /* 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; word->code = def->code;
if(word->direct_entry_def != F) if(word->pic_def != F) jit_compile(word->pic_def,relocate);
jit_compile(word->direct_entry_def,relocate); if(word->pic_tail_def != F) jit_compile(word->pic_tail_def,relocate);
} }
/* Apply a function to every code block */ /* 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 ret
DEF(F_FASTCALL void,primitive_inline_cache_miss,(void)): 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 sub $8,%esp
push %eax push %ebx
call MANGLE(inline_cache_miss) call MANGLE(inline_cache_miss)
add $12,%esp add $12,%esp
jmp *%eax 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_ */ ret /* return _with new stack_ */
DEF(F_FASTCALL void,primitive_inline_cache_miss,(void)): 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 sub $STACK_PADDING,%rsp
mov %rbx,ARG0
call MANGLE(inline_cache_miss) call MANGLE(inline_cache_miss)
add $STACK_PADDING,%rsp add $STACK_PADDING,%rsp
jmp *%rax jmp *%rax

31
vm/cpu-x86.hpp
View File

@ -7,15 +7,29 @@ namespace factor
inline static void flush_icache(cell start, cell len) {} 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) 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 #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 #endif
} }
@ -31,6 +45,11 @@ inline static void set_call_target(cell return_address, void *target)
*(int *)(return_address - 4) = ((cell)target - return_address); *(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 */ /* Defined in assembly */
VM_ASM_API void c_to_factor(cell quot); VM_ASM_API void c_to_factor(cell quot);
VM_ASM_API void throw_impl(cell quot, stack_frame *rewind_to); 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_) {}; inline_cache_jit(cell generic_word_) : jit(PIC_TYPE,generic_word_) {};
void emit_check(cell klass); 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) 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 /* index: 0 = top of stack, 1 = item underneath, etc
cache_entries: array of class/method pairs */ 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<word> generic_word(generic_word_);
gc_root<array> methods(methods_); 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(methods.value());
push(tag_fixnum(index)); push(tag_fixnum(index));
push(cache_entries.value()); 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, static code_block *compile_inline_cache(fixnum index,
cell generic_word_, cell generic_word_,
cell methods_, cell methods_,
cell cache_entries_) cell cache_entries_,
bool tail_call_p)
{ {
gc_root<word> generic_word(generic_word_); gc_root<word> generic_word(generic_word_);
gc_root<array> methods(methods_); gc_root<array> methods(methods_);
gc_root<array> cache_entries(cache_entries_); gc_root<array> cache_entries(cache_entries_);
inline_cache_jit jit(generic_word.value()); 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(); code_block *code = jit.to_code_block();
relocate_code_block(code); relocate_code_block(code);
return code; return code;
@ -227,14 +240,18 @@ void *inline_cache_miss(cell return_address)
xt = compile_inline_cache(index, xt = compile_inline_cache(index,
generic_word.value(), generic_word.value(),
methods.value(), methods.value(),
new_cache_entries.value()) + 1; new_cache_entries.value(),
tail_call_site_p(return_address))->xt();
} }
/* Install the new stub. */ /* Install the new stub. */
set_call_target(return_address,xt); set_call_target(return_address,xt);
#ifdef PIC_DEBUG #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 #endif
return xt; 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(reset_inline_cache_stats);
PRIMITIVE(inline_cache_stats); PRIMITIVE(inline_cache_stats);
PRIMITIVE(inline_cache_miss); 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()); 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); gc_root<array> code_template(code_template_);
cell rel_class = array_nth(quadruple,1); cell capacity = array_capacity(code_template.untagged());
cell rel_type = array_nth(quadruple,2); for(cell i = 1; i < capacity; i += 3)
cell offset = array_nth(quadruple,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) relocation_entry new_entry
{ = (untag_fixnum(rel_type) << 28)
*rel_p = false;
return 0;
}
else
{
*rel_p = true;
return (untag_fixnum(rel_type) << 28)
| (untag_fixnum(rel_class) << 24) | (untag_fixnum(rel_class) << 24)
| ((code.count + untag_fixnum(offset))); | ((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_); gc_root<array> code_template(code_template_);
bool rel_p; emit_relocation(code_template.value());
relocation_entry rel = rel_to_emit(code_template.value(),&rel_p);
if(rel_p) relocation.append_bytes(&rel,sizeof(relocation_entry));
gc_root<byte_array> insns(array_nth(code_template.untagged(),0)); 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); jit(cell jit_type, cell owner);
void compute_position(cell offset); 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 emit(cell code_template);
void literal(cell literal) { literals.add(literal); } void literal(cell literal) { literals.add(literal); }
@ -25,17 +25,23 @@ struct jit {
} }
void word_jump(cell word) { 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) { void word_call(cell word) {
emit_with(userenv[JIT_WORD_CALL],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_) { void emit_subprimitive(cell word_) {
gc_root<word> word(word_); gc_root<word> word(word_);
gc_root<array> code_template(word->subprimitive); 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()); emit(code_template.value());
} }

4
vm/layouts.hpp
View File

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

1
vm/primitives.cpp
View File

@ -147,6 +147,7 @@ const primitive_type primitives[] = {
primitive_load_locals, primitive_load_locals,
primitive_check_datastack, primitive_check_datastack,
primitive_inline_cache_miss, primitive_inline_cache_miss,
primitive_inline_cache_miss_tail,
primitive_mega_cache_miss, primitive_mega_cache_miss,
primitive_lookup_method, primitive_lookup_method,
primitive_reset_dispatch_stats, 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]); if(stack_frame) emit(userenv[JIT_EPILOG]);
tail_call = true; 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 else
word_call(obj.value()); word_call(obj.value());
@ -165,7 +181,6 @@ void quotation_jit::iterate_quotation()
/* Primitive calls */ /* Primitive calls */
if(primitive_call_p(i)) if(primitive_call_p(i))
{ {
emit(userenv[JIT_SAVE_STACK]);
emit_with(userenv[JIT_PRIMITIVE],obj.value()); emit_with(userenv[JIT_PRIMITIVE],obj.value());
i++; i++;
@ -187,8 +202,9 @@ void quotation_jit::iterate_quotation()
jit_compile(array_nth(elements.untagged(),i + 1),relocate); jit_compile(array_nth(elements.untagged(),i + 1),relocate);
} }
emit_with(userenv[JIT_IF_1],array_nth(elements.untagged(),i)); literal(array_nth(elements.untagged(),i));
emit_with(userenv[JIT_IF_2],array_nth(elements.untagged(),i + 1)); literal(array_nth(elements.untagged(),i + 1));
emit(userenv[JIT_IF]);
i += 2; i += 2;

10
vm/run.hpp
View File

@ -41,14 +41,13 @@ enum special_object {
JIT_PRIMITIVE, JIT_PRIMITIVE,
JIT_WORD_JUMP, JIT_WORD_JUMP,
JIT_WORD_CALL, JIT_WORD_CALL,
JIT_WORD_SPECIAL,
JIT_IF_WORD, JIT_IF_WORD,
JIT_IF_1, JIT_IF,
JIT_IF_2, JIT_EPILOG,
JIT_EPILOG = 33,
JIT_RETURN, JIT_RETURN,
JIT_PROFILING, JIT_PROFILING,
JIT_PUSH_IMMEDIATE, JIT_PUSH_IMMEDIATE,
JIT_SAVE_STACK = 38,
JIT_DIP_WORD, JIT_DIP_WORD,
JIT_DIP, JIT_DIP,
JIT_2DIP_WORD, JIT_2DIP_WORD,
@ -60,7 +59,7 @@ enum special_object {
JIT_EXECUTE_CALL, JIT_EXECUTE_CALL,
/* Polymorphic inline cache generation in inline_cache.c */ /* Polymorphic inline cache generation in inline_cache.c */
PIC_LOAD = 48, PIC_LOAD = 47,
PIC_TAG, PIC_TAG,
PIC_HI_TAG, PIC_HI_TAG,
PIC_TUPLE, PIC_TUPLE,
@ -69,6 +68,7 @@ enum special_object {
PIC_CHECK, PIC_CHECK,
PIC_HIT, PIC_HIT,
PIC_MISS_WORD, PIC_MISS_WORD,
PIC_MISS_TAIL_WORD,
/* Megamorphic cache generation in dispatch.c */ /* Megamorphic cache generation in dispatch.c */
MEGA_LOOKUP = 57, 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->def = userenv[UNDEFINED_ENV];
new_word->props = F; new_word->props = F;
new_word->counter = tag_fixnum(0); 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->subprimitive = F;
new_word->profiling = NULL; new_word->profiling = NULL;
new_word->code = NULL; new_word->code = NULL;