diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor index 24433ad594..44326c179f 100644 --- 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 678ce76860..c015cb640b 100644 --- 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 4ebc818b83..2b2ae7d160 100644 --- 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 9731d2f6f5..da77bcaa09 100644 --- 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 d82ced8a1d..4208fec0a7 100755 --- 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 692dbee4c5..ceac1b094c 100755 --- 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-test >double-rect< ] unit-test +[ + 1.0 2.0 3.0 4.0 + 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 b617746a06..ad1a4be2eb 100644 --- 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 dbc313052f..3fd0552a99 100644 --- 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 09f1ecb32b..8b97eb9351 100755 --- 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 04f64f96b6..bea5d4da1f 100644 --- 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 dbb112bf4b..acd2e1358d 100644 --- 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