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

compiler.cfg: more flexible addressing for ##slot and ##set-slot

db4
Slava Pestov 2010-04-23 20:20:06 -04:00
parent 6d41d2277f
commit 2475699736
5 changed files with 47 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
basis/compiler/cfg/instructions/instructions.factor
View File

@ -73,7 +73,8 @@ temp: temp/int-rep ;
! Slot access
INSN: ##slot
def: dst/tagged-rep
use: obj/tagged-rep slot/int-rep ;
use: obj/tagged-rep slot/int-rep
literal: scale tag ;
INSN: ##slot-imm
def: dst/tagged-rep
@ -81,7 +82,8 @@ use: obj/tagged-rep
literal: slot tag ;
INSN: ##set-slot
use: src/tagged-rep obj/tagged-rep slot/int-rep ;
use: src/tagged-rep obj/tagged-rep slot/int-rep
literal: scale tag ;
INSN: ##set-slot-imm
use: src/tagged-rep obj/tagged-rep
@ -568,11 +570,12 @@ temp: temp/int-rep ;
INSN: ##write-barrier
use: src/tagged-rep slot/int-rep
literal: scale tag
temp: temp1/int-rep temp2/int-rep ;
INSN: ##write-barrier-imm
use: src/tagged-rep
literal: slot
literal: slot tag
temp: temp1/int-rep temp2/int-rep ;
INSN: ##alien-global

29
basis/compiler/cfg/intrinsics/slots/slots.factor
View File

@ -1,9 +1,10 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: layouts namespaces kernel accessors sequences math
classes.algebra classes.builtin locals combinators
cpu.architecture compiler.tree.propagation.info
compiler.cfg.stacks compiler.cfg.hats compiler.cfg.registers
combinators.short-circuit cpu.architecture
compiler.tree.propagation.info compiler.cfg.stacks
compiler.cfg.hats compiler.cfg.registers
compiler.cfg.instructions compiler.cfg.utilities
compiler.cfg.builder.blocks compiler.constants ;
IN: compiler.cfg.intrinsics.slots
@ -13,12 +14,13 @@ IN: compiler.cfg.intrinsics.slots
: value-tag ( info -- n ) class>> class-tag ;
: ^^tag-offset>slot ( slot tag -- vreg' )
[ ^^offset>slot ] dip ^^sub-imm ;
: slot-indexing ( slot tag -- slot scale tag )
complex-addressing?
[ [ cell log2 ] dip ] [ [ ^^offset>slot ] dip ^^sub-imm 0 0 ] if ;
: (emit-slot) ( infos -- dst )
[ 2inputs ] [ first value-tag ] bi*
^^tag-offset>slot ^^slot ;
slot-indexing ^^slot ;
: (emit-slot-imm) ( infos -- dst )
ds-drop
@ -28,9 +30,9 @@ IN: compiler.cfg.intrinsics.slots
: immediate-slot-offset? ( value-info -- ? )
literal>> {
{ [ dup fixnum? ] [ tag-fixnum immediate-arithmetic? ] }
[ drop f ]
} cond ;
[ fixnum? ]
[ cell * immediate-arithmetic? ]
} 1&& ;
: emit-slot ( node -- )
dup node-input-infos
@ -47,12 +49,13 @@ IN: compiler.cfg.intrinsics.slots
:: (emit-set-slot) ( infos -- )
3inputs :> ( src obj slot )
slot infos second value-tag ^^tag-offset>slot :> slot
infos second value-tag :> tag
src obj slot ##set-slot
slot tag slot-indexing :> ( slot scale tag )
src obj slot scale tag ##set-slot
infos emit-write-barrier?
[ obj slot next-vreg next-vreg ##write-barrier ] when ;
[ obj slot scale tag next-vreg next-vreg ##write-barrier ] when ;
:: (emit-set-slot-imm) ( infos -- )
ds-drop
@ -65,7 +68,7 @@ IN: compiler.cfg.intrinsics.slots
src obj slot tag ##set-slot-imm
infos emit-write-barrier?
[ obj slot tag slot-offset next-vreg next-vreg ##write-barrier-imm ] when ;
[ obj slot tag next-vreg next-vreg ##write-barrier-imm ] when ;
: emit-set-slot ( node -- )
dup node-input-infos

4
basis/compiler/tests/low-level-ir.factor
View File

@ -46,7 +46,7 @@ IN: compiler.tests.low-level-ir
V{
T{ ##load-tagged f 1 $[ 2 cell log2 shift array type-number - ] }
T{ ##load-reference f 0 { t f t } }
T{ ##slot f 0 0 1 }
T{ ##slot f 0 0 1 0 0 }
} compile-test-bb
] unit-test
@ -61,7 +61,7 @@ IN: compiler.tests.low-level-ir
V{
T{ ##load-tagged f 1 $[ 2 cell log2 shift array type-number - ] }
T{ ##load-reference f 0 { t f t } }
T{ ##set-slot f 0 0 1 }
T{ ##set-slot f 0 0 1 0 0 }
} compile-test-bb
dup first eq?
] unit-test

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

@ -203,6 +203,11 @@ M: ulonglong-2-rep scalar-rep-of drop ulonglong-scalar-rep ;
! Mapping from register class to machine registers
HOOK: machine-registers cpu ( -- assoc )
! Specifies if %slot, %set-slot and %write-barrier accept the
! 'scale' and 'tag' parameters, and if %load-memory and
! %store-memory work
HOOK: complex-addressing? cpu ( -- ? )
HOOK: %load-immediate cpu ( reg val -- )
HOOK: %load-reference cpu ( reg obj -- )
HOOK: %load-double cpu ( reg val -- )
@ -220,9 +225,9 @@ HOOK: %return cpu ( -- )
HOOK: %dispatch cpu ( src temp -- )
HOOK: %slot cpu ( dst obj slot -- )
HOOK: %slot cpu ( dst obj slot scale tag -- )
HOOK: %slot-imm cpu ( dst obj slot tag -- )
HOOK: %set-slot cpu ( src obj slot -- )
HOOK: %set-slot cpu ( src obj slot scale tag -- )
HOOK: %set-slot-imm cpu ( src obj slot tag -- )
HOOK: %string-nth cpu ( dst obj index temp -- )
@ -440,8 +445,8 @@ HOOK: %set-vm-field cpu ( src offset -- )
: %context ( dst -- ) 0 %vm-field ;
HOOK: %allot cpu ( dst size class temp -- )
HOOK: %write-barrier cpu ( src slot temp1 temp2 -- )
HOOK: %write-barrier-imm cpu ( src slot temp1 temp2 -- )
HOOK: %write-barrier cpu ( src slot scale tag temp1 temp2 -- )
HOOK: %write-barrier-imm cpu ( src slot tag temp1 temp2 -- )
! GC checks
HOOK: %check-nursery cpu ( label size temp1 temp2 -- )

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

@ -65,6 +65,8 @@ HOOK: temp-reg cpu ( -- reg )
HOOK: pic-tail-reg cpu ( -- reg )
M: x86 complex-addressing? t ;
M: x86 %load-immediate dup 0 = [ drop dup XOR ] [ MOV ] if ;
M: x86 %load-reference
@ -110,12 +112,12 @@ M: x86 %return ( -- ) 0 RET ;
: align-code ( n -- )
0 <repetition> % ;
:: (%slot-imm) ( obj slot tag -- op )
obj slot tag slot-offset [+] ; inline
: (%slot) ( obj slot scale tag -- op ) neg <indirect> ; inline
: (%slot-imm) ( obj slot tag -- op ) slot-offset [+] ; inline
M: x86 %slot ( dst obj slot -- ) [+] MOV ;
M: x86 %slot ( dst obj slot scale tag -- ) (%slot) MOV ;
M: x86 %slot-imm ( dst obj slot tag -- ) (%slot-imm) MOV ;
M: x86 %set-slot ( src obj slot -- ) [+] swap MOV ;
M: x86 %set-slot ( src obj slot scale tag -- ) (%slot) swap MOV ;
M: x86 %set-slot-imm ( src obj slot tag -- ) (%slot-imm) swap MOV ;
:: two-operand ( dst src1 src2 rep -- dst src )
@ -283,7 +285,7 @@ M:: x86 %box-displaced-alien ( dst displacement base temp base-class -- )
dst 1 alien@ base MOV
dst 3 alien@ displacement MOV
temp base displacement byte-array-offset [++] MOV
temp base displacement byte-array-offset [++] LEA
dst 4 alien@ temp MOV
"end" resolve-label
@ -445,16 +447,19 @@ M:: x86 %allot ( dst size class nursery-ptr -- )
HOOK: %mark-card cpu ( card temp -- )
HOOK: %mark-deck cpu ( card temp -- )
:: (%write-barrier) ( src slot temp1 temp2 -- )
temp1 src slot [+] LEA
:: (%write-barrier) ( temp1 temp2 -- )
temp1 card-bits SHR
temp1 temp2 %mark-card
temp1 deck-bits card-bits - SHR
temp1 temp2 %mark-deck ;
M: x86 %write-barrier ( src slot temp1 temp2 -- ) (%write-barrier) ;
M:: x86 %write-barrier ( src slot scale tag temp1 temp2 -- )
temp1 src slot scale tag (%slot) LEA
temp1 temp2 (%write-barrier) ;
M: x86 %write-barrier-imm ( src slot temp1 temp2 -- ) (%write-barrier) ;
M:: x86 %write-barrier-imm ( src slot tag temp1 temp2 -- )
temp1 src slot tag (%slot-imm) LEA
temp1 temp2 (%write-barrier) ;
M:: x86 %check-nursery ( label size temp1 temp2 -- )
temp1 load-zone-offset