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

diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index 4023247b825afd37ce36aa397695f70541417367..4960722eb2381a64c7b178c9b13940ead856e498 100644 (file)
--- 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 1ec648b908cfac74c502389e8b0bdc6661e170ad..a3f532b4dbee7889d4bdd7d7baf28b37af217db5 100644 (file)
--- 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 02f5c9335265f586b7a7f4b2443f19c23ca85a72..7ce43e9524cc8a485f526777c13825db4b7c8a84 100644 (file)
--- 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 c25ade8312b87c699959b7e7ed36052b737f2d16..ea98a199ed38acf9fd819a81d58d59735c88048b 100644 (file)
--- 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 86c8c5b46e9b32f3a42ba50255400ac53bc4b078..01c11c6aecb35e98948ea151d74febfaead4904a 100644 (file)
--- 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