Merge branch 'master' of git://factorcode.org/git/factor

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/cfg/save-contexts/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/compiler/cfg/save-contexts/save-contexts-tests.factor

@@ -0,0 +1,37 @@
+USING: accessors compiler.cfg.debugger
+compiler.cfg.instructions compiler.cfg.save-contexts namespaces
+tools.test ;
+IN: compiler.cfg.save-contexts.tests
+
+V{
+    T{ ##save-context f 0 1 f }
+    T{ ##save-context f 0 1 t }
+    T{ ##branch }
+} 0 test-bb
+
+0 get combine-in-block
+
+[
+    V{
+        T{ ##save-context f 0 1 t }
+        T{ ##branch }
+    }
+] [
+    0 get instructions>>
+] unit-test
+
+V{
+    T{ ##add f 1 2 3 }
+    T{ ##branch }
+} 0 test-bb
+
+0 get combine-in-block
+
+[
+    V{
+        T{ ##add f 1 2 3 }
+        T{ ##branch }
+    }
+] [
+    0 get instructions>>
+] unit-test

basis/compiler/cfg/save-contexts/save-contexts.factor

@@ -0,0 +1,38 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators.short-circuit
+compiler.cfg.instructions compiler.cfg.registers
+compiler.cfg.rpo cpu.architecture kernel sequences vectors ;
+IN: compiler.cfg.save-contexts
+
+! Insert context saves.
+
+: needs-save-context? ( insns -- ? )
+    [
+        {
+            [ ##unary-float-function? ]
+            [ ##binary-float-function? ]
+            [ ##alien-invoke? ]
+            [ ##alien-indirect? ]
+        } 1||
+    ] any? ;
+
+: needs-callback-context? ( insns -- ? )
+    [
+        {
+            [ ##alien-invoke? ]
+            [ ##alien-indirect? ]
+        } 1||
+    ] any? ;
+
+: insert-save-context ( bb -- )
+    dup instructions>> dup needs-save-context? [
+        int-rep next-vreg-rep
+        int-rep next-vreg-rep
+        pick needs-callback-context?
+        \ ##save-context new-insn prefix
+        >>instructions drop
+    ] [ 2drop ] if ;
+
+: insert-save-contexts ( cfg -- cfg' )
+    dup [ insert-save-context ] each-basic-block ;

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 ;
@@ -670,15 +669,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
+    temp1 "stack_chain" f %alien-global
-    scratch-reg scratch-reg 0 LWZ
+    temp1 temp1 0 LWZ
-    1 scratch-reg 0 STW
+    1 temp1 0 STW
-    ds-reg scratch-reg 8 STW
+    callback-allowed? [
-    rs-reg scratch-reg 12 STW ;
+        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
+    temp1 "stack_chain" f %alien-global
-    temp-reg temp-reg [] MOV
+    temp1 temp1 [] MOV
-    temp-reg [] stack-reg MOV
+    temp2 stack-reg cell neg [+] LEA
-    temp-reg [] cell SUB
+    temp1 [] temp2 MOV
-    temp-reg 2 cells [+] ds-reg MOV
+    callback-allowed? [
-    temp-reg 3 cells [+] rs-reg MOV ;
+        temp1 2 cells [+] ds-reg MOV
+        temp1 3 cells [+] rs-reg MOV
+    ] when ;
 
 M: x86 value-struct? drop t ;
 

basis/tools/annotations/annotations-docs.factor

@@ -16,7 +16,10 @@ $nl
 { $subsection add-timing }
 { $subsection word-timing. }
 "All of the above words are implemented using a single combinator which applies a quotation to a word definition to yield a new definition:"
-{ $subsection annotate } ;
+{ $subsection annotate }
+{ $warning
+    "Certain internal words, such as words in the " { $vocab-link "math" } ", " { $vocab-link "sequences" } " and UI vocabularies, cannot be annotated, since the annotated code may end up recursively invoking the word in question. This may crash or hang Factor. It is safest to only define annotations on your own words."
+} ;
 
 ABOUT: "tools.annotations"