diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index 4023247b82..4960722eb2 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -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
diff --git a/basis/compiler/cfg/intrinsics/slots/slots.factor b/basis/compiler/cfg/intrinsics/slots/slots.factor
index 1ec648b908..a3f532b4db 100644
--- a/basis/compiler/cfg/intrinsics/slots/slots.factor
+++ b/basis/compiler/cfg/intrinsics/slots/slots.factor
@@ -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
diff --git a/basis/compiler/tests/low-level-ir.factor b/basis/compiler/tests/low-level-ir.factor
index 02f5c93352..7ce43e9524 100644
--- a/basis/compiler/tests/low-level-ir.factor
+++ b/basis/compiler/tests/low-level-ir.factor
@@ -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
diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor
index c25ade8312..ea98a199ed 100644
--- a/basis/cpu/architecture/architecture.factor
+++ b/basis/cpu/architecture/architecture.factor
@@ -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 -- )
diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor
index 86c8c5b46e..01c11c6aec 100644
--- a/basis/cpu/x86/x86.factor
+++ b/basis/cpu/x86/x86.factor
@@ -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