compiler: separate ##save-context instruction from ##alien-invoke, generate a ##save...

diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index bd3cd9f2a4fa6e234bdf2111cb8203cd193cbae6..32e5d46c61469c77165e1c4cbf875354ad779db4 100644 (file)
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -533,6 +533,10 @@ INSN: ##gc
 temp: temp1/int-rep temp2/int-rep
 literal: data-values tagged-values uninitialized-locs ;
 
+INSN: ##save-context
+temp: temp1/int-rep temp2/int-rep
+literal: callback-allowed? ;
+
 ! Instructions used by machine IR only.
 INSN: _prologue
 literal: stack-frame ;

diff --git a/basis/compiler/cfg/instructions/syntax/syntax.factor b/basis/compiler/cfg/instructions/syntax/syntax.factor
index cc1d0df21c477a978c680b227b7042f0fb0b55bc..bca5e1ee64491c2c8956fd7c74e5f40bc8ca725b 100644 (file)
--- a/basis/compiler/cfg/instructions/syntax/syntax.factor
+++ b/basis/compiler/cfg/instructions/syntax/syntax.factor
@@ -41,11 +41,11 @@ TUPLE: insn-slot-spec type name rep ;
     "insn-slots" word-prop
     [ type>> def eq? ] find nip ;
 
-: insn-use-slots ( class -- slot/f )
+: insn-use-slots ( class -- slots )
     "insn-slots" word-prop
     [ type>> use eq? ] filter ;
 
-: insn-temp-slots ( class -- slot/f )
+: insn-temp-slots ( class -- slots )
     "insn-slots" word-prop
     [ type>> temp eq? ] filter ;
 

diff --git a/basis/compiler/cfg/optimizer/optimizer.factor b/basis/compiler/cfg/optimizer/optimizer.factor
index 649032b46936d958d214ea39a85fdfb5ed78d365..35e0c6e3aa9541830258c981cf47d978d82a31d7 100644 (file)
--- a/basis/compiler/cfg/optimizer/optimizer.factor
+++ b/basis/compiler/cfg/optimizer/optimizer.factor
@@ -13,6 +13,7 @@ compiler.cfg.dce
 compiler.cfg.write-barrier
 compiler.cfg.representations
 compiler.cfg.two-operand
+compiler.cfg.save-contexts
 compiler.cfg.ssa.destruction
 compiler.cfg.empty-blocks
 compiler.cfg.checker ;
@@ -38,6 +39,7 @@ SYMBOL: check-optimizer?
     eliminate-write-barriers
     select-representations
     convert-two-operand
+    insert-save-contexts
     destruct-ssa
     delete-empty-blocks
     ?check ;

diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index 23b02aa224aabe47ad8913ab84b9e170924ff13f..d441b961c5a7bbcb018dfc81aea8a80273dd57b7 100755 (executable)
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -201,6 +201,7 @@ CODEGEN: ##compare %compare
 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: _fixnum-add %fixnum-add
 CODEGEN: _fixnum-sub %fixnum-sub
@@ -254,6 +255,7 @@ M: _gc generate-insn
         [ [ uninitialized-locs>> ] [ temp1>> ] bi wipe-locs ]
         [ data-values>> save-data-regs ]
         [ [ tagged-values>> ] [ temp1>> ] bi save-gc-roots ]
+        [ [ temp1>> ] [ temp2>> ] bi t %save-context ]
         [ tagged-values>> length %call-gc ]
         [ [ tagged-values>> ] [ temp1>> ] bi load-gc-roots ]
         [ data-values>> load-data-regs ]
@@ -396,8 +398,6 @@ M: long-long-type flatten-value-type ( type -- types )
 
 M: ##alien-invoke generate-insn
     params>>
-    ! Save registers for GC
-    %prepare-alien-invoke
     ! Unbox parameters
     dup objects>registers
     %prepare-var-args
@@ -410,8 +410,6 @@ M: ##alien-invoke generate-insn
 ! ##alien-indirect
 M: ##alien-indirect generate-insn
     params>>
-    ! Save registers for GC
-    %prepare-alien-invoke
     ! Save alien at top of stack to temporary storage
     %prepare-alien-indirect
     ! Unbox parameters

diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor
index b6955fabf1021b78c17fccef4736d5d537c96351..d6611c3384fa301f3a1a5e1d38366351871e8abd 100644 (file)
--- a/basis/cpu/architecture/architecture.factor
+++ b/basis/cpu/architecture/architecture.factor
@@ -289,7 +289,7 @@ HOOK: %save-param-reg cpu ( stack reg rep -- )
 
 HOOK: %load-param-reg cpu ( stack reg rep -- )
 
-HOOK: %prepare-alien-invoke cpu ( -- )
+HOOK: %save-context cpu ( temp1 temp2 callback-allowed? -- )
 
 HOOK: %prepare-var-args cpu ( -- )
 

diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor
index 62dbe715b49f32266ecc4595c995bf958551c60e..9f236be8bd7814a4bb0fee431634de3b1364ae34 100644 (file)
--- a/basis/cpu/ppc/ppc.factor
+++ b/basis/cpu/ppc/ppc.factor
@@ -468,7 +468,6 @@ M:: ppc %load-gc-root ( gc-root register -- )
     register 1 gc-root gc-root@ LWZ ;
 
 M:: ppc %call-gc ( gc-root-count -- )
-    %prepare-alien-invoke
     3 1 gc-root-base local@ ADDI
     gc-root-count 4 LI
     "inline_gc" f %alien-invoke ;
@@ -666,15 +665,17 @@ M: ppc %box-large-struct ( n c-type -- )
     ! Call the function
     "box_value_struct" f %alien-invoke ;
 
-M: ppc %prepare-alien-invoke
+M:: ppc %save-context ( temp1 temp2 callback-allowed? -- )
     #! Save Factor stack pointers in case the C code calls a
     #! callback which does a GC, which must reliably trace
     #! all roots.
-    scratch-reg "stack_chain" f %alien-global
-    scratch-reg scratch-reg 0 LWZ
-    1 scratch-reg 0 STW
-    ds-reg scratch-reg 8 STW
-    rs-reg scratch-reg 12 STW ;
+    temp1 "stack_chain" f %alien-global
+    temp1 temp1 0 LWZ
+    1 temp1 0 STW
+    callback-allowed? [
+        ds-reg temp1 8 STW
+        rs-reg temp1 12 STW
+    ] when ;
 
 M: ppc %alien-invoke ( symbol dll -- )
     [ 11 ] 2dip %alien-global 11 MTLR BLRL ;

diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor
index 186c1c4c0c64f59f6f42f00dd39ad5793bbed6f4..e124bd8be333e8fca493d6d22d1e4a8c588e3e5d 100644 (file)
--- a/basis/cpu/x86/x86.factor
+++ b/basis/cpu/x86/x86.factor
@@ -610,7 +610,6 @@ M:: x86 %call-gc ( gc-root-count -- )
     ! Pass number of roots as second parameter
     param-reg-2 gc-root-count MOV
     ! Call GC
-    %prepare-alien-invoke
     "inline_gc" f %alien-invoke ;
 
 M: x86 %alien-global
@@ -739,16 +738,18 @@ M:: x86 %reload ( dst rep n -- )
 
 M: x86 %loop-entry 16 code-alignment [ NOP ] times ;
 
-M: x86 %prepare-alien-invoke
+M:: x86 %save-context ( temp1 temp2 callback-allowed? -- )
     #! Save Factor stack pointers in case the C code calls a
     #! callback which does a GC, which must reliably trace
     #! all roots.
-    temp-reg "stack_chain" f %alien-global
-    temp-reg temp-reg [] MOV
-    temp-reg [] stack-reg MOV
-    temp-reg [] cell SUB
-    temp-reg 2 cells [+] ds-reg MOV
-    temp-reg 3 cells [+] rs-reg MOV ;
+    temp1 "stack_chain" f %alien-global
+    temp1 temp1 [] MOV
+    temp2 stack-reg cell neg [+] LEA
+    temp1 [] temp2 MOV
+    callback-allowed? [
+        temp1 2 cells [+] ds-reg MOV
+        temp1 3 cells [+] rs-reg MOV
+    ] when ;
 
 M: x86 value-struct? drop t ;