compiler: separate ##save-context instruction from ##alien-invoke, generate a ##save-context for libm calls, and add a pass to combine multiple context saves within a basic block. Fixes crashes with FP traps thrown by libm functions on x86-32

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 ;

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 ;
 

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 ;

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

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 ( -- )
 

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 ;

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 ;