! PIC stubs
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
+USERENV: pic-tuple 49
+USERENV: pic-check-tag 50
+USERENV: pic-check-tuple 51
+USERENV: pic-hit 52
+USERENV: pic-miss-word 53
+USERENV: pic-miss-tail-word 54
! Megamorphic dispatch
USERENV: mega-lookup 57
: emit-fixnum ( n -- ) tag-fixnum emit ;
: emit-object ( class quot -- addr )
- over tag-number here-as [ swap type-number tag-fixnum emit call align-here ] dip ;
+ [ type-number ] dip over here-as
+ [ swap tag-fixnum emit call align-here ] dip ;
inline
! Write an object to the image.
M: f '
#! f is #define F RETAG(0,F_TYPE)
- drop \ f tag-number ;
+ drop \ f type-number ;
: 0, ( -- ) 0 >bignum ' 0-offset fixup ;
: 1, ( -- ) 1 >bignum ' 1-offset fixup ;
M: ##compare analyze-aliases*
call-next-method
dup useless-compare? [
- dst>> \ f tag-number \ ##load-immediate new-insn
+ dst>> \ f type-number \ ##load-immediate new-insn
analyze-aliases*
] when ;
{
byte-array
- simple-alien
alien
POSTPONE: f
} [| class |
] unit-test
[ f t ] [
- [ { fixnum simple-alien } declare <displaced-alien> 0 alien-cell ]
+ [ { fixnum alien } declare <displaced-alien> 0 alien-cell ]
[ [ ##unbox-any-c-ptr? ] contains-insn? ]
[ [ ##unbox-alien? ] contains-insn? ] bi
] unit-test
] unit-test
[ f t ] [
- [ { byte-array fixnum } declare alien-cell { simple-alien } declare 4 alien-float ]
+ [ { byte-array fixnum } declare alien-cell { alien } declare 4 alien-float ]
[ [ ##box-alien? ] contains-insn? ]
[ [ ##allot? ] contains-insn? ] bi
] unit-test
and ;
: emit-trivial-if ( -- )
- ds-pop \ f tag-number cc/= ^^compare-imm ds-push ;
+ ds-pop \ f type-number cc/= ^^compare-imm ds-push ;
: trivial-not-if? ( #if -- ? )
children>> first2
and ;
: emit-trivial-not-if ( -- )
- ds-pop \ f tag-number cc= ^^compare-imm ds-push ;
+ ds-pop \ f type-number cc= ^^compare-imm ds-push ;
: emit-actual-if ( #if -- )
! Inputs to the final instruction need to be copied because of
! loc>vreg sync
- ds-pop any-rep ^^copy \ f tag-number cc/= ##compare-imm-branch emit-if ;
+ ds-pop any-rep ^^copy \ f type-number cc/= ##compare-imm-branch emit-if ;
M: #if emit-node
{
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel sequences assocs fry
+USING: accessors kernel sequences assocs fry math
cpu.architecture layouts
compiler.cfg.rpo
compiler.cfg.registers
M: ##allot allocation-size* size>> ;
-M: ##box-alien allocation-size* drop 4 cells ;
+M: ##box-alien allocation-size* drop 5 cells ;
-M: ##box-displaced-alien allocation-size* drop 4 cells ;
+M: ##box-displaced-alien allocation-size* drop 5 cells ;
: allocation-size ( bb -- n )
- instructions>> [ ##allocation? ] filter [ allocation-size* ] map-sum ;
+ instructions>>
+ [ ##allocation? ] filter
+ [ allocation-size* data-alignment align ] map-sum ;
: insert-gc-check ( bb -- )
dup dup '[
: ^^load-literal ( obj -- dst )
[ next-vreg dup ] dip {
- { [ dup not ] [ drop \ f tag-number ##load-immediate ] }
+ { [ dup not ] [ drop \ f type-number ##load-immediate ] }
{ [ dup fixnum? ] [ tag-fixnum ##load-immediate ] }
{ [ dup float? ] [ ##load-constant ] }
[ ##load-reference ]
} cond ;
: ^^offset>slot ( slot -- vreg' )
- cell 4 = [ 1 ^^shr-imm ] [ any-rep ^^copy ] if ;
+ cell 4 = 2 1 ? ^^shr-imm ;
: ^^tag-fixnum ( src -- dst )
tag-bits get ^^shl-imm ;
: ##unbox-c-ptr ( dst src class temp -- )
{
{ [ over \ f class<= ] [ 2drop ##unbox-f ] }
- { [ over simple-alien class<= ] [ 2drop ##unbox-alien ] }
+ { [ over alien class<= ] [ 2drop ##unbox-alien ] }
{ [ over byte-array class<= ] [ 2drop ##unbox-byte-array ] }
[ nip ##unbox-any-c-ptr ]
} cond ;
IN: compiler.cfg.intrinsics.allot
: ##set-slots ( regs obj class -- )
- '[ _ swap 1 + _ tag-number ##set-slot-imm ] each-index ;
+ '[ _ swap 1 + _ type-number ##set-slot-imm ] each-index ;
: emit-simple-allot ( node -- )
[ in-d>> length ] [ node-output-infos first class>> ] bi
] [ drop emit-primitive ] if ;
: store-length ( len reg class -- )
- [ [ ^^load-literal ] dip 1 ] dip tag-number ##set-slot-imm ;
+ [ [ ^^load-literal ] dip 1 ] dip type-number ##set-slot-imm ;
:: store-initial-element ( len reg elt class -- )
- len [ [ elt reg ] dip 2 + class tag-number ##set-slot-imm ] each ;
+ len [ [ elt reg ] dip 2 + class type-number ##set-slot-imm ] each ;
: expand-<array>? ( obj -- ? )
dup integer? [ 0 8 between? ] [ drop f ] if ;
ds-push ;
: tag-literal ( n -- tagged )
- literal>> [ tag-fixnum ] [ \ f tag-number ] if* ;
+ literal>> [ tag-fixnum ] [ \ f type-number ] if* ;
: emit-fixnum-op ( insn -- )
[ 2inputs ] dip call ds-push ; inline
compiler.cfg.builder.blocks compiler.constants ;
IN: compiler.cfg.intrinsics.slots
-: value-tag ( info -- n ) class>> class-tag ; inline
+: value-tag ( info -- n ) class>> type-number ; inline
: ^^tag-offset>slot ( slot tag -- vreg' )
[ ^^offset>slot ] dip ^^sub-imm ;
int-rep next-vreg-rep :> temp
dst 16 2 cells + byte-array int-rep next-vreg-rep ##allot
temp 16 tag-fixnum ##load-immediate
- temp dst 1 byte-array tag-number ##set-slot-imm
+ temp dst 1 byte-array type-number ##set-slot-imm
dst byte-array-offset src rep ##set-alien-vector ;
M: vector-rep emit-unbox
dup ##compare-imm-branch? [
{
[ cc>> cc/= eq? ]
- [ src2>> \ f tag-number eq? ]
+ [ src2>> \ f type-number eq? ]
} 1&&
] [ drop f ] if ; inline
: rewrite-redundant-comparison? ( insn -- ? )
{
[ src1>> vreg>expr general-compare-expr? ]
- [ src2>> \ f tag-number = ]
+ [ src2>> \ f type-number = ]
[ cc>> { cc= cc/= } member-eq? ]
} 1&& ; inline
[ dst>> ] dip
{
{ t [ t \ ##load-constant new-insn ] }
- { f [ \ f tag-number \ ##load-immediate new-insn ] }
+ { f [ \ f type-number \ ##load-immediate new-insn ] }
} case ;
: rewrite-self-compare ( insn -- insn' )
! These constants must match vm/layouts.h
: slot-offset ( slot tag -- n ) [ bootstrap-cells ] dip - ; inline
-: header-offset ( -- n ) 0 object tag-number slot-offset ; inline
-: float-offset ( -- n ) 8 float tag-number - ; inline
-: string-offset ( -- n ) 4 string tag-number slot-offset ; inline
-: string-aux-offset ( -- n ) 2 string tag-number slot-offset ; inline
-: profile-count-offset ( -- n ) 8 \ word tag-number slot-offset ; inline
-: byte-array-offset ( -- n ) 16 byte-array tag-number - ; inline
-: alien-offset ( -- n ) 3 alien tag-number slot-offset ; inline
-: underlying-alien-offset ( -- n ) 1 alien tag-number slot-offset ; inline
-: tuple-class-offset ( -- n ) 1 tuple tag-number slot-offset ; inline
-: word-xt-offset ( -- n ) 10 \ word tag-number slot-offset ; inline
-: quot-xt-offset ( -- n ) 4 quotation tag-number slot-offset ; inline
-: word-code-offset ( -- n ) 11 \ word tag-number slot-offset ; inline
-: array-start-offset ( -- n ) 2 array tag-number slot-offset ; inline
+: float-offset ( -- n ) 8 float type-number - ; inline
+: string-offset ( -- n ) 4 string type-number slot-offset ; inline
+: string-aux-offset ( -- n ) 2 string type-number slot-offset ; inline
+: profile-count-offset ( -- n ) 8 \ word type-number slot-offset ; inline
+: byte-array-offset ( -- n ) 16 byte-array type-number - ; inline
+: alien-offset ( -- n ) 4 alien type-number slot-offset ; inline
+: underlying-alien-offset ( -- n ) 1 alien type-number slot-offset ; inline
+: tuple-class-offset ( -- n ) 1 tuple type-number slot-offset ; inline
+: word-xt-offset ( -- n ) 10 \ word type-number slot-offset ; inline
+: quot-xt-offset ( -- n ) 4 quotation type-number slot-offset ; inline
+: word-code-offset ( -- n ) 11 \ word type-number slot-offset ; inline
+: array-start-offset ( -- n ) 2 array type-number slot-offset ; inline
: compiled-header-size ( -- n ) 4 bootstrap-cells ; inline
! Relocation classes
] compile-call
] unit-test
-[ 1 t ] [
- B{ 1 2 3 4 } [
- { c-ptr } declare
- [ 0 alien-unsigned-1 ] keep hi-tag
- ] compile-call byte-array type-number =
-] unit-test
-
-[ t ] [
- B{ 1 2 3 4 } [
- { c-ptr } declare
- 0 alien-cell hi-tag
- ] compile-call alien type-number =
-] unit-test
-
[ 2 1 ] [
2 1
[ 2dup fixnum< [ [ die ] dip ] when ] compile-call
"b" get [
[ 3 ] [ "b" get 2 [ alien-unsigned-1 ] compile-call ] unit-test
[ 3 ] [ "b" get [ { alien } declare 2 alien-unsigned-1 ] compile-call ] unit-test
- [ 3 ] [ "b" get 2 [ { simple-alien fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
+ [ 3 ] [ "b" get 2 [ { alien fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
[ 3 ] [ "b" get 2 [ { c-ptr fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
[ ] [ "b" get free ] unit-test
! one of the sources
[ t ] [
V{
- T{ ##load-immediate f 1 $[ 2 cell log2 shift array tag-number - ] }
+ T{ ##load-immediate f 1 $[ 2 cell log2 shift array type-number - ] }
T{ ##load-reference f 0 { t f t } }
T{ ##slot f 0 0 1 }
} compile-test-bb
[ t ] [
V{
T{ ##load-reference f 0 { t f t } }
- T{ ##slot-imm f 0 0 2 $[ array tag-number ] }
+ T{ ##slot-imm f 0 0 2 $[ array type-number ] }
} compile-test-bb
] unit-test
[ t ] [
V{
- T{ ##load-immediate f 1 $[ 2 cell log2 shift array tag-number - ] }
+ T{ ##load-immediate f 1 $[ 2 cell log2 shift array type-number - ] }
T{ ##load-reference f 0 { t f t } }
T{ ##set-slot f 0 0 1 }
} compile-test-bb
[ t ] [
V{
T{ ##load-reference f 0 { t f t } }
- T{ ##set-slot-imm f 0 0 2 $[ array tag-number ] }
+ T{ ##set-slot-imm f 0 0 2 $[ array type-number ] }
} compile-test-bb
dup first eq?
] unit-test
] each
\ alien-cell [
- 2drop simple-alien \ f class-or <class-info>
+ 2drop alien \ f class-or <class-info>
] "outputs" set-word-prop
{ <tuple> <tuple-boa> } [
[ { 1 2 3 } dup tuple-with-read-only-slot boa clone x>> eq? ] final-classes
] unit-test
-! alien-cell outputs a simple-alien or f
+! alien-cell outputs a alien or f
[ t ] [
[ { byte-array fixnum } declare alien-cell dup [ "OOPS" throw ] unless ] final-classes
- first simple-alien class=
+ first alien class=
] unit-test
! Don't crash if bad literal inputs are passed to unsafe words
[\r
3 ds-reg 0 LWZ\r
ds-reg dup 4 SUBI\r
- 0 3 \ f tag-number CMPI\r
+ 0 3 \ f type-number CMPI\r
2 BEQ\r
0 B rc-relative-ppc-3 rt-xt jit-rel\r
0 B rc-relative-ppc-3 rt-xt jit-rel\r
\r
[ load-tag ] pic-tag jit-define\r
\r
-! Hi-tag\r
-[\r
- 3 4 MR\r
- load-tag\r
- 0 4 object tag-number tag-fixnum CMPI\r
- 2 BNE\r
- 4 3 object tag-number neg LWZ\r
-] pic-hi-tag jit-define\r
-\r
! Tuple\r
[\r
3 4 MR\r
load-tag\r
- 0 4 tuple tag-number tag-fixnum CMPI\r
+ 0 4 tuple type-number tag-fixnum CMPI\r
2 BNE\r
- 4 3 tuple tag-number neg bootstrap-cell + LWZ\r
+ 4 3 tuple type-number neg bootstrap-cell + LWZ\r
] pic-tuple jit-define\r
\r
-! Hi-tag and tuple\r
-[\r
- 3 4 MR\r
- load-tag\r
- ! If bits 2 and 3 are set, the tag is either 6 (object) or 7 (tuple)\r
- 0 4 BIN: 110 tag-fixnum CMPI\r
- 5 BLT\r
- ! Untag r3\r
- 3 3 0 0 31 tag-bits get - RLWINM\r
- ! Set r4 to 0 for objects, and bootstrap-cell for tuples\r
- 4 4 1 tag-fixnum ANDI\r
- 4 4 1 SRAWI\r
- ! Load header cell or tuple layout cell\r
- 4 4 3 LWZX\r
-] pic-hi-tag-tuple jit-define\r
-\r
[\r
0 4 0 CMPI rc-absolute-ppc-2 rt-immediate jit-rel\r
] pic-check-tag jit-define\r
[\r
0 5 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel\r
4 0 5 CMP\r
-] pic-check jit-define\r
+] pic-check-tuple jit-define\r
\r
[ 2 BNE 0 B rc-relative-ppc-3 rt-xt jit-rel ] pic-hit jit-define\r
\r
[\r
3 ds-reg 0 LWZ\r
4 ds-reg -4 LWZU\r
- 3 3 1 SRAWI\r
+ 3 3 2 SRAWI\r
4 4 0 0 31 tag-bits get - RLWINM\r
4 3 3 LWZX\r
3 ds-reg 0 STW\r
5 ds-reg -4 LWZU\r
5 0 4 CMP\r
2 swap execute( offset -- ) ! magic number\r
- \ f tag-number 3 LI\r
+ \ f type-number 3 LI\r
3 ds-reg 0 STW ;\r
\r
: define-jit-compare ( insn word -- )\r
4 ds-reg 0 LWZ\r
3 3 4 OR\r
3 3 tag-mask get ANDI\r
- \ f tag-number 4 LI\r
+ \ f type-number 4 LI\r
0 3 0 CMPI\r
2 BNE\r
1 tag-fixnum 4 LI\r
! We come back here with displaced aliens
"start" resolve-label
! Is the object f?
- 0 scratch-reg \ f tag-number CMPI
+ 0 scratch-reg \ f type-number CMPI
! If so, done
"end" get BEQ
! Is the object an alien?
"end" resolve-label
] with-scope ;
-: alien@ ( n -- n' ) cells object tag-number - ;
-
-:: %allot-alien ( dst displacement base temp -- )
- dst 4 cells alien temp %allot
- temp \ f tag-number %load-immediate
- ! Store underlying-alien slot
- base dst 1 alien@ STW
- ! Store expired slot
- temp dst 2 alien@ STW
- ! Store offset
- displacement dst 3 alien@ STW ;
+: alien@ ( n -- n' ) cells alien type-number - ;
M:: ppc %box-alien ( dst src temp -- )
[
"f" define-label
- dst \ f tag-number %load-immediate
+ dst %load-immediate
0 src 0 CMPI
"f" get BEQ
- dst src temp temp %allot-alien
+ dst 5 cells alien temp %allot
+ temp \ f type-number %load-immediate
+ temp dst 1 alien@ STW
+ temp dst 2 alien@ STW
+ displacement dst 3 alien@ STW
+ displacement dst 4 alien@ STW
"f" resolve-label
] with-scope ;
displacement' :> temp
dst 4 cells alien temp %allot
! If base is already a displaced alien, unpack it
- 0 base \ f tag-number CMPI
+ 0 base \ f type-number CMPI
"simple-case" get BEQ
temp base header-offset LWZ
0 temp alien type-number tag-fixnum CMPI
! Store offset
displacement' dst 3 alien@ STW
! Store expired slot (its ok to clobber displacement')
- temp \ f tag-number %load-immediate
+ temp \ f type-number %load-immediate
temp dst 2 alien@ STW
"end" resolve-label
] with-scope ;
scratch-reg dst 0 STW ;
: store-tagged ( dst tag -- )
- dupd tag-number ORI ;
+ dupd type-number ORI ;
M:: ppc %allot ( dst size class nursery-ptr -- )
nursery-ptr dst load-allot-ptr
:: (%boolean) ( dst temp branch1 branch2 -- )
"end" define-label
- dst \ f tag-number %load-immediate
+ dst \ f type-number %load-immediate
"end" get branch1 execute( label -- )
branch2 [ "end" get branch2 execute( label -- ) ] when
dst \ t %load-reference
: stack-reg ( -- reg ) ESP ;
: ds-reg ( -- reg ) ESI ;
: rs-reg ( -- reg ) EDI ;
-: fixnum>slot@ ( -- ) temp0 1 SAR ;
+: fixnum>slot@ ( -- ) temp0 2 SAR ;
: rex-length ( -- n ) 0 ;
[
: stack-reg ( -- reg ) RSP ;
: ds-reg ( -- reg ) R14 ;
: rs-reg ( -- reg ) R15 ;
-: fixnum>slot@ ( -- ) ;
+: fixnum>slot@ ( -- ) temp0 1 SAR ;
: rex-length ( -- n ) 1 ;
[
! pop boolean
ds-reg bootstrap-cell SUB
! compare boolean with f
- temp0 \ f tag-number CMP
+ temp0 \ f type-number CMP
! jump to true branch if not equal
0 JNE rc-relative rt-xt jit-rel
! jump to false branch if equal
! ! ! Polymorphic inline caches
-! The PIC and megamorphic code stubs are not permitted to touch temp3.
+! The PIC stubs are not permitted to touch temp3.
! Load a value from a stack position
[
! The 'make' trick lets us compute the jump distance for the
! conditional branches there
-! Hi-tag
-[
- temp0 temp1 MOV
- load-tag
- temp1 object tag-number tag-fixnum CMP
- [ temp1 temp0 object tag-number neg [+] MOV ] { } make
- [ length JNE ] [ % ] bi
-] pic-hi-tag jit-define
-
! Tuple
[
temp0 temp1 MOV
load-tag
- temp1 tuple tag-number tag-fixnum CMP
- [ temp1 temp0 tuple tag-number neg bootstrap-cell + [+] MOV ] { } make
+ temp1 tuple type-number tag-fixnum CMP
+ [ temp1 temp0 tuple type-number neg bootstrap-cell + [+] MOV ] { } make
[ length JNE ] [ % ] bi
] pic-tuple jit-define
-! Hi-tag and tuple
-[
- temp0 temp1 MOV
- load-tag
- ! If bits 2 and 3 are set, the tag is either 6 (object) or 7 (tuple)
- temp1 BIN: 110 tag-fixnum CMP
- [
- ! Untag temp0
- temp0 tag-mask get bitnot AND
- ! Set temp1 to 0 for objects, and bootstrap-cell for tuples
- temp1 1 tag-fixnum AND
- bootstrap-cell 4 = [ temp1 1 SHR ] when
- ! Load header cell or tuple layout cell
- temp1 temp0 temp1 [+] MOV
- ] [ ] make [ length JL ] [ % ] bi
-] pic-hi-tag-tuple jit-define
-
[
temp1 HEX: ffffffff CMP rc-absolute rt-immediate jit-rel
] pic-check-tag jit-define
[
temp2 HEX: ffffffff MOV rc-absolute-cell rt-immediate jit-rel
temp1 temp2 CMP
-] pic-check jit-define
+] pic-check-tuple jit-define
[ 0 JE rc-relative rt-xt jit-rel ] pic-hit jit-define
temp0 0 MOV rc-absolute-cell rt-immediate jit-rel
! key = hashcode(class)
temp2 temp1 MOV
- temp2 3 SHR
- temp3 temp1 MOV
- temp3 8 SHR
- temp2 temp3 ADD
- temp3 temp1 MOV
- temp3 13 SHR
- temp2 temp3 ADD
- temp2 bootstrap-cell 4 = 3 4 ? SHL
+ bootstrap-cell 4 = [ temp2 1 SHR ] when
! key &= cache.length - 1
temp2 mega-cache-size get 1 - bootstrap-cell * AND
! cache += array-start-offset
t jit-literal
temp3 0 MOV rc-absolute-cell rt-immediate jit-rel
! load f
- temp1 \ f tag-number MOV
+ temp1 \ f type-number MOV
! load first value
temp0 ds-reg [] MOV
! adjust stack pointer
ds-reg bootstrap-cell SUB
temp0 ds-reg [] OR
temp0 tag-mask get AND
- temp0 \ f tag-number MOV
+ temp0 \ f type-number MOV
temp1 1 tag-fixnum MOV
temp0 temp1 CMOVE
ds-reg [] temp0 MOV
M:: x86 %unbox-any-c-ptr ( dst src temp -- )
[
- { "is-byte-array" "end" "start" } [ define-label ] each
- dst 0 MOV
+ "end" define-label
+ ! Compute tag in temp register
temp src MOV
- ! We come back here with displaced aliens
- "start" resolve-label
+ temp tag-mask get AND
+ dst 0 MOV
! Is the object f?
- temp \ f tag-number CMP
+ src \ f type-number CMP
"end" get JE
+ ! Add an offset to start of byte array's data
+ dst src byte-array-offset [+] LEA
! Is the object an alien?
- temp header-offset [+] alien type-number tag-fixnum CMP
- "is-byte-array" get JNE
+ temp alien type-number CMP
+ "end" get JNE
! If so, load the offset and add it to the address
- dst temp alien-offset [+] ADD
- ! Now recurse on the underlying alien
- temp temp underlying-alien-offset [+] MOV
- "start" get JMP
- "is-byte-array" resolve-label
- ! Add byte array address to address being computed
- dst temp ADD
- ! Add an offset to start of byte array's data
- dst byte-array-offset ADD
+ dst src alien-offset [+] MOV
"end" resolve-label
] with-scope ;
-: alien@ ( reg n -- op ) cells alien tag-number - [+] ;
-
-:: %allot-alien ( dst displacement base temp -- )
- dst 4 cells alien temp %allot
- dst 1 alien@ base MOV ! alien
- dst 2 alien@ \ f tag-number MOV ! expired
- dst 3 alien@ displacement MOV ! displacement
- ;
+: alien@ ( reg n -- op ) cells alien type-number - [+] ;
M:: x86 %box-alien ( dst src temp -- )
[
"end" define-label
- dst \ f tag-number MOV
+ dst \ f type-number MOV
src 0 CMP
"end" get JE
- dst src \ f tag-number temp %allot-alien
+ dst 5 cells alien temp %allot
+ dst 1 alien@ \ f type-number MOV ! base
+ dst 2 alien@ \ f type-number MOV ! expired
+ dst 3 alien@ displacement MOV ! displacement
+ dst 4 alien@ displacement MOV ! address
"end" resolve-label
] with-scope ;
! If base is already a displaced alien, unpack it
base' base MOV
displacement' displacement MOV
- base \ f tag-number CMP
+ base \ f type-number CMP
"ok" get JE
- base header-offset [+] alien type-number tag-fixnum CMP
+ ! XXX
+ base 0 [+] alien type-number tag-fixnum CMP
"ok" get JNE
! displacement += base.displacement
displacement' base 3 alien@ ADD
base' base 1 alien@ MOV
"ok" resolve-label
dst 1 alien@ base' MOV ! alien
- dst 2 alien@ \ f tag-number MOV ! expired
+ dst 2 alien@ \ f type-number MOV ! expired
dst 3 alien@ displacement' MOV ! displacement
"end" resolve-label
] with-scope ;
[ [] ] [ type-number tag-fixnum ] bi* MOV ;
: store-tagged ( dst tag -- )
- tag-number OR ;
+ type-number OR ;
M:: x86 %allot ( dst size class nursery-ptr -- )
nursery-ptr dst load-allot-ptr
M: x86 %epilogue ( n -- ) cell - incr-stack-reg ;
:: %boolean ( dst temp word -- )
- dst \ f tag-number MOV
+ dst \ f type-number MOV
temp 0 MOV \ t rc-absolute-cell rel-immediate
dst temp word execute ; inline
TUPLE: buffer
{ size fixnum }
-{ ptr simple-alien }
+{ ptr alien }
{ fill fixnum }
{ pos fixnum }
disposed ;
\ set-alien-double { float c-ptr integer } { } define-primitive
-\ alien-cell { c-ptr integer } { simple-c-ptr } define-primitive
+\ alien-cell { c-ptr integer } { pinned-c-ptr } define-primitive
\ alien-cell make-flushable
\ set-alien-cell { c-ptr c-ptr integer } { } define-primitive
: dispatch-stats. ( stats -- )
"== Megamorphic caches ==" print nl
- { "Hits" "Misses" } swap zip simple-table. ;
+ [ { "Hits" "Misses" } ] dip zip simple-table. ;
: inline-cache-stats. ( stats -- )
"== Polymorphic inline caches ==" print nl
3 cut
[
"- Transitions:" print
- { "Cold to monomorphic" "Mono to polymorphic" "Poly to megamorphic" } swap zip
+ [ { "Cold to monomorphic" "Mono to polymorphic" "Poly to megamorphic" } ] dip zip
simple-table. nl
] [
"- Type check stubs:" print
- { "Tag only" "Hi-tag" "Tuple" "Hi-tag and tuple" } swap zip
+ [ { "Tag" "Tuple" } ] dip zip
simple-table.
] bi* ;
kernel.private byte-arrays arrays init ;
IN: alien
-! Some predicate classes used by the compiler for optimization
-! purposes
-PREDICATE: simple-alien < alien underlying>> not ;
+PREDICATE: pinned-alien < alien underlying>> not ;
-UNION: simple-c-ptr
-simple-alien POSTPONE: f byte-array ;
-
-DEFER: pinned-c-ptr?
-
-PREDICATE: pinned-alien < alien underlying>> pinned-c-ptr? ;
-
-UNION: pinned-c-ptr
- pinned-alien POSTPONE: f ;
+UNION: pinned-c-ptr pinned-alien POSTPONE: f ;
GENERIC: >c-ptr ( obj -- c-ptr )
M: f expired? drop t ;
: <alien> ( address -- alien )
- f <displaced-alien> { simple-c-ptr } declare ; inline
+ f <displaced-alien> { pinned-c-ptr } declare ; inline
: <bad-alien> ( -- alien )
-1 <alien> t >>expired ; inline
16 data-alignment set
-BIN: 111 tag-mask set
-8 num-tags set
-3 tag-bits set
+BIN: 1111 tag-mask set
+4 tag-bits set
-15 num-types set
+14 num-types set
32 mega-cache-size set
H{
- { fixnum BIN: 000 }
- { bignum BIN: 001 }
- { array BIN: 010 }
- { float BIN: 011 }
- { quotation BIN: 100 }
- { POSTPONE: f BIN: 101 }
- { object BIN: 110 }
- { hi-tag BIN: 110 }
- { tuple BIN: 111 }
-} tag-numbers set
-
-tag-numbers get H{
+ { fixnum 0 }
+ { bignum 1 }
+ { array 2 }
+ { float 3 }
+ { quotation 4 }
+ { POSTPONE: f 5 }
+ { alien 6 }
+ { tuple 7 }
{ wrapper 8 }
{ byte-array 9 }
{ callstack 10 }
{ string 11 }
{ word 12 }
{ dll 13 }
- { alien 14 }
-} assoc-union type-numbers set
+} type-numbers set
"object?" "kernel" vocab-words delete-at
-! Class of objects with object tag
-"hi-tag" "kernel.private" create
-builtins get num-tags get tail define-union-class
-
! Empty class with no instances
"null" "kernel" create
[ f { } f union-class define-class ]
flatten-class\r
flatten-builtin-class\r
class-types\r
- class-tags\r
} ;\r
\r
ARTICLE: "class-linearization" "Class linearization"\r
\r
[ f ] [ a1 c1 class-or b1 c1 class-or class-and a1 b1 class-or classes-intersect? ] unit-test\r
\r
-[ f ] [ growable \ hi-tag classes-intersect? ] unit-test\r
-\r
[ t ] [\r
growable tuple sequence class-and class<=\r
] unit-test\r
flatten-builtin-class keys\r
[ "type" word-prop ] map natural-sort ;\r
\r
-: class-tags ( class -- seq )\r
- class-types [\r
- dup num-tags get >=\r
- [ drop \ hi-tag tag-number ] when\r
- ] map prune ;\r
-\r
-: class-tag ( class -- tag/f )\r
- class-tags dup length 1 = [ first ] [ drop f ] if ;\r
+: class-type ( class -- tag/f )\r
+ class-types dup length 1 = [ first ] [ drop f ] if ;\r
: class>type ( class -- n ) "type" word-prop ; foldable
-PREDICATE: lo-tag-class < builtin-class class>type 7 <= ;
-
-PREDICATE: hi-tag-class < builtin-class class>type 7 > ;
-
: type>class ( n -- class ) builtins get-global nth ;
: bootstrap-type>class ( n -- class ) builtins get nth ;
-M: hi-tag class hi-tag type>class ; inline
-
M: object class tag type>class ; inline
M: builtin-class rank-class drop 0 ;
GENERIC: define-builtin-predicate ( class -- )
-M: lo-tag-class define-builtin-predicate
+M: builtin-class define-builtin-predicate
dup class>type [ eq? ] curry [ tag ] prepend define-predicate ;
-M: hi-tag-class define-builtin-predicate
- dup class>type [ eq? ] curry [ hi-tag ] prepend 1quotation
- [ dup tag 6 eq? ] [ [ drop f ] if ] surround
- define-predicate ;
-
-M: lo-tag-class instance? [ tag ] [ class>type ] bi* eq? ;
-
-M: hi-tag-class instance?
- over tag 6 eq? [ [ hi-tag ] [ class>type ] bi* eq? ] [ 2drop f ] if ;
+M: builtin-class instance? [ tag ] [ class>type ] bi* eq? ;
M: builtin-class (flatten-class) dup set ;
[ f ] [ 3 float instance? ] unit-test
[ t ] [ 3 number instance? ] unit-test
[ f ] [ 3 null instance? ] unit-test
-[ t ] [ "hi" \ hi-tag instance? ] unit-test
! Regression
GENERIC: method-forget-test ( obj -- obj )
tuple bootstrap-word
\ <tuple-dispatch-engine> convert-methods ;
-! 2.2 Convert hi-tag methods
-TUPLE: hi-tag-dispatch-engine methods ;
-
-C: <hi-tag-dispatch-engine> hi-tag-dispatch-engine
-
-: convert-hi-tag-methods ( assoc -- assoc' )
- \ hi-tag bootstrap-word
- \ <hi-tag-dispatch-engine> convert-methods ;
-
! 3 Tag methods
TUPLE: tag-dispatch-engine methods ;
: <engine> ( assoc -- engine )
flatten-methods
convert-tuple-methods
- convert-hi-tag-methods
<tag-dispatch-engine> ;
! ! ! Compile engine ! ! !
: direct-dispatch-table ( assoc n -- table )
default get <array> [ <enum> swap update ] keep ;
-: lo-tag-number ( class -- n )
- "type" word-prop dup num-tags get iota member?
- [ drop object tag-number ] unless ;
+: tag-number ( class -- n ) "type" word-prop ;
M: tag-dispatch-engine compile-engine
methods>> compile-engines*
- [ [ lo-tag-number ] dip ] assoc-map
- num-tags get direct-dispatch-table ;
-
-: num-hi-tags ( -- n ) num-types get num-tags get - ;
-
-: hi-tag-number ( class -- n ) "type" word-prop ;
-
-M: hi-tag-dispatch-engine compile-engine
- methods>> compile-engines*
- [ [ hi-tag-number num-tags get - ] dip ] assoc-map
- num-hi-tags direct-dispatch-table ;
+ [ [ tag-number ] dip ] assoc-map
+ num-types get direct-dispatch-table ;
: build-fast-hash ( methods -- buckets )
>alist V{ } clone [ hashcode 1array ] distribute-buckets
HELP: tag ( object -- n )
{ $values { "object" object } { "n" "a tag number" } }
-{ $description "Outputs an object's tag number, between zero and one less than " { $link num-tags } ". This is implementation detail and user code should call " { $link class } " instead." } ;
+{ $description "Outputs an object's tag number, between zero and one less than " { $link num-types } ". This is implementation detail and user code should call " { $link class } " instead." } ;
HELP: getenv ( n -- obj )
{ $values { "n" "a non-negative integer" } { "obj" object } }
: declare ( spec -- ) drop ;
-: hi-tag ( obj -- n ) { hi-tag } declare 0 slot ; inline
-
: do-primitive ( number -- ) "Improper primitive call" throw ;
PRIVATE>
{ $var-description "Number of least significant bits reserved for a type tag in a tagged pointer." }
{ $see-also tag } ;
-HELP: num-tags
-{ $var-description "Number of distinct pointer tags. This is one more than the maximum value from the " { $link tag } " primitive." } ;
-
HELP: tag-mask
{ $var-description "Taking the bitwise and of a tagged pointer with this mask leaves the tag." } ;
HELP: num-types
-{ $var-description "Number of distinct built-in types. This is one more than the maximum value from the " { $link hi-tag } " primitive." } ;
-
-HELP: tag-number
-{ $values { "class" class } { "n" "an integer or " { $link f } } }
-{ $description "Outputs the pointer tag for pointers to instances of " { $link class } ". Will output " { $link f } " if instances of this class are not identified by a distinct pointer tag." } ;
+{ $var-description "Number of distinct built-in types. This is one more than the maximum value from the " { $link tag } " primitive." } ;
HELP: type-number
{ $values { "class" class } { "n" "an integer or " { $link f } } }
ARTICLE: "layouts-types" "Type numbers"
"Corresponding to every built-in class is a built-in type number. An object can be asked for its built-in type number:"
-{ $subsections hi-tag }
+{ $subsections tag }
"Built-in type numbers can be converted to classes, and vice versa:"
{ $subsections
type>class
ARTICLE: "layouts-tags" "Tagged pointers"
"Every pointer stored on the stack or in the heap has a " { $emphasis "tag" } ", which is a small integer identifying the type of the pointer. If the tag is not equal to one of the two special tags, the remaining bits contain the memory address of a heap-allocated object. The two special tags are the " { $link fixnum } " tag and the " { $link f } " tag."
$nl
-"Getting the tag of an object:"
-{ $link tag }
"Words for working with tagged pointers:"
{ $subsections
tag-bits
- num-tags
tag-mask
- tag-number
}
"The Factor VM does not actually expose any words for working with tagged pointers directly. The above words operate on integers; they are used in the bootstrap image generator and the optimizing compiler." ;
SYMBOL: tag-mask
-SYMBOL: num-tags
-
SYMBOL: tag-bits
SYMBOL: num-types
-SYMBOL: tag-numbers
-
SYMBOL: type-numbers
SYMBOL: mega-cache-size
: type-number ( class -- n )
type-numbers get at ;
-: tag-number ( class -- n )
- type-number dup num-tags get >= [ drop object tag-number ] when ;
-
: tag-fixnum ( n -- tagged )
tag-bits get shift ;
alien *ptr = untag<alien>(obj);
if(to_boolean(ptr->expired))
general_error(ERROR_EXPIRED,obj,false_object,NULL);
- return pinned_alien_offset(ptr->base) + ptr->displacement;
+ if(to_boolean(ptr->base))
+ type_error(ALIEN_TYPE,obj);
+ else
+ return (char *)ptr->address;
}
case F_TYPE:
return NULL;
new_alien->displacement = displacement;
new_alien->expired = false_object;
+ new_alien->update_address();
return new_alien.value();
}
case BYTE_ARRAY_TYPE:
return untag<byte_array>(obj)->data<char>();
case ALIEN_TYPE:
- {
- alien *ptr = untag<alien>(obj);
- if(to_boolean(ptr->expired))
- general_error(ERROR_EXPIRED,obj,false_object,NULL);
- return alien_offset(ptr->base) + ptr->displacement;
- }
+ return (char *)untag<alien>(obj)->address;
case F_TYPE:
return NULL;
default:
workhorse.visit_handle(handle);
}
- void trace_slots(object *ptr)
+ void trace_object(object *ptr)
{
workhorse.visit_slots(ptr);
+ if(ptr->h.hi_tag() == ALIEN_TYPE)
+ ((alien *)ptr)->update_address();
}
void trace_roots()
{
while(scan && scan < this->target->here)
{
- this->trace_slots((object *)scan);
+ this->trace_object((object *)scan);
scan = this->target->next_object_after(scan);
}
}
lwz r3,0(DS_REG)
lwz r4,-4(DS_REG)
subi DS_REG,DS_REG,4
- srawi r3,r3,3
+ srawi r3,r3,4
mullwo. r6,r3,r4
bso multiply_overflow
stw r6,0(DS_REG)
mov (DS_REG),ARITH_TEMP_1
mov ARITH_TEMP_1,DIV_RESULT
mov -CELL_SIZE(DS_REG),ARITH_TEMP_2
- sar $3,ARITH_TEMP_2
+ sar $4,ARITH_TEMP_2
sub $CELL_SIZE,DS_REG
imul ARITH_TEMP_2
jo multiply_overflow
return false_object;
}
-cell factor_vm::lookup_hi_tag_method(cell obj, cell methods)
-{
- array *hi_tag_methods = untag<array>(methods);
- cell tag = untag<object>(obj)->h.hi_tag() - HEADER_TYPE;
-#ifdef FACTOR_DEBUG
- assert(tag < TYPE_COUNT - HEADER_TYPE);
-#endif
- return array_nth(hi_tag_methods,tag);
-}
-
cell factor_vm::lookup_method(cell obj, cell methods)
{
cell tag = TAG(obj);
else
return method;
}
- else if(tag == OBJECT_TYPE)
- {
- if(TAG(method) == ARRAY_TYPE)
- return lookup_hi_tag_method(obj,method);
- else
- return method;
- }
else
return method;
}
cell factor_vm::object_class(cell obj)
{
- switch(TAG(obj))
- {
- case TUPLE_TYPE:
+ cell tag = TAG(obj);
+ if(tag == TUPLE_TYPE)
return untag<tuple>(obj)->layout;
- case OBJECT_TYPE:
- return untag<object>(obj)->h.value;
- default:
- return tag_fixnum(TAG(obj));
- }
+ else
+ return tag_fixnum(tag);
}
cell factor_vm::method_cache_hashcode(cell klass, array *array)
{
cell capacity = (array_capacity(array) >> 1) - 1;
- return (((klass >> 3) + (klass >> 8) + (klass >> 13)) & capacity) << 1;
+ return ((klass >> TAG_BITS) & capacity) << 1;
}
void factor_vm::update_method_cache(cell cache, cell klass, cell method)
gc_root<array> cache(cache_,parent);
/* Generate machine code to determine the object's class. */
- emit_class_lookup(index,PIC_HI_TAG_TUPLE);
+ emit_class_lookup(index,PIC_TUPLE);
/* Do a cache lookup. */
emit_with(parent->special_objects[MEGA_LOOKUP],cache.value());
{
object *obj = mark_stack->back();
mark_stack->pop_back();
- collector.trace_slots(obj);
+ collector.trace_object(obj);
code_marker.visit_object_code_block(obj);
}
quot->xt = (void *)lazy_jit_compile;
}
-void factor_vm::fixup_alien(alien *d)
+void factor_vm::fixup_alien(alien *ptr)
{
- if(!to_boolean(d->base)) d->expired = true_object;
+ if(!to_boolean(ptr->base))
+ ptr->expired = true_object;
+ else
+ ptr->update_address();
}
struct stack_frame_fixupper {
cold_call_to_ic_transitions = 0;
ic_to_pic_transitions = 0;
pic_to_mega_transitions = 0;
- for(int i = 0; i < 4; i++) pic_counts[i] = 0;
+ pic_counts[0] = 0;
+ pic_counts[1] = 0;
}
void factor_vm::deallocate_inline_cache(cell return_address)
it contains */
cell factor_vm::determine_inline_cache_type(array *cache_entries)
{
- bool seen_hi_tag = false, seen_tuple = false;
+ bool seen_tuple = false;
cell i;
for(i = 0; i < array_capacity(cache_entries); i += 2)
{
- cell klass = array_nth(cache_entries,i);
-
/* Is it a tuple layout? */
- switch(TAG(klass))
+ if(TAG(array_nth(cache_entries,i)) == ARRAY_TYPE)
{
- case FIXNUM_TYPE:
- {
- fixnum type = untag_fixnum(klass);
- if(type >= HEADER_TYPE)
- seen_hi_tag = true;
- }
- break;
- case ARRAY_TYPE:
seen_tuple = true;
break;
- default:
- critical_error("Expected a fixnum or array",klass);
- break;
}
}
- if(seen_hi_tag && seen_tuple) return PIC_HI_TAG_TUPLE;
- if(seen_hi_tag && !seen_tuple) return PIC_HI_TAG;
- if(!seen_hi_tag && seen_tuple) return PIC_TUPLE;
- if(!seen_hi_tag && !seen_tuple) return PIC_TAG;
-
- critical_error("Oops",0);
- return 0;
+ return seen_tuple ? PIC_TUPLE : PIC_TAG;
}
void factor_vm::update_pic_count(cell type)
void inline_cache_jit::emit_check(cell klass)
{
cell code_template;
- if(TAG(klass) == FIXNUM_TYPE && untag_fixnum(klass) < HEADER_TYPE)
+ if(TAG(klass) == FIXNUM_TYPE)
code_template = parent->special_objects[PIC_CHECK_TAG];
else
- code_template = parent->special_objects[PIC_CHECK];
+ code_template = parent->special_objects[PIC_CHECK_TUPLE];
emit_with(code_template,klass);
}
void factor_vm::primitive_reset_inline_cache_stats()
{
cold_call_to_ic_transitions = ic_to_pic_transitions = pic_to_mega_transitions = 0;
- cell i;
- for(i = 0; i < 4; i++) pic_counts[i] = 0;
+ pic_counts[0] = 0;
+ pic_counts[1] = 0;
}
void factor_vm::primitive_inline_cache_stats()
stats.add(allot_cell(cold_call_to_ic_transitions));
stats.add(allot_cell(ic_to_pic_transitions));
stats.add(allot_cell(pic_to_mega_transitions));
- cell i;
- for(i = 0; i < 4; i++)
- stats.add(allot_cell(pic_counts[i]));
+ stats.add(allot_cell(pic_counts[0]));
+ stats.add(allot_cell(pic_counts[1]));
stats.trim();
dpush(stats.elements.value());
}
#define WORD_SIZE (signed)(sizeof(cell)*8)
-#define TAG_MASK 7
-#define TAG_BITS 3
+#define TAG_MASK 15
+#define TAG_BITS 4
#define TAG(x) ((cell)(x) & TAG_MASK)
#define UNTAG(x) ((cell)(x) & ~TAG_MASK)
#define RETAG(x,tag) (UNTAG(x) | (tag))
#define FLOAT_TYPE 3
#define QUOTATION_TYPE 4
#define F_TYPE 5
-#define OBJECT_TYPE 6
+#define ALIEN_TYPE 6
#define TUPLE_TYPE 7
-
-#define HEADER_TYPE 8 /* anything less than this is a tag */
-
-#define GC_COLLECTED 5 /* can be anything other than FIXNUM_TYPE */
-
-/*** Header types ***/
#define WRAPPER_TYPE 8
#define BYTE_ARRAY_TYPE 9
#define CALLSTACK_TYPE 10
#define STRING_TYPE 11
#define WORD_TYPE 12
#define DLL_TYPE 13
-#define ALIEN_TYPE 14
-#define TYPE_COUNT 15
+#define TYPE_COUNT 14
+
+#define GC_COLLECTED 5 /* can be anything other than FIXNUM_TYPE */
enum code_block_type
{
return RETAG(untagged << TAG_BITS,FIXNUM_TYPE);
}
-inline static cell tag_for(cell type)
-{
- return type < HEADER_TYPE ? type : OBJECT_TYPE;
-}
-
struct object;
struct header {
cell expired;
/* untagged */
cell displacement;
+ /* untagged */
+ cell address;
+
+ void update_address()
+ {
+ if(base == false_object)
+ address = displacement;
+ else
+ address = UNTAG(base) + sizeof(byte_array) + displacement;
+ }
};
struct dll : public object {
/* Polymorphic inline cache generation in inline_cache.c */
PIC_LOAD = 47,
PIC_TAG,
- PIC_HI_TAG,
PIC_TUPLE,
- PIC_HI_TAG_TUPLE,
PIC_CHECK_TAG,
- PIC_CHECK,
+ PIC_CHECK_TUPLE,
PIC_HIT,
PIC_MISS_WORD,
PIC_MISS_TAIL_WORD,
/* Megamorphic cache generation in dispatch.c */
MEGA_LOOKUP = 57,
MEGA_LOOKUP_WORD,
- MEGA_MISS_WORD,
+ MEGA_MISS_WORD,
OBJ_UNDEFINED = 60, /* default quotation for undefined words */
template<typename Type> cell tag(Type *value)
{
- return RETAG(value,tag_for(Type::type_number));
+ return RETAG(value,Type::type_number);
}
inline static cell tag_dynamic(object *value)
{
- return RETAG(value,tag_for(value->h.hi_tag()));
+ return RETAG(value,value->h.hi_tag());
}
template<typename Type>
cell value_;
cell type() const {
- cell tag = TAG(value_);
- if(tag == OBJECT_TYPE)
- return ((object *)UNTAG(value_))->h.hi_tag();
- else
- return tag;
+ return TAG(value_);
}
bool type_p(cell type_) const
{
object *obj = mark_stack->back();
mark_stack->pop_back();
- this->trace_slots(obj);
+ this->trace_object(obj);
}
}
cell cold_call_to_ic_transitions;
cell ic_to_pic_transitions;
cell pic_to_mega_transitions;
- /* Indexed by PIC_TAG, PIC_HI_TAG, PIC_TUPLE, PIC_HI_TAG_TUPLE */
- cell pic_counts[4];
+ /* Indexed by PIC_TAG, PIC_TUPLE */
+ cell pic_counts[2];
/* Number of entries in a polymorphic inline cache */
cell max_pic_size;
cell nth_superclass(tuple_layout *layout, fixnum echelon);
cell nth_hashcode(tuple_layout *layout, fixnum echelon);
cell lookup_tuple_method(cell obj, cell methods);
- cell lookup_hi_tag_method(cell obj, cell methods);
cell lookup_method(cell obj, cell methods);
void primitive_lookup_method();
cell object_class(cell obj);
projects / factor.git / commitdiff