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

basis/cocoa/types/types.factor

@@ -46,6 +46,7 @@ C-STRUCT: NSSize
     { "CGFloat" "h" } ;
 
 TYPEDEF: NSSize _NSSize
+TYPEDEF: NSSize CGSize
 TYPEDEF: NSPoint CGPoint
 
 : <NSSize> ( w h -- size )

basis/compiler/generator/registers/registers.factor

@@ -50,13 +50,21 @@ C: <vreg> vreg ( n reg-class -- vreg )
 
 M: vreg v>operand [ n>> ] [ reg-class>> ] bi vregs nth ;
 M: vreg live-vregs* , ;
-M: vreg move-spec reg-class>> move-spec ;
+
+M: vreg move-spec
+    reg-class>> {
+        { [ dup int-regs? ] [ f ] }
+        { [ dup float-regs? ] [ float ] }
+    } cond nip ;
+
+M: vreg operand-class*
+    reg-class>> {
+        { [ dup int-regs? ] [ f ] }
+        { [ dup float-regs? ] [ float ] }
+    } cond nip ;
 
 INSTANCE: vreg value
 
-M: float-regs move-spec drop float ;
-M: float-regs operand-class* drop float ;
-
 ! Temporary register for stack shuffling
 SINGLETON: temp-reg
 

basis/compiler/tests/alien.factor

@@ -3,7 +3,7 @@ USING: alien alien.c-types alien.syntax compiler kernel
 namespaces namespaces tools.test sequences stack-checker
 stack-checker.errors words arrays parser quotations
 continuations effects namespaces.private io io.streams.string
-memory system threads tools.test math accessors ;
+memory system threads tools.test math accessors combinators ;
 
 FUNCTION: void ffi_test_0 ;
 [ ] [ ffi_test_0 ] unit-test
@@ -401,3 +401,41 @@ C-STRUCT: test_struct_13
 FUNCTION: int ffi_test_39 ( long a, long b, test_struct_13 s ) ;
 
 [ 21 ] [ 12347 12347 make-test-struct-13 ffi_test_39 ] unit-test
+
+! Joe Groff found this problem
+C-STRUCT: double-rect
+{ "double" "a" }
+{ "double" "b" }
+{ "double" "c" }
+{ "double" "d" } ;
+
+: <double-rect> ( a b c d -- foo )
+    "double-rect" <c-object>
+    {
+        [ set-double-rect-d ]
+        [ set-double-rect-c ]
+        [ set-double-rect-b ]
+        [ set-double-rect-a ]
+        [ ]
+    } cleave ;
+
+: >double-rect< ( foo -- a b c d )
+    {
+        [ double-rect-a ]
+        [ double-rect-b ]
+        [ double-rect-c ]
+        [ double-rect-d ]
+    } cleave ;
+
+: double-rect-callback ( -- alien )
+    "void" { "void*" "void*" "double-rect" } "cdecl"
+    [ "example" set-global 2drop ] alien-callback ;
+
+: double-rect-test ( arg -- arg' )
+    f f rot
+    double-rect-callback
+    "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

basis/compiler/tree/cleanup/cleanup-tests.factor

@@ -10,12 +10,13 @@ compiler.tree
 compiler.tree.combinators
 compiler.tree.cleanup
 compiler.tree.builder
+compiler.tree.recursive
 compiler.tree.normalization
 compiler.tree.propagation
 compiler.tree.checker ;
 
 : cleaned-up-tree ( quot -- nodes )
-    build-tree normalize propagate cleanup dup check-nodes ;
+    build-tree analyze-recursive normalize propagate cleanup dup check-nodes ;
 
 [ t ] [ [ [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test
 

basis/compiler/tree/dead-code/dead-code-tests.factor

@@ -3,16 +3,17 @@ compiler.tree.dead-code compiler.tree.def-use compiler.tree
 compiler.tree.combinators compiler.tree.propagation
 compiler.tree.cleanup compiler.tree.escape-analysis
 compiler.tree.tuple-unboxing compiler.tree.debugger
-compiler.tree.normalization compiler.tree.checker tools.test
+compiler.tree.recursive compiler.tree.normalization
-kernel math stack-checker.state accessors combinators io
+compiler.tree.checker tools.test kernel math stack-checker.state
-prettyprint words sequences.deep sequences.private arrays
+accessors combinators io prettyprint words sequences.deep
-classes kernel.private ;
+sequences.private arrays classes kernel.private ;
 IN: compiler.tree.dead-code.tests
 
 \ remove-dead-code must-infer
 
 : count-live-values ( quot -- n )
     build-tree
+    analyze-recursive
     normalize
     propagate
     cleanup
@@ -64,6 +65,7 @@ IN: compiler.tree.dead-code.tests
 
 : optimize-quot ( quot -- quot' )
     build-tree
+    analyze-recursive
     normalize
     propagate
     cleanup

basis/compiler/tree/def-use/def-use-tests.factor

@@ -1,9 +1,10 @@
 USING: accessors namespaces assocs kernel sequences math
 tools.test words sets combinators.short-circuit
 stack-checker.state compiler.tree compiler.tree.builder
-compiler.tree.normalization compiler.tree.propagation
+compiler.tree.recursive compiler.tree.normalization
-compiler.tree.cleanup compiler.tree.def-use arrays kernel.private
+compiler.tree.propagation compiler.tree.cleanup
-sorting math.order binary-search compiler.tree.checker ;
+compiler.tree.def-use arrays kernel.private sorting math.order
+binary-search compiler.tree.checker ;
 IN: compiler.tree.def-use.tests
 
 \ compute-def-use must-infer
@@ -18,6 +19,7 @@ IN: compiler.tree.def-use.tests
 
 : test-def-use ( quot -- )
     build-tree
+    analyze-recursive
     normalize
     propagate
     cleanup
@@ -27,7 +29,14 @@ IN: compiler.tree.def-use.tests
 : too-deep ( a b -- c )
     dup [ drop ] [ 2dup too-deep too-deep drop ] if ; inline recursive
 
-[ ] [ [ too-deep ] build-tree normalize compute-def-use check-nodes ] unit-test
+[ ] [
+    [ too-deep ]
+    build-tree
+    analyze-recursive
+    normalize
+    compute-def-use
+    check-nodes
+] unit-test
 
 ! compute-def-use checks for SSA violations, so we use that to
 ! ensure we generate some common patterns correctly.

basis/compiler/tree/escape-analysis/escape-analysis-tests.factor

@@ -1,13 +1,14 @@
 IN: compiler.tree.escape-analysis.tests
 USING: compiler.tree.escape-analysis
 compiler.tree.escape-analysis.allocations compiler.tree.builder
-compiler.tree.normalization math.functions
+compiler.tree.recursive compiler.tree.normalization
-compiler.tree.propagation compiler.tree.cleanup
+math.functions compiler.tree.propagation compiler.tree.cleanup
-compiler.tree.combinators compiler.tree sequences math math.private
+compiler.tree.combinators compiler.tree sequences math
-kernel tools.test accessors slots.private quotations.private
+math.private kernel tools.test accessors slots.private
-prettyprint classes.tuple.private classes classes.tuple
+quotations.private prettyprint classes.tuple.private classes
-compiler.intrinsics namespaces compiler.tree.propagation.info
+classes.tuple compiler.intrinsics namespaces
-stack-checker.errors kernel.private ;
+compiler.tree.propagation.info stack-checker.errors
+kernel.private ;
 
 \ escape-analysis must-infer
 
@@ -28,6 +29,7 @@ M: node count-unboxed-allocations* drop ;
 
 : count-unboxed-allocations ( quot -- sizes )
     build-tree
+    analyze-recursive
     normalize
     propagate
     cleanup

basis/compiler/tree/finalization/finalization.factor

@@ -7,6 +7,7 @@ byte-arrays alien.accessors
 compiler.intrinsics
 compiler.tree
 compiler.tree.builder
+compiler.tree.recursive
 compiler.tree.normalization
 compiler.tree.propagation
 compiler.tree.propagation.info
@@ -39,6 +40,7 @@ M: #shuffle finalize*
 : splice-quot ( quot -- nodes )
     [
         build-tree
+        analyze-recursive 
         normalize
         propagate
         cleanup

basis/compiler/tree/identities/identities.factor

@@ -0,0 +1,98 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel sequences fry words math
+math.partial-dispatch combinators arrays hashtables
+compiler.tree
+compiler.tree.combinators
+compiler.tree.propagation.info ;
+IN: compiler.tree.identities
+
+: define-identities ( word identities -- )
+    [ integer-derived-ops ] dip
+    '[ _ "identities" set-word-prop ] each ;
+
+SYMBOL: X
+
+\ + {
+    { { X 0 } drop }
+    { { 0 X } nip }
+} define-identities
+
+\ - {
+    { { X 0 } drop }
+} define-identities
+
+\ * {
+    { { X 1 } drop }
+    { { 1 X } nip }
+    { { X 0 } nip }
+    { { 0 X } drop }
+} define-identities
+
+\ / {
+    { { X 1 } drop }
+} define-identities
+
+\ mod {
+    { { X 1 } 0 }
+} define-identities
+
+\ rem {
+    { { X 1 } 0 }
+} define-identities
+
+\ bitand {
+    { { X -1 } drop }
+    { { -1 X } nip }
+    { { X 0 } nip }
+    { { 0 X } drop }
+} define-identities
+
+\ bitor {
+    { { X 0 } drop }
+    { { 0 X } nip }
+    { { X -1 } nip }
+    { { -1 X } drop }
+} define-identities
+
+\ bitxor {
+    { { X 0 } drop }
+    { { 0 X } nip }
+} define-identities
+
+\ shift {
+    { { 0 X } drop }
+    { { X 0 } drop }
+} define-identities
+
+: matches? ( pattern infos -- ? )
+    [ over X eq? [ 2drop t ] [ literal>> = ] if ] 2all? ;
+
+: find-identity ( patterns infos -- result )
+    '[ first _ matches? ] find swap [ second ] when ;
+
+GENERIC: apply-identities* ( node -- node )
+
+: simplify-to-constant ( #call constant -- nodes )
+    [ [ in-d>> #drop ] [ out-d>> first ] bi ] dip swap #push
+    2array ;
+
+: select-input ( node n -- #shuffle )
+    [ [ in-d>> ] [ out-d>> ] bi ] dip
+    pick nth over first associate #shuffle ;
+
+M: #call apply-identities*
+    dup word>> "identities" word-prop [
+        over node-input-infos find-identity [
+            {
+                { \ drop [ 0 select-input ] }
+                { \ nip [ 1 select-input ] }
+                [ simplify-to-constant ]
+            } case
+        ] when*
+    ] when* ;
+
+M: node apply-identities* ;
+
+: apply-identities ( nodes -- nodes' )
+    [ apply-identities* ] map-nodes ;

basis/compiler/tree/normalization/introductions/introductions.factor

@@ -0,0 +1,36 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces sequences accessors math kernel
+compiler.tree ;
+IN: compiler.tree.normalization.introductions
+
+SYMBOL: introductions
+
+GENERIC: count-introductions* ( node -- )
+
+: count-introductions ( nodes -- n )
+    #! Note: we use each, not each-node, since the #branch
+    #! method recurses into children directly and we don't
+    #! recurse into #recursive at all.
+    [
+        0 introductions set
+        [ count-introductions* ] each
+        introductions get
+    ] with-scope ;
+
+: introductions+ ( n -- ) introductions [ + ] change ;
+
+M: #introduce count-introductions*
+    out-d>> length introductions+ ;
+
+M: #branch count-introductions*
+    children>>
+    [ count-introductions ] map supremum
+    introductions+ ;
+
+M: #recursive count-introductions*
+    [ label>> ] [ child>> count-introductions ] bi
+    >>introductions
+    drop ;
+
+M: node count-introductions* drop ;

basis/compiler/tree/normalization/normalization-tests.factor

@@ -1,5 +1,8 @@
 IN: compiler.tree.normalization.tests
-USING: compiler.tree.builder compiler.tree.normalization
+USING: compiler.tree.builder compiler.tree.recursive
+compiler.tree.normalization
+compiler.tree.normalization.introductions
+compiler.tree.normalization.renaming
 compiler.tree compiler.tree.checker
 sequences accessors tools.test kernel math ;
 
@@ -22,27 +25,30 @@ sequences accessors tools.test kernel math ;
 [ 0 2 ] [
     [ foo ] build-tree
     [ recursive-inputs ]
-    [ normalize recursive-inputs ] bi
+    [ analyze-recursive normalize recursive-inputs ] bi
 ] unit-test
 
-[ ] [ [ [ 1 ] [ 2 ] if + * ] build-tree normalize check-nodes ] unit-test
+: test-normalization ( quot -- )
+    build-tree analyze-recursive normalize check-nodes ;
+
+[ ] [ [ [ 1 ] [ 2 ] if + * ] test-normalization ] unit-test
 
 DEFER: bbb
 : aaa ( x -- ) dup [ dup >r bbb r> aaa ] [ drop ] if ; inline recursive
 : bbb ( x -- ) >r drop 0 r> aaa ; inline recursive
 
-[ ] [ [ bbb ] build-tree normalize check-nodes ] unit-test
+[ ] [ [ bbb ] test-normalization ] unit-test
 
 : ccc ( -- ) ccc drop 1 ; inline recursive
 
-[ ] [ [ ccc ] build-tree normalize check-nodes ] unit-test
+[ ] [ [ ccc ] test-normalization ] unit-test
 
 DEFER: eee
 : ddd ( -- ) eee ; inline recursive
 : eee ( -- ) swap ddd ; inline recursive
 
-[ ] [ [ eee ] build-tree normalize check-nodes ] unit-test
+[ ] [ [ eee ] test-normalization ] unit-test
 
 : call-recursive-5 ( -- ) call-recursive-5 ; inline recursive
 
-[ ] [ [ call-recursive-5 swap ] build-tree normalize check-nodes ] unit-test
+[ ] [ [ call-recursive-5 swap ] test-normalization ] unit-test

basis/compiler/tree/normalization/normalization.factor

@@ -6,7 +6,9 @@ stack-checker.backend
 stack-checker.branches
 stack-checker.inlining
 compiler.tree
-compiler.tree.combinators ;
+compiler.tree.combinators
+compiler.tree.normalization.introductions
+compiler.tree.normalization.renaming ;
 IN: compiler.tree.normalization
 
 ! A transform pass done before optimization can begin to
@@ -16,9 +18,6 @@ IN: compiler.tree.normalization
 ! replaced with a single one, at the beginning of a program.
 ! This simplifies subsequent analysis.
 !
-! - We collect #return-recursive and #call-recursive nodes and
-! store them in the #recursive's label slot.
-!
 ! - We normalize #call-recursive as follows. The stack checker
 ! says that the inputs of a #call-recursive are the entire stack
 ! at the time of the call. This is a conservative estimate; we
@@ -28,93 +27,6 @@ IN: compiler.tree.normalization
 ! #call-recursive into a #copy of the unchanged values and a
 ! #call-recursive with trimmed inputs and outputs.
 
-! Collect introductions
-SYMBOL: introductions
-
-GENERIC: count-introductions* ( node -- )
-
-: count-introductions ( nodes -- n )
-    #! Note: we use each, not each-node, since the #branch
-    #! method recurses into children directly and we don't
-    #! recurse into #recursive at all.
-    [
-        0 introductions set
-        [ count-introductions* ] each
-        introductions get
-    ] with-scope ;
-
-: introductions+ ( n -- ) introductions [ + ] change ;
-
-M: #introduce count-introductions*
-    out-d>> length introductions+ ;
-
-M: #branch count-introductions*
-    children>>
-    [ count-introductions ] map supremum
-    introductions+ ;
-
-M: #recursive count-introductions*
-    [ label>> ] [ child>> count-introductions ] bi
-    >>introductions
-    drop ;
-
-M: node count-introductions* drop ;
-
-! Collect label info
-GENERIC: collect-label-info ( node -- )
-
-M: #return-recursive collect-label-info
-    dup label>> (>>return) ;
-
-M: #call-recursive collect-label-info
-    dup label>> calls>> push ;
-
-M: #recursive collect-label-info
-    label>> V{ } clone >>calls drop ;
-
-M: node collect-label-info drop ;
-
-! Rename
-SYMBOL: rename-map
-
-: rename-value ( value -- value' )
-    [ rename-map get at ] keep or ;
-
-: rename-values ( values -- values' )
-    rename-map get '[ [ _ at ] keep or ] map ;
-
-GENERIC: rename-node-values* ( node -- node )
-
-M: #introduce rename-node-values* ;
-
-M: #shuffle rename-node-values*
-    [ rename-values ] change-in-d
-    [ [ rename-value ] assoc-map ] change-mapping ;
-
-M: #push rename-node-values* ;
-
-M: #r> rename-node-values*
-    [ rename-values ] change-in-r ;
-
-M: #terminate rename-node-values*
-    [ rename-values ] change-in-d
-    [ rename-values ] change-in-r ;
-
-M: #phi rename-node-values*
-    [ [ rename-values ] map ] change-phi-in-d ;
-
-M: #declare rename-node-values*
-    [ [ [ rename-value ] dip ] assoc-map ] change-declaration ;
-
-M: #alien-callback rename-node-values* ;
-
-M: node rename-node-values*
-    [ rename-values ] change-in-d ;
-
-: rename-node-values ( nodes -- nodes' )
-    dup [ rename-node-values* drop ] each-node ;
-
-! Normalize
 GENERIC: normalize* ( node -- node' )
 
 SYMBOL: introduction-stack
@@ -125,10 +37,6 @@ SYMBOL: introduction-stack
 : pop-introductions ( n -- values )
     introduction-stack [ swap cut* swap ] change ;
 
-: add-renamings ( old new -- )
-    [ rename-values ] dip
-    rename-map get '[ _ set-at ] 2each ;
-
 M: #introduce normalize*
     out-d>> [ length pop-introductions ] keep add-renamings f ;
 
@@ -201,9 +109,8 @@ M: #call-recursive normalize*
 M: node normalize* ;
 
 : normalize ( nodes -- nodes' )
-    H{ } clone rename-map set
-    dup [ collect-label-info ] each-node
     dup count-introductions make-values
+    H{ } clone rename-map set
     [ (normalize) ] [ nip ] 2bi
     [ #introduce prefix ] unless-empty
     rename-node-values ;

basis/compiler/tree/normalization/renaming/renaming.factor

@@ -0,0 +1,48 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces assocs kernel accessors sequences fry
+compiler.tree compiler.tree.combinators ;
+IN: compiler.tree.normalization.renaming
+
+SYMBOL: rename-map
+
+: rename-value ( value -- value' )
+    [ rename-map get at ] keep or ;
+
+: rename-values ( values -- values' )
+    rename-map get '[ [ _ at ] keep or ] map ;
+
+: add-renamings ( old new -- )
+    [ rename-values ] dip
+    rename-map get '[ _ set-at ] 2each ;
+
+GENERIC: rename-node-values* ( node -- node )
+
+M: #introduce rename-node-values* ;
+
+M: #shuffle rename-node-values*
+    [ rename-values ] change-in-d
+    [ [ rename-value ] assoc-map ] change-mapping ;
+
+M: #push rename-node-values* ;
+
+M: #r> rename-node-values*
+    [ rename-values ] change-in-r ;
+
+M: #terminate rename-node-values*
+    [ rename-values ] change-in-d
+    [ rename-values ] change-in-r ;
+
+M: #phi rename-node-values*
+    [ [ rename-values ] map ] change-phi-in-d ;
+
+M: #declare rename-node-values*
+    [ [ [ rename-value ] dip ] assoc-map ] change-declaration ;
+
+M: #alien-callback rename-node-values* ;
+
+M: node rename-node-values*
+    [ rename-values ] change-in-d ;
+
+: rename-node-values ( nodes -- nodes' )
+    dup [ rename-node-values* drop ] each-node ;

basis/compiler/tree/optimizer/optimizer.factor

@@ -1,15 +1,16 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel namespaces
+compiler.tree.recursive
 compiler.tree.normalization
 compiler.tree.propagation
 compiler.tree.cleanup
 compiler.tree.escape-analysis
 compiler.tree.tuple-unboxing
+compiler.tree.identities
 compiler.tree.def-use
 compiler.tree.dead-code
 compiler.tree.strength-reduction
-compiler.tree.loop.detection
 compiler.tree.finalization
 compiler.tree.checker ;
 IN: compiler.tree.optimizer
@@ -17,12 +18,13 @@ IN: compiler.tree.optimizer
 SYMBOL: check-optimizer?
 
 : optimize-tree ( nodes -- nodes' )
+    analyze-recursive
     normalize
     propagate
     cleanup
-    detect-loops
     escape-analysis
     unbox-tuples
+    apply-identities
     compute-def-use
     remove-dead-code
     ! strength-reduce

basis/compiler/tree/propagation/inlining/inlining.factor

@@ -6,11 +6,20 @@ classes.algebra classes.union sets quotations assocs combinators
 words namespaces
 compiler.tree
 compiler.tree.builder
+compiler.tree.recursive
+compiler.tree.combinators
 compiler.tree.normalization
 compiler.tree.propagation.info
 compiler.tree.propagation.nodes ;
 IN: compiler.tree.propagation.inlining
 
+! We count nodes up-front; if there are relatively few nodes,
+! we are more eager to inline
+SYMBOL: node-count
+
+: count-nodes ( nodes -- )
+    0 swap [ drop 1+ ] each-node node-count set ;
+
 ! Splicing nodes
 GENERIC: splicing-nodes ( #call word/quot/f -- nodes )
 
@@ -18,7 +27,7 @@ M: word splicing-nodes
     [ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ;
 
 M: quotation splicing-nodes
-    build-sub-tree normalize ;
+    build-sub-tree analyze-recursive normalize ;
 
 : propagate-body ( #call -- )
     body>> (propagate) ;
@@ -113,12 +122,13 @@ DEFER: (flat-length)
     [ classes-known? 2 0 ? ]
     [
         {
+            [ drop node-count get 45 swap [-] 8 /i ]
             [ flat-length 24 swap [-] 4 /i ]
             [ "default" word-prop -4 0 ? ]
             [ "specializer" word-prop 1 0 ? ]
             [ method-body? 1 0 ? ]
         } cleave
-    ] bi* + + + + ;
+    ] bi* + + + + + ;
 
 : should-inline? ( #call word -- ? )
     inlining-rank 5 >= ;

basis/compiler/tree/propagation/propagation-tests.factor

@@ -1,5 +1,5 @@
 USING: kernel compiler.tree.builder compiler.tree
-compiler.tree.propagation
+compiler.tree.propagation compiler.tree.recursive
 compiler.tree.normalization tools.test math math.order
 accessors sequences arrays kernel.private vectors
 alien.accessors alien.c-types sequences.private
@@ -14,6 +14,7 @@ IN: compiler.tree.propagation.tests
 
 : final-info ( quot -- seq )
     build-tree
+    analyze-recursive
     normalize
     propagate
     compute-def-use

basis/compiler/tree/propagation/propagation.factor

@@ -6,6 +6,7 @@ compiler.tree.propagation.copy
 compiler.tree.propagation.info
 compiler.tree.propagation.nodes
 compiler.tree.propagation.simple
+compiler.tree.propagation.inlining
 compiler.tree.propagation.branches
 compiler.tree.propagation.recursive
 compiler.tree.propagation.constraints
@@ -18,4 +19,5 @@ IN: compiler.tree.propagation
     H{ } clone copies set
     H{ } clone constraints set
     H{ } clone value-infos set
+    dup count-nodes
     dup (propagate) ;

basis/compiler/tree/propagation/recursive/recursive.factor

@@ -70,7 +70,8 @@ M: #recursive propagate-around ( #recursive -- )
     [ generalize-return-interval ] map ;
 
 : return-infos ( node -- infos )
-    label>> return>> node-input-infos generalize-return ;
+    label>> [ return>> node-input-infos ] [ loop?>> ] bi
+    [ generalize-return ] unless ;
 
 M: #call-recursive propagate-before ( #call-recursive -- )
     [ ] [ return-infos ] [ node-output-infos ] tri

basis/compiler/tree/recursive/recursive-tests.factor

@@ -1,5 +1,5 @@
-IN: compiler.tree.loop.detection.tests
+IN: compiler.tree.recursive.tests
-USING: compiler.tree.loop.detection tools.test
+USING: compiler.tree.recursive tools.test
 kernel combinators.short-circuit math sequences accessors
 compiler.tree
 compiler.tree.builder
@@ -10,7 +10,7 @@ compiler.tree.combinators ;
 [ { f t t t } ] [ t { f f t t } (tail-calls) ] unit-test
 [ { f f f t } ] [ t { f f t f } (tail-calls) ] unit-test
 
-\ detect-loops must-infer
+\ analyze-recursive must-infer
 
 : label-is-loop? ( nodes word -- ? )
     [
@@ -38,22 +38,22 @@ compiler.tree.combinators ;
     dup [ 1+ loop-test-1 ] [ drop ] if ; inline recursive
                           
 [ t ] [
-    [ loop-test-1 ] build-tree detect-loops
+    [ loop-test-1 ] build-tree analyze-recursive
     \ loop-test-1 label-is-loop?
 ] unit-test
 
 [ t ] [
-    [ loop-test-1 1 2 3 ] build-tree detect-loops
+    [ loop-test-1 1 2 3 ] build-tree analyze-recursive
     \ loop-test-1 label-is-loop?
 ] unit-test
 
 [ t ] [
-    [ [ loop-test-1 ] each ] build-tree detect-loops
+    [ [ loop-test-1 ] each ] build-tree analyze-recursive
     \ loop-test-1 label-is-loop?
 ] unit-test
 
 [ t ] [
-    [ [ loop-test-1 ] each ] build-tree detect-loops
+    [ [ loop-test-1 ] each ] build-tree analyze-recursive
     \ (each-integer) label-is-loop?
 ] unit-test
 
@@ -61,7 +61,7 @@ compiler.tree.combinators ;
     dup [ 1+ loop-test-2 1- ] [ drop ] if ; inline recursive
 
 [ t ] [
-    [ loop-test-2 ] build-tree detect-loops
+    [ loop-test-2 ] build-tree analyze-recursive
     \ loop-test-2 label-is-not-loop?
 ] unit-test
 
@@ -69,7 +69,7 @@ compiler.tree.combinators ;
     dup [ [ loop-test-3 ] each ] [ drop ] if ; inline recursive
 
 [ t ] [
-    [ loop-test-3 ] build-tree detect-loops
+    [ loop-test-3 ] build-tree analyze-recursive
     \ loop-test-3 label-is-not-loop?
 ] unit-test
 
@@ -81,7 +81,7 @@ compiler.tree.combinators ;
     ] if ; inline recursive
 
 [ f ] [
-    [ [ [ ] map ] map ] build-tree detect-loops
+    [ [ [ ] map ] map ] build-tree analyze-recursive
     [
         dup #recursive? [ label>> loop?>> not ] [ drop f ] if
     ] contains-node?
@@ -98,22 +98,22 @@ DEFER: a
     blah [ b ] [ a ] if ; inline recursive
 
 [ t ] [
-    [ a ] build-tree detect-loops
+    [ a ] build-tree analyze-recursive
     \ a label-is-loop?
 ] unit-test
 
 [ t ] [
-    [ a ] build-tree detect-loops
+    [ a ] build-tree analyze-recursive
     \ b label-is-loop?
 ] unit-test
 
 [ t ] [
-    [ b ] build-tree detect-loops
+    [ b ] build-tree analyze-recursive
     \ a label-is-loop?
 ] unit-test
 
 [ t ] [
-    [ a ] build-tree detect-loops
+    [ a ] build-tree analyze-recursive
     \ b label-is-loop?
 ] unit-test
 
@@ -126,12 +126,12 @@ DEFER: a'
     blah [ b' ] [ a' ] if ; inline recursive
 
 [ f ] [
-    [ a' ] build-tree detect-loops
+    [ a' ] build-tree analyze-recursive
     \ a' label-is-loop?
 ] unit-test
 
 [ f ] [
-    [ b' ] build-tree detect-loops
+    [ b' ] build-tree analyze-recursive
     \ b' label-is-loop?
 ] unit-test
 
@@ -140,11 +140,11 @@ DEFER: a'
 ! sound.
 
 [ t ] [
-    [ b' ] build-tree detect-loops
+    [ b' ] build-tree analyze-recursive
     \ a' label-is-loop?
 ] unit-test
 
 [ f ] [
-    [ a' ] build-tree detect-loops
+    [ a' ] build-tree analyze-recursive
     \ b' label-is-loop?
 ] unit-test

basis/compiler/tree/recursive/recursive.factor

@@ -1,14 +1,27 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences namespaces assocs accessors fry
+USING: kernel assocs namespaces accessors sequences deques
-compiler.tree deques search-deques ;
+search-deques compiler.tree compiler.tree.combinators ;
-IN: compiler.tree.loop.detection
+IN: compiler.tree.recursive
+
+! Collect label info
+GENERIC: collect-label-info ( node -- )
+
+M: #return-recursive collect-label-info
+    dup label>> (>>return) ;
+
+M: #call-recursive collect-label-info
+    dup label>> calls>> push ;
+
+M: #recursive collect-label-info
+    label>> V{ } clone >>calls drop ;
+
+M: node collect-label-info drop ;
 
 ! A loop is a #recursive which only tail calls itself, and those
 ! calls are nested inside other loops only. We optimistically
 ! assume all #recursive nodes are loops, disqualifying them as
 ! we see evidence to the contrary.
-
 : (tail-calls) ( tail? seq -- seq' )
     reverse [ swap [ and ] keep ] map nip reverse ;
 
@@ -84,5 +97,6 @@ M: node collect-loop-info* 2drop ;
         ] [ drop ] if
     ] slurp-deque ;
 
-: detect-loops ( nodes -- nodes )
+: analyze-recursive ( nodes -- nodes )
+    dup [ collect-label-info ] each-node
     dup collect-loop-info disqualify-loops ;

basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor

@@ -1,16 +1,18 @@
 IN: compiler.tree.tuple-unboxing.tests
 USING: tools.test compiler.tree.tuple-unboxing compiler.tree
-compiler.tree.builder compiler.tree.normalization
+compiler.tree.builder compiler.tree.recursive
-compiler.tree.propagation compiler.tree.cleanup
+compiler.tree.normalization compiler.tree.propagation
-compiler.tree.escape-analysis compiler.tree.tuple-unboxing
+compiler.tree.cleanup compiler.tree.escape-analysis
-compiler.tree.checker compiler.tree.def-use kernel accessors
+compiler.tree.tuple-unboxing compiler.tree.checker
-sequences math math.private sorting math.order binary-search
+compiler.tree.def-use kernel accessors sequences math
-sequences.private slots.private ;
+math.private sorting math.order binary-search sequences.private
+slots.private ;
 
 \ unbox-tuples must-infer
 
 : test-unboxing ( quot -- )
     build-tree
+    analyze-recursive
     normalize
     propagate
     cleanup

basis/cpu/x86/32/32.factor

@@ -173,6 +173,9 @@ M: x86.32 %box-long-long ( n func -- )
         [ (%box-long-long) ] [ f %alien-invoke ] bi*
     ] with-aligned-stack ;
 
+: struct-return@ ( size n -- n )
+    [ stack-frame* cell + + ] [ \ stack-frame get swap - ] ?if ;
+
 M: x86.32 %box-large-struct ( n size -- )
     ! Compute destination address
     [ swap struct-return@ ] keep

basis/cpu/x86/64/64.factor

@@ -116,6 +116,9 @@ M: x86.64 %box-small-struct ( size -- )
     RDX swap MOV
     "box_small_struct" f %alien-invoke ;
 
+: struct-return@ ( size n -- n )
+    [ ] [ \ stack-frame get swap - ] ?if ;
+
 M: x86.64 %box-large-struct ( n size -- )
     ! Struct size is parameter 2
     RSI over MOV

basis/cpu/x86/architecture/architecture.factor

@@ -141,13 +141,6 @@ M: x86 small-enough? ( n -- ? )
 
 : temp@ ( n -- op ) stack-reg \ stack-frame get rot - [+] ;
 
-: struct-return@ ( size n -- n )
-    [
-        stack-frame* cell + +
-    ] [
-        \ stack-frame get swap -
-    ] ?if ;
-
 HOOK: %unbox-struct-1 cpu ( -- )
 
 HOOK: %unbox-struct-2 cpu ( -- )

basis/hints/hints.factor

@@ -91,7 +91,7 @@ IN: hints
 
 \ >string { sbuf } "specializer" set-word-prop
 
-\ >array { { string } { vector } } "specializer" set-word-prop
+\ >array { { vector } } "specializer" set-word-prop
 
 \ >vector { { array } { vector } } "specializer" set-word-prop
 
@@ -101,7 +101,7 @@ IN: hints
 
 \ memq? { array } "specializer" set-word-prop
 
-\ member? { fixnum string } "specializer" set-word-prop
+\ member? { array } "specializer" set-word-prop
 
 \ assoc-stack { vector } "specializer" set-word-prop
 

basis/math/partial-dispatch/partial-dispatch.factor

@@ -2,7 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel kernel.private math math.private words
 sequences parser namespaces make assocs quotations arrays locals
-generic generic.math hashtables effects compiler.units ;
+generic generic.math hashtables effects compiler.units
+classes.algebra ;
 IN: math.partial-dispatch
 
 ! Partial dispatch.
@@ -96,19 +97,28 @@ SYMBOL: fast-math-ops
     [ drop math-class-max swap specific-method >boolean ] if ;
 
 : (derived-ops) ( word assoc -- words )
-    swap [ rot first eq? nip ] curry assoc-filter values ;
+    swap [ rot first eq? nip ] curry assoc-filter ;
 
 : derived-ops ( word -- words )
-    [ 1array ]
+    [ 1array ] [ math-ops get (derived-ops) values ] bi append ;
-    [ math-ops get (derived-ops) ]
-    bi append ;
 
 : fast-derived-ops ( word -- words )
-    fast-math-ops get (derived-ops) ;
+    fast-math-ops get (derived-ops) values ;
 
 : all-derived-ops ( word -- words )
     [ derived-ops ] [ fast-derived-ops ] bi append ;
 
+: integer-derived-ops ( word -- words )
+    [ math-ops get (derived-ops) ] [ fast-math-ops get (derived-ops) ] bi
+    [
+            [
+            drop
+            [ second integer class<= ]
+            [ third integer class<= ]
+            bi and
+        ] assoc-filter values
+    ] bi@ append ;
+
 : each-derived-op ( word quot -- )
     >r derived-ops r> each ; inline
 

core/sequences/sequences.factor

@@ -236,6 +236,10 @@ INSTANCE: repetition immutable-sequence
 
 <PRIVATE
 
+: check-length ( n -- n )
+    #! Ricing.
+    dup integer? [ "length not an integer" throw ] unless ; inline
+
 : ((copy)) ( dst i src j n -- dst i src j n )
     dup -roll [
         + swap nth-unsafe -roll [
@@ -248,8 +252,9 @@ INSTANCE: repetition immutable-sequence
     inline recursive
 
 : prepare-subseq ( from to seq -- dst i src j n )
+    #! The check-length call forces partial dispatch
     [ >r swap - r> new-sequence dup 0 ] 3keep
-    -rot drop roll length ; inline
+    -rot drop roll length check-length ; inline
 
 : check-copy ( src n dst -- )
     over 0 < [ bounds-error ] when
@@ -273,7 +278,8 @@ PRIVATE>
 : but-last ( seq -- headseq ) 1 head* ;
 
 : copy ( src i dst -- )
-    pick length >r 3dup check-copy spin 0 r>
+    #! The check-length call forces partial dispatch
+    pick length check-length >r 3dup check-copy spin 0 r>
     (copy) drop ; inline
 
 M: sequence clone-like

extra/benchmark/nsieve-bytes/nsieve-bytes.factor

@@ -0,0 +1,35 @@
+IN: benchmark.nsieve-bytes
+USING: math math.parser sequences sequences.private kernel
+byte-arrays make io ;
+
+: clear-flags ( step i seq -- )
+    2dup length >= [
+        3drop
+    ] [
+        0 2over set-nth-unsafe >r over + r> clear-flags
+    ] if ; inline recursive
+
+: (nsieve) ( count i seq -- count )
+    2dup length < [
+        2dup nth-unsafe 0 > [
+            over dup 2 * pick clear-flags
+            rot 1+ -rot ! increment count
+        ] when >r 1+ r> (nsieve)
+    ] [
+        2drop
+    ] if ; inline recursive
+
+: nsieve ( m -- count )
+    0 2 rot 1+ <byte-array> dup [ drop 1 ] change-each (nsieve) ;
+
+: nsieve. ( m -- )
+    [ "Primes up to " % dup # " " % nsieve # ] "" make print ;
+
+: nsieve-main ( n -- )
+    dup 2^ 10000 * nsieve.
+    dup 1 - 2^ 10000 * nsieve.
+    2 - 2^ 10000 * nsieve. ;
+
+: nsieve-main* ( -- ) 9 nsieve-main ;
+
+MAIN: nsieve-main*

work/README.txt

@@ -0,0 +1 @@
+The 'work' directory is for your own personal vocabularies.