compiler: new set-special-object intrinsic; more efficient special-object intrinsic

diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor
index 24433ad594f75ff9742e166082b3c54c1d226a9a..44326c179fb4b60834b78764a54ffb66788b093b 100644 (file)
--- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor
+++ b/basis/compiler/cfg/alias-analysis/alias-analysis.factor
@@ -202,14 +202,16 @@ M: ##slot-imm insn-slot# slot>> ;
 M: ##set-slot insn-slot# slot>> constant ;
 M: ##set-slot-imm insn-slot# slot>> ;
 M: ##alien-global insn-slot# [ library>> ] [ symbol>> ] bi 2array ;
-M: ##vm-field-ptr insn-slot# field-name>> ;
+M: ##vm-field insn-slot# offset>> ;
+M: ##set-vm-field insn-slot# offset>> ;
 
 M: ##slot insn-object obj>> resolve ;
 M: ##slot-imm insn-object obj>> resolve ;
 M: ##set-slot insn-object obj>> resolve ;
 M: ##set-slot-imm insn-object obj>> resolve ;
 M: ##alien-global insn-object drop \ ##alien-global ;
-M: ##vm-field-ptr insn-object drop \ ##vm-field-ptr ;
+M: ##vm-field insn-object drop \ ##vm-field ;
+M: ##set-vm-field insn-object drop \ ##vm-field ;
 
 : init-alias-analysis ( insns -- insns' )
     H{ } clone histories set
@@ -222,7 +224,7 @@ M: ##vm-field-ptr insn-object drop \ ##vm-field-ptr ;
     0 ac-counter set
     next-ac heap-ac set
 
-    \ ##vm-field-ptr set-new-ac
+    \ ##vm-field set-new-ac
     \ ##alien-global set-new-ac
 
     dup local-live-in [ set-heap-ac ] each ;

diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index 678ce768600a5829282534af9b88c5049c0ff9d0..c015cb640b5222a3dcaaff6c04e784507cab9a62 100644 (file)
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -660,13 +660,13 @@ INSN: ##alien-global
 def: dst/int-rep
 literal: symbol library ;
 
-INSN: ##vm-field-ptr
-def: dst/int-rep
-literal: field-name ;
-
 INSN: ##vm-field
 def: dst/int-rep
-literal: field-name ;
+literal: offset ;
+
+INSN: ##set-vm-field
+use: src/int-rep
+literal: offset ;
 
 ! FFI
 INSN: ##alien-invoke
@@ -835,8 +835,8 @@ UNION: ##allocation
 ##box-displaced-alien ;
 
 ! For alias analysis
-UNION: ##read ##slot ##slot-imm ##vm-field-ptr ##alien-global ;
-UNION: ##write ##set-slot ##set-slot-imm ;
+UNION: ##read ##slot ##slot-imm ##vm-field ##alien-global ;
+UNION: ##write ##set-slot ##set-slot-imm ##set-vm-field ;
 
 ! Instructions that kill all live vregs but cannot trigger GC
 UNION: partial-sync-insn

diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor
index 4ebc818b83c1c7e97dfbbbfbfbe141f26c0198a5..2b2ae7d160d15a94cf8c76fb3243aac040bd91a7 100644 (file)
--- a/basis/compiler/cfg/intrinsics/intrinsics.factor
+++ b/basis/compiler/cfg/intrinsics/intrinsics.factor
@@ -32,6 +32,7 @@ IN: compiler.cfg.intrinsics
     { kernel.private:tag [ drop emit-tag ] }
     { kernel.private:context-object [ emit-context-object ] }
     { kernel.private:special-object [ emit-special-object ] }
+    { kernel.private:set-special-object [ emit-set-special-object ] }
     { kernel.private:(identity-hashcode) [ drop emit-identity-hashcode ] }
     { math.private:both-fixnums? [ drop emit-both-fixnums? ] }
     { math.private:fixnum+ [ drop emit-fixnum+ ] }

diff --git a/basis/compiler/cfg/intrinsics/misc/misc.factor b/basis/compiler/cfg/intrinsics/misc/misc.factor
index 9731d2f6f519668c0e7d7f2fb60433b9b9b2f048..da77bcaa09d69deb332739ddbe24bf00c207e0fa 100644 (file)
--- a/basis/compiler/cfg/intrinsics/misc/misc.factor
+++ b/basis/compiler/cfg/intrinsics/misc/misc.factor
@@ -1,30 +1,39 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces layouts sequences kernel math accessors
 compiler.tree.propagation.info compiler.cfg.stacks
 compiler.cfg.hats compiler.cfg.instructions
 compiler.cfg.builder.blocks
 compiler.cfg.utilities ;
-FROM: vm => context-field-offset ;
+FROM: vm => context-field-offset vm-field-offset ;
 IN: compiler.cfg.intrinsics.misc
 
 : emit-tag ( -- )
     ds-pop tag-mask get ^^and-imm ^^tag-fixnum ds-push ;
 
+: special-object-offset ( n -- offset )
+    cells "special-objects" vm-field-offset + ;
+
 : emit-special-object ( node -- )
     dup node-input-infos first literal>> [
-        "special-objects" ^^vm-field-ptr
-        ds-drop swap 0 ^^slot-imm
+        ds-drop
+        special-object-offset ^^vm-field
         ds-push
     ] [ emit-primitive ] ?if ;
 
-: context-object-offset ( -- n )
-    "context-objects" context-field-offset cell /i ;
+: emit-set-special-object ( node -- )
+    dup node-input-infos second literal>> [
+        ds-drop
+        [ ds-pop ] dip special-object-offset ##set-vm-field
+    ] [ emit-primitive ] ?if ;
+
+: context-object-offset ( n -- n )
+    cells "context-objects" context-field-offset + ;
 
 : emit-context-object ( node -- )
     dup node-input-infos first literal>> [
-        "ctx" ^^vm-field
-        ds-drop swap context-object-offset + 0 ^^slot-imm ds-push
+        "ctx" vm-field-offset ^^vm-field
+        ds-drop swap context-object-offset cell /i 0 ^^slot-imm ds-push
     ] [ emit-primitive ] ?if ;
 
 : emit-identity-hashcode ( -- )

diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index d82ced8a1d8a8b2c4dad3457a80121a0b40be3cd..4208fec0a73fb544f6c88d0456cc7174a536232a 100755 (executable)
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -210,8 +210,8 @@ CODEGEN: ##compare-imm %compare-imm
 CODEGEN: ##compare-float-ordered %compare-float-ordered
 CODEGEN: ##compare-float-unordered %compare-float-unordered
 CODEGEN: ##save-context %save-context
-CODEGEN: ##vm-field-ptr %vm-field-ptr
 CODEGEN: ##vm-field %vm-field
+CODEGEN: ##set-vm-field %set-vm-field
 
 CODEGEN: _fixnum-add %fixnum-add
 CODEGEN: _fixnum-sub %fixnum-sub

diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor
index 692dbee4c54aeb03ab7fe38301c2dc64f2a7d9c5..ceac1b094c58efdb39b06a6a6f51b08bd1c7bd23 100755 (executable)
--- a/basis/compiler/tests/alien.factor
+++ b/basis/compiler/tests/alien.factor
@@ -432,14 +432,17 @@ STRUCT: double-rect
     void { void* void* double-rect } "cdecl"
     [ "example" set-global 2drop ] alien-callback ;
 
-: double-rect-test ( arg -- arg' )
-    f f rot
-    double-rect-callback
+: double-rect-test ( arg callback -- arg' )
+    [ f f ] 2dip
     void { void* void* double-rect } "cdecl" alien-indirect
     "example" get-global ;
 
 [ 1.0 2.0 3.0 4.0 ]
-[ 1.0 2.0 3.0 4.0 <double-rect> double-rect-test >double-rect< ] unit-test
+[
+    1.0 2.0 3.0 4.0 <double-rect>
+    double-rect-callback double-rect-test
+    >double-rect<
+] unit-test
 
 STRUCT: test_struct_14
     { x1 double }

diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor
index b617746a06f81db50e7ddf101845c6efcb4fa36f..ad1a4be2eb072f67966b5b641813c1a343965d75 100644 (file)
--- a/basis/cpu/architecture/architecture.factor
+++ b/basis/cpu/architecture/architecture.factor
@@ -447,8 +447,10 @@ HOOK: %set-alien-double    cpu ( ptr offset value -- )
 HOOK: %set-alien-vector    cpu ( ptr offset value rep -- )
 
 HOOK: %alien-global cpu ( dst symbol library -- )
-HOOK: %vm-field cpu ( dst fieldname -- )
-HOOK: %vm-field-ptr cpu ( dst fieldname -- )
+HOOK: %vm-field cpu ( dst offset -- )
+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 -- )

diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor
index dbc313052f6e9c1d8127a79f9785fa0a7671c191..3fd0552a99dced9e1e251fec7e20efb82e08e67d 100644 (file)
--- a/basis/cpu/ppc/ppc.factor
+++ b/basis/cpu/ppc/ppc.factor
@@ -58,11 +58,7 @@ CONSTANT: vm-reg 15
 
 : %load-vm-addr ( reg -- ) vm-reg MR ;
 
-M: ppc %vm-field ( dst field -- )
-    [ vm-reg ] dip vm-field-offset LWZ ;
-
-M: ppc %vm-field-ptr ( dst field -- )
-    [ vm-reg ] dip vm-field-offset ADDI ;
+M: ppc %vm-field ( dst field -- ) [ vm-reg ] dip LWZ ;
 
 GENERIC: loc-reg ( loc -- reg )
 
@@ -385,7 +381,7 @@ M: ppc %set-alien-float -rot STFS ;
 M: ppc %set-alien-double -rot STFD ;
 
 : load-zone-ptr ( reg -- )
-    "nursery" %vm-field-ptr ;
+    vm-reg "nursery" vm-field-offset ADDI ;
 
 : load-allot-ptr ( nursery-ptr allot-ptr -- )
     [ drop load-zone-ptr ] [ swap 0 LWZ ] 2bi ;
@@ -604,14 +600,14 @@ M: ppc %push-stack ( -- )
     int-regs return-reg ds-reg 0 STW ;
 
 M: ppc %push-context-stack ( -- )
-    11 "ctx" %vm-field
+    11 %context
     12 11 "datastack" context-field-offset LWZ
     12 12 4 ADDI
     12 11 "datastack" context-field-offset STW
     int-regs return-reg 12 0 STW ;
 
 M: ppc %pop-context-stack ( -- )
-    11 "ctx" %vm-field
+    11 %context
     12 11 "datastack" context-field-offset LWZ
     int-regs return-reg 12 0 LWZ
     12 12 4 SUBI
@@ -677,12 +673,12 @@ M: ppc %box-large-struct ( n c-type -- )
     "from_value_struct" f %alien-invoke ;
 
 M:: ppc %restore-context ( temp1 temp2 -- )
-    temp1 "ctx" %vm-field
+    temp1 %context
     ds-reg temp1 "datastack" context-field-offset LWZ
     rs-reg temp1 "retainstack" context-field-offset LWZ ;
 
 M:: ppc %save-context ( temp1 temp2 -- )
-    temp1 "ctx" %vm-field
+    temp1 %context
     1 temp1 "callstack-top" context-field-offset STW
     ds-reg temp1 "datastack" context-field-offset STW
     rs-reg temp1 "retainstack" context-field-offset STW ;

diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor
index 09f1ecb32b6763c1b965212ad22d1538f10598f5..8b97eb9351a501ab135bd243448bcf61d1c8de2d 100755 (executable)
--- a/basis/cpu/x86/32/32.factor
+++ b/basis/cpu/x86/32/32.factor
@@ -28,10 +28,13 @@ M: x86.32 %mov-vm-ptr ( reg -- )
     0 MOV 0 rc-absolute-cell rel-vm ;
 
 M: x86.32 %vm-field ( dst field -- )
-    [ 0 [] MOV ] dip vm-field-offset rc-absolute-cell rel-vm ;
+    [ 0 [] MOV ] dip rc-absolute-cell rel-vm ;
+
+M: x86.32 %set-vm-field ( dst field -- )
+    [ 0 [] swap MOV ] dip rc-absolute-cell rel-vm ;
 
 M: x86.32 %vm-field-ptr ( dst field -- )
-    [ 0 MOV ] dip vm-field-offset rc-absolute-cell rel-vm ;
+    [ 0 MOV ] dip rc-absolute-cell rel-vm ;
 
 : local@ ( n -- op )
     stack-frame get extra-stack-space dup 16 assert= + stack@ ;
@@ -166,7 +169,7 @@ M: x86.32 %pop-stack ( n -- )
     EAX swap ds-reg reg-stack MOV ;
 
 M: x86.32 %pop-context-stack ( -- )
-    temp-reg "ctx" %vm-field
+    temp-reg %context
     EAX temp-reg "datastack" context-field-offset [+] MOV
     EAX EAX [] MOV
     temp-reg "datastack" context-field-offset [+] bootstrap-cell SUB ;

diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor
index 04f64f96b6d3808b13e764ab3acc7aac1dab7aba..bea5d4da1fc06a37322ccd5cd27cb47d47c4ef4c 100644 (file)
--- a/basis/cpu/x86/64/64.factor
+++ b/basis/cpu/x86/64/64.factor
@@ -43,11 +43,14 @@ M: x86.64 machine-registers
 M: x86.64 %mov-vm-ptr ( reg -- )
     vm-reg MOV ;
 
-M: x86.64 %vm-field ( dst field -- )
-    [ vm-reg ] dip vm-field-offset [+] MOV ;
+M: x86.64 %vm-field ( dst offset -- )
+    [ vm-reg ] dip [+] MOV ;
 
-M: x86.64 %vm-field-ptr ( dst field -- )
-    [ vm-reg ] dip vm-field-offset [+] LEA ;
+M: x86.64 %set-vm-field ( src offset -- )
+    [ vm-reg ] dip [+] swap MOV ;
+
+M: x86.64 %vm-field-ptr ( dst offset -- )
+    [ vm-reg ] dip [+] LEA ;
 
 : param@ ( n -- op ) reserved-stack-space + stack@ ;
 
@@ -111,7 +114,7 @@ M: x86.64 %pop-stack ( n -- )
     param-reg-0 swap ds-reg reg-stack MOV ;
 
 M: x86.64 %pop-context-stack ( -- )
-    temp-reg "ctx" %vm-field
+    temp-reg %context
     param-reg-0 temp-reg "datastack" context-field-offset [+] MOV
     param-reg-0 param-reg-0 [] MOV
     temp-reg "datastack" context-field-offset [+] bootstrap-cell SUB ;

diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor
index dbb112bf4bf9a245e062a210d7bc6adfe4b736ba..acd2e1358dbdb9b7f1e95dd041728f5f6b37ee74 100644 (file)
--- a/basis/cpu/x86/x86.factor
+++ b/basis/cpu/x86/x86.factor
@@ -423,8 +423,13 @@ M: x86 %sar int-rep two-operand [ SAR ] emit-shift ;
 
 HOOK: %mov-vm-ptr cpu ( reg -- )
 
+HOOK: %vm-field-ptr cpu ( reg offset -- )
+
+: load-zone-offset ( nursery-ptr -- )
+    "nursery" vm-field-offset %vm-field-ptr ;
+
 : load-allot-ptr ( nursery-ptr allot-ptr -- )
-    [ drop "nursery" %vm-field-ptr ] [ swap [] MOV ] 2bi ;
+    [ drop load-zone-offset ] [ swap [] MOV ] 2bi ;
 
 : inc-allot-ptr ( nursery-ptr n -- )
     [ [] ] dip data-alignment get align ADD ;
@@ -456,7 +461,7 @@ M: x86 %write-barrier ( src slot temp1 temp2 -- ) (%write-barrier) ;
 M: x86 %write-barrier-imm ( src slot temp1 temp2 -- ) (%write-barrier) ;
 
 M:: x86 %check-nursery ( label size temp1 temp2 -- )
-    temp1 "nursery" %vm-field-ptr
+    temp1 load-zone-offset
     ! Load 'here' into temp2
     temp2 temp1 [] MOV
     temp2 size ADD
@@ -477,7 +482,7 @@ M: x86 %push-stack ( -- )
     ds-reg [] int-regs return-reg MOV ;
 
 M: x86 %push-context-stack ( -- )
-    temp-reg "ctx" %vm-field
+    temp-reg %context
     temp-reg "datastack" context-field-offset [+] bootstrap-cell ADD
     temp-reg temp-reg "datastack" context-field-offset [+] MOV
     temp-reg [] int-regs return-reg MOV ;
@@ -1403,7 +1408,7 @@ M: x86 %loop-entry 16 code-alignment [ NOP ] times ;
 
 M:: x86 %restore-context ( temp1 temp2 -- )
     #! Load Factor stack pointers on entry from C to Factor.
-    temp1 "ctx" %vm-field
+    temp1 %context
     ds-reg temp1 "datastack" context-field-offset [+] MOV
     rs-reg temp1 "retainstack" context-field-offset [+] MOV ;
 
@@ -1411,7 +1416,7 @@ M:: x86 %save-context ( temp1 temp2 -- )
     #! Save Factor stack pointers in case the C code calls a
     #! callback which does a GC, which must reliably trace
     #! all roots.
-    temp1 "ctx" %vm-field
+    temp1 %context
     temp2 stack-reg cell neg [+] LEA
     temp1 "callstack-top" context-field-offset [+] temp2 MOV
     temp1 "datastack" context-field-offset [+] ds-reg MOV