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

diff --git a/basis/cocoa/types/types.factor b/basis/cocoa/types/types.factor
index 6e65bc1a720028dba386025b1c943c96c28641cc..0bf4257a0b8355c7718b502ecc499858ad0a12fe 100644 (file)
--- a/basis/cocoa/types/types.factor
+++ b/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 )

diff --git a/basis/compiler/generator/registers/registers.factor b/basis/compiler/generator/registers/registers.factor
index 76d3c325947720ef3e69eaaca4268286dc528806..6fdb8d98860a9525bb315d5a4ee24293df27827b 100755 (executable)
--- a/basis/compiler/generator/registers/registers.factor
+++ b/basis/compiler/generator/registers/registers.factor
@@ -50,12 +50,20 @@ 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 ;
 
-INSTANCE: vreg value
+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 ;
 
-M: float-regs move-spec drop float ;
-M: float-regs operand-class* drop float ;
+INSTANCE: vreg value
 
 ! Temporary register for stack shuffling
 SINGLETON: temp-reg

diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor
index e44ae681ffed11f4dfec0b8fb0538335d7372be1..dc7388879657a0ace1ccc937a5e4f7df889a36f8 100755 (executable)
--- a/basis/compiler/tests/alien.factor
+++ b/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

diff --git a/basis/compiler/tree/cleanup/cleanup-tests.factor b/basis/compiler/tree/cleanup/cleanup-tests.factor
index 15bc6444ac1c46c155c6e4cc2f17214bf33b60b5..2e8eb15959b3a91689cc0392e06c18bd14478dee 100644 (file)
--- a/basis/compiler/tree/cleanup/cleanup-tests.factor
+++ b/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
 

diff --git a/basis/compiler/tree/dead-code/dead-code-tests.factor b/basis/compiler/tree/dead-code/dead-code-tests.factor
index e8d2b290276897d26afb74241cc9e1ca946c0c58..7b15fdf8563bdb1b82da3ca91d8c0ac4d0e84d62 100644 (file)
--- a/basis/compiler/tree/dead-code/dead-code-tests.factor
+++ b/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
-kernel math stack-checker.state accessors combinators io
-prettyprint words sequences.deep sequences.private arrays
-classes kernel.private ;
+compiler.tree.recursive compiler.tree.normalization
+compiler.tree.checker tools.test kernel math stack-checker.state
+accessors combinators io prettyprint words sequences.deep
+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

diff --git a/basis/compiler/tree/def-use/def-use-tests.factor b/basis/compiler/tree/def-use/def-use-tests.factor
index 993627eb15fa7908059d3631e955183dc8b866c4..d970e04afd815e3c0dc3fe6a9fe822a542270a66 100755 (executable)
--- a/basis/compiler/tree/def-use/def-use-tests.factor
+++ b/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.cleanup compiler.tree.def-use arrays kernel.private
-sorting math.order binary-search compiler.tree.checker ;
+compiler.tree.recursive compiler.tree.normalization
+compiler.tree.propagation compiler.tree.cleanup
+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.

diff --git a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor
index f51046c6cb51bc5f05725e8c1b26e4c0ea08db70..7ece8a5a804b889505ac19c2e5e787807cb3af40 100644 (file)
--- a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor
+++ b/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.propagation compiler.tree.cleanup
-compiler.tree.combinators compiler.tree sequences math math.private
-kernel tools.test accessors slots.private quotations.private
-prettyprint classes.tuple.private classes classes.tuple
-compiler.intrinsics namespaces compiler.tree.propagation.info
-stack-checker.errors kernel.private ;
+compiler.tree.recursive compiler.tree.normalization
+math.functions compiler.tree.propagation compiler.tree.cleanup
+compiler.tree.combinators compiler.tree sequences math
+math.private kernel tools.test accessors slots.private
+quotations.private prettyprint classes.tuple.private classes
+classes.tuple compiler.intrinsics namespaces
+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

diff --git a/basis/compiler/tree/finalization/finalization.factor b/basis/compiler/tree/finalization/finalization.factor
index dafe032ab6afb68d57e7b08c725f1b4f2ddb3830..ba7e4ff652b27b7b8618119648eb254e29f5547c 100644 (file)
--- a/basis/compiler/tree/finalization/finalization.factor
+++ b/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

diff --git a/basis/compiler/tree/identities/identities.factor b/basis/compiler/tree/identities/identities.factor
new file mode 100644 (file)
index 0000000..d6ed59c
--- /dev/null
+++ b/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 ;

diff --git a/basis/compiler/tree/loop/detection/detection-tests.factor b/basis/compiler/tree/loop/detection/detection-tests.factor
deleted file mode 100644 (file)
index 5864dc3..0000000
--- a/basis/compiler/tree/loop/detection/detection-tests.factor
+++ /dev/null
@@ -1,150 +0,0 @@
-IN: compiler.tree.loop.detection.tests
-USING: compiler.tree.loop.detection tools.test
-kernel combinators.short-circuit math sequences accessors
-compiler.tree
-compiler.tree.builder
-compiler.tree.combinators ;
-
-[ { f f f f } ] [ f { f t f f } (tail-calls) ] unit-test
-[ { f f f t } ] [ t { f t f f } (tail-calls) ] unit-test
-[ { 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
-
-: label-is-loop? ( nodes word -- ? )
-    [
-        {
-            [ drop #recursive? ]
-            [ drop label>> loop?>> ]
-            [ swap label>> word>> eq? ]
-        } 2&&
-    ] curry contains-node? ;
-
-\ label-is-loop? must-infer
-
-: label-is-not-loop? ( nodes word -- ? )
-    [
-        {
-            [ drop #recursive? ]
-            [ drop label>> loop?>> not ]
-            [ swap label>> word>> eq? ]
-        } 2&&
-    ] curry contains-node? ;
-
-\ label-is-not-loop? must-infer
-
-: loop-test-1 ( a -- )
-    dup [ 1+ loop-test-1 ] [ drop ] if ; inline recursive
-                          
-[ t ] [
-    [ loop-test-1 ] build-tree detect-loops
-    \ loop-test-1 label-is-loop?
-] unit-test
-
-[ t ] [
-    [ loop-test-1 1 2 3 ] build-tree detect-loops
-    \ loop-test-1 label-is-loop?
-] unit-test
-
-[ t ] [
-    [ [ loop-test-1 ] each ] build-tree detect-loops
-    \ loop-test-1 label-is-loop?
-] unit-test
-
-[ t ] [
-    [ [ loop-test-1 ] each ] build-tree detect-loops
-    \ (each-integer) label-is-loop?
-] unit-test
-
-: loop-test-2 ( a -- )
-    dup [ 1+ loop-test-2 1- ] [ drop ] if ; inline recursive
-
-[ t ] [
-    [ loop-test-2 ] build-tree detect-loops
-    \ loop-test-2 label-is-not-loop?
-] unit-test
-
-: loop-test-3 ( a -- )
-    dup [ [ loop-test-3 ] each ] [ drop ] if ; inline recursive
-
-[ t ] [
-    [ loop-test-3 ] build-tree detect-loops
-    \ loop-test-3 label-is-not-loop?
-] unit-test
-
-: loop-test-4 ( a -- )
-    dup [
-        loop-test-4
-    ] [
-        drop
-    ] if ; inline recursive
-
-[ f ] [
-    [ [ [ ] map ] map ] build-tree detect-loops
-    [
-        dup #recursive? [ label>> loop?>> not ] [ drop f ] if
-    ] contains-node?
-] unit-test
-
-: blah f ;
-
-DEFER: a
-
-: b ( -- )
-    blah [ b ] [ a ] if ; inline recursive
-
-: a ( -- )
-    blah [ b ] [ a ] if ; inline recursive
-
-[ t ] [
-    [ a ] build-tree detect-loops
-    \ a label-is-loop?
-] unit-test
-
-[ t ] [
-    [ a ] build-tree detect-loops
-    \ b label-is-loop?
-] unit-test
-
-[ t ] [
-    [ b ] build-tree detect-loops
-    \ a label-is-loop?
-] unit-test
-
-[ t ] [
-    [ a ] build-tree detect-loops
-    \ b label-is-loop?
-] unit-test
-
-DEFER: a'
-
-: b' ( -- )
-    blah [ b' b' ] [ a' ] if ; inline recursive
-
-: a' ( -- )
-    blah [ b' ] [ a' ] if ; inline recursive
-
-[ f ] [
-    [ a' ] build-tree detect-loops
-    \ a' label-is-loop?
-] unit-test
-
-[ f ] [
-    [ b' ] build-tree detect-loops
-    \ b' label-is-loop?
-] unit-test
-
-! I used to think this should be f, but doing this on pen and
-! paper almost convinced me that a loop conversion here is
-! sound.
-
-[ t ] [
-    [ b' ] build-tree detect-loops
-    \ a' label-is-loop?
-] unit-test
-
-[ f ] [
-    [ a' ] build-tree detect-loops
-    \ b' label-is-loop?
-] unit-test

diff --git a/basis/compiler/tree/loop/detection/detection.factor b/basis/compiler/tree/loop/detection/detection.factor
deleted file mode 100644 (file)
index 1f9e425..0000000
--- a/basis/compiler/tree/loop/detection/detection.factor
+++ /dev/null
@@ -1,88 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences namespaces assocs accessors fry
-compiler.tree deques search-deques ;
-IN: compiler.tree.loop.detection
-
-! 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 ;
-
-: tail-calls ( tail? node -- seq )
-    [
-        [ #phi? ]
-        [ #return? ]
-        [ #return-recursive? ]
-        tri or or
-    ] map (tail-calls) ;
-
-SYMBOL: loop-heights
-SYMBOL: loop-calls
-SYMBOL: loop-stack
-SYMBOL: work-list
-
-GENERIC: collect-loop-info* ( tail? node -- )
-
-: non-tail-label-info ( nodes -- )
-    [ f swap collect-loop-info* ] each ;
-
-: (collect-loop-info) ( tail? nodes -- )
-    [ tail-calls ] keep [ collect-loop-info* ] 2each ;
-
-: remember-loop-info ( label -- )
-    loop-stack get length swap loop-heights get set-at ;
-
-M: #recursive collect-loop-info*
-    nip
-    [
-        [
-            label>>
-            [ loop-stack [ swap suffix ] change ]
-            [ remember-loop-info ]
-            [ t >>loop? drop ]
-            tri
-        ]
-        [ t swap child>> (collect-loop-info) ] bi
-    ] with-scope ;
-
-: current-loop-nesting ( label -- labels )
-    loop-stack get swap loop-heights get at tail ;
-
-: disqualify-loop ( label -- )
-    work-list get push-front ;
-
-M: #call-recursive collect-loop-info*
-    label>>
-    swap [ dup disqualify-loop ] unless
-    dup current-loop-nesting [ loop-calls get push-at ] with each ;
-
-M: #if collect-loop-info*
-    children>> [ (collect-loop-info) ] with each ;
-
-M: #dispatch collect-loop-info*
-    children>> [ (collect-loop-info) ] with each ;
-
-M: node collect-loop-info* 2drop ;
-
-: collect-loop-info ( node -- )
-    { } loop-stack set
-    H{ } clone loop-calls set
-    H{ } clone loop-heights set
-    <hashed-dlist> work-list set
-    t swap (collect-loop-info) ;
-
-: disqualify-loops ( -- )
-    work-list get [
-        dup loop?>> [
-            [ f >>loop? drop ]
-            [ loop-calls get at [ disqualify-loop ] each ]
-            bi
-        ] [ drop ] if
-    ] slurp-deque ;
-
-: detect-loops ( nodes -- nodes )
-    dup collect-loop-info disqualify-loops ;

diff --git a/basis/compiler/tree/normalization/introductions/introductions.factor b/basis/compiler/tree/normalization/introductions/introductions.factor
new file mode 100644 (file)
index 0000000..9e96dc0
--- /dev/null
+++ b/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 ;

diff --git a/basis/compiler/tree/normalization/normalization-tests.factor b/basis/compiler/tree/normalization/normalization-tests.factor
index 1b4f728adc24810ad6dc9b6019df71e1c23b2970..c4a97fcc92a09a9b4337edb0fd8feab768bab494 100644 (file)
--- a/basis/compiler/tree/normalization/normalization-tests.factor
+++ b/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

diff --git a/basis/compiler/tree/normalization/normalization.factor b/basis/compiler/tree/normalization/normalization.factor
index b826a1590bfc09c0473b1f8169b2eb485f2489ee..bebe2e91b6521eb19ac1860566371f182b00c028 100644 (file)
--- a/basis/compiler/tree/normalization/normalization.factor
+++ b/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 ;

diff --git a/basis/compiler/tree/normalization/renaming/renaming.factor b/basis/compiler/tree/normalization/renaming/renaming.factor
new file mode 100644 (file)
index 0000000..3050df2
--- /dev/null
+++ b/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 ;

diff --git a/basis/compiler/tree/optimizer/optimizer.factor b/basis/compiler/tree/optimizer/optimizer.factor
index aafc7f137ba729f7cb1991bacf7f23000dc06d6e..3196253d457106a0e2b167ca491dba046ef807da 100644 (file)
--- a/basis/compiler/tree/optimizer/optimizer.factor
+++ b/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

diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor
index 4f93769b7f9ec1a2a02a91d134e2ffaa65adef28..48864d8782cea61dda1b6bfbe87a9172b6a255ca 100644 (file)
--- a/basis/compiler/tree/propagation/inlining/inlining.factor
+++ b/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 >= ;

diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor
index f04460f32a65aa053bceb6cde858a351206eb7fe..a115ee53c2692e91d00c5251668b3914ac849903 100644 (file)
--- a/basis/compiler/tree/propagation/propagation-tests.factor
+++ b/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

diff --git a/basis/compiler/tree/propagation/propagation.factor b/basis/compiler/tree/propagation/propagation.factor
index f184418d435ca67e97f4d9bd1ddba36bda9799ee..d82ebed43379b3d805526969cfd5bb6d0caff4d6 100755 (executable)
--- a/basis/compiler/tree/propagation/propagation.factor
+++ b/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) ;

diff --git a/basis/compiler/tree/propagation/recursive/recursive.factor b/basis/compiler/tree/propagation/recursive/recursive.factor
index 649eaa763e598b2621bab5e0a2c3b9b00cafb93d..53dce813a3874624a1b760f83705ef1583cfe040 100644 (file)
--- a/basis/compiler/tree/propagation/recursive/recursive.factor
+++ b/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

diff --git a/basis/compiler/tree/recursive/recursive-tests.factor b/basis/compiler/tree/recursive/recursive-tests.factor
new file mode 100644 (file)
index 0000000..c66c182
--- /dev/null
+++ b/basis/compiler/tree/recursive/recursive-tests.factor
@@ -0,0 +1,150 @@
+IN: compiler.tree.recursive.tests
+USING: compiler.tree.recursive tools.test
+kernel combinators.short-circuit math sequences accessors
+compiler.tree
+compiler.tree.builder
+compiler.tree.combinators ;
+
+[ { f f f f } ] [ f { f t f f } (tail-calls) ] unit-test
+[ { f f f t } ] [ t { f t f f } (tail-calls) ] unit-test
+[ { 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
+
+\ analyze-recursive must-infer
+
+: label-is-loop? ( nodes word -- ? )
+    [
+        {
+            [ drop #recursive? ]
+            [ drop label>> loop?>> ]
+            [ swap label>> word>> eq? ]
+        } 2&&
+    ] curry contains-node? ;
+
+\ label-is-loop? must-infer
+
+: label-is-not-loop? ( nodes word -- ? )
+    [
+        {
+            [ drop #recursive? ]
+            [ drop label>> loop?>> not ]
+            [ swap label>> word>> eq? ]
+        } 2&&
+    ] curry contains-node? ;
+
+\ label-is-not-loop? must-infer
+
+: loop-test-1 ( a -- )
+    dup [ 1+ loop-test-1 ] [ drop ] if ; inline recursive
+                          
+[ t ] [
+    [ loop-test-1 ] build-tree analyze-recursive
+    \ loop-test-1 label-is-loop?
+] unit-test
+
+[ t ] [
+    [ 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 analyze-recursive
+    \ loop-test-1 label-is-loop?
+] unit-test
+
+[ t ] [
+    [ [ loop-test-1 ] each ] build-tree analyze-recursive
+    \ (each-integer) label-is-loop?
+] unit-test
+
+: loop-test-2 ( a -- )
+    dup [ 1+ loop-test-2 1- ] [ drop ] if ; inline recursive
+
+[ t ] [
+    [ loop-test-2 ] build-tree analyze-recursive
+    \ loop-test-2 label-is-not-loop?
+] unit-test
+
+: loop-test-3 ( a -- )
+    dup [ [ loop-test-3 ] each ] [ drop ] if ; inline recursive
+
+[ t ] [
+    [ loop-test-3 ] build-tree analyze-recursive
+    \ loop-test-3 label-is-not-loop?
+] unit-test
+
+: loop-test-4 ( a -- )
+    dup [
+        loop-test-4
+    ] [
+        drop
+    ] if ; inline recursive
+
+[ f ] [
+    [ [ [ ] map ] map ] build-tree analyze-recursive
+    [
+        dup #recursive? [ label>> loop?>> not ] [ drop f ] if
+    ] contains-node?
+] unit-test
+
+: blah f ;
+
+DEFER: a
+
+: b ( -- )
+    blah [ b ] [ a ] if ; inline recursive
+
+: a ( -- )
+    blah [ b ] [ a ] if ; inline recursive
+
+[ t ] [
+    [ a ] build-tree analyze-recursive
+    \ a label-is-loop?
+] unit-test
+
+[ t ] [
+    [ a ] build-tree analyze-recursive
+    \ b label-is-loop?
+] unit-test
+
+[ t ] [
+    [ b ] build-tree analyze-recursive
+    \ a label-is-loop?
+] unit-test
+
+[ t ] [
+    [ a ] build-tree analyze-recursive
+    \ b label-is-loop?
+] unit-test
+
+DEFER: a'
+
+: b' ( -- )
+    blah [ b' b' ] [ a' ] if ; inline recursive
+
+: a' ( -- )
+    blah [ b' ] [ a' ] if ; inline recursive
+
+[ f ] [
+    [ a' ] build-tree analyze-recursive
+    \ a' label-is-loop?
+] unit-test
+
+[ f ] [
+    [ b' ] build-tree analyze-recursive
+    \ b' label-is-loop?
+] unit-test
+
+! I used to think this should be f, but doing this on pen and
+! paper almost convinced me that a loop conversion here is
+! sound.
+
+[ t ] [
+    [ b' ] build-tree analyze-recursive
+    \ a' label-is-loop?
+] unit-test
+
+[ f ] [
+    [ a' ] build-tree analyze-recursive
+    \ b' label-is-loop?
+] unit-test

diff --git a/basis/compiler/tree/recursive/recursive.factor b/basis/compiler/tree/recursive/recursive.factor
new file mode 100644 (file)
index 0000000..d1e4c7c
--- /dev/null
+++ b/basis/compiler/tree/recursive/recursive.factor
@@ -0,0 +1,102 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel assocs namespaces accessors sequences deques
+search-deques compiler.tree compiler.tree.combinators ;
+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 ;
+
+: tail-calls ( tail? node -- seq )
+    [
+        [ #phi? ]
+        [ #return? ]
+        [ #return-recursive? ]
+        tri or or
+    ] map (tail-calls) ;
+
+SYMBOL: loop-heights
+SYMBOL: loop-calls
+SYMBOL: loop-stack
+SYMBOL: work-list
+
+GENERIC: collect-loop-info* ( tail? node -- )
+
+: non-tail-label-info ( nodes -- )
+    [ f swap collect-loop-info* ] each ;
+
+: (collect-loop-info) ( tail? nodes -- )
+    [ tail-calls ] keep [ collect-loop-info* ] 2each ;
+
+: remember-loop-info ( label -- )
+    loop-stack get length swap loop-heights get set-at ;
+
+M: #recursive collect-loop-info*
+    nip
+    [
+        [
+            label>>
+            [ loop-stack [ swap suffix ] change ]
+            [ remember-loop-info ]
+            [ t >>loop? drop ]
+            tri
+        ]
+        [ t swap child>> (collect-loop-info) ] bi
+    ] with-scope ;
+
+: current-loop-nesting ( label -- labels )
+    loop-stack get swap loop-heights get at tail ;
+
+: disqualify-loop ( label -- )
+    work-list get push-front ;
+
+M: #call-recursive collect-loop-info*
+    label>>
+    swap [ dup disqualify-loop ] unless
+    dup current-loop-nesting [ loop-calls get push-at ] with each ;
+
+M: #if collect-loop-info*
+    children>> [ (collect-loop-info) ] with each ;
+
+M: #dispatch collect-loop-info*
+    children>> [ (collect-loop-info) ] with each ;
+
+M: node collect-loop-info* 2drop ;
+
+: collect-loop-info ( node -- )
+    { } loop-stack set
+    H{ } clone loop-calls set
+    H{ } clone loop-heights set
+    <hashed-dlist> work-list set
+    t swap (collect-loop-info) ;
+
+: disqualify-loops ( -- )
+    work-list get [
+        dup loop?>> [
+            [ f >>loop? drop ]
+            [ loop-calls get at [ disqualify-loop ] each ]
+            bi
+        ] [ drop ] if
+    ] slurp-deque ;
+
+: analyze-recursive ( nodes -- nodes )
+    dup [ collect-label-info ] each-node
+    dup collect-loop-info disqualify-loops ;

diff --git a/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor b/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor
index 858e40347fb1dd7407f368b7ee7ba252f2cfb441..81ba01f1e2b0adb54e70ed0a3b009ff1a18462a6 100644 (file)
--- a/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor
+++ b/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.propagation compiler.tree.cleanup
-compiler.tree.escape-analysis compiler.tree.tuple-unboxing
-compiler.tree.checker compiler.tree.def-use kernel accessors
-sequences math math.private sorting math.order binary-search
-sequences.private slots.private ;
+compiler.tree.builder compiler.tree.recursive
+compiler.tree.normalization compiler.tree.propagation
+compiler.tree.cleanup compiler.tree.escape-analysis
+compiler.tree.tuple-unboxing compiler.tree.checker
+compiler.tree.def-use kernel accessors sequences math
+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

diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor
index 6f255893db088d6dc38d10917df22f1a92bfe49f..67a8ec8a2c4ddeac12f1f50b46253842fdee9d48 100755 (executable)
--- a/basis/cpu/x86/32/32.factor
+++ b/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

diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor
index 1eb4a7896b3fb56cceddd92910a2a848bac05932..4770c09a834f56b71d742ba76e918a7386944a56 100755 (executable)
--- a/basis/cpu/x86/64/64.factor
+++ b/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

diff --git a/basis/cpu/x86/architecture/architecture.factor b/basis/cpu/x86/architecture/architecture.factor
index 13524aecc4084a03490522f734af73436ac51235..171e67bcfbba738c94e8c4cebc1d5123b970d50d 100755 (executable)
--- a/basis/cpu/x86/architecture/architecture.factor
+++ b/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 ( -- )

diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor
index 499267de7c265ff790db4e5d40b57d7427242f9e..1138ad872abbc41ec86ffe1ee7121f1d15a52d32 100644 (file)
--- a/basis/hints/hints.factor
+++ b/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
 

diff --git a/basis/math/partial-dispatch/partial-dispatch.factor b/basis/math/partial-dispatch/partial-dispatch.factor
index 6def4966a28c442239142d24d93b5fdd2de40f3d..b162406e5af6831f9b4be65cd0acdf2b90a8a1d5 100644 (file)
--- a/basis/math/partial-dispatch/partial-dispatch.factor
+++ b/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 ]
-    [ math-ops get (derived-ops) ]
-    bi append ;
+    [ 1array ] [ math-ops get (derived-ops) values ] 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
 

diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor
index dbb24c316818c8b2c7114c9cc1d50ba7d169aa23..6f755e5cb5267c694e222f696c84537e2f65e7e9 100755 (executable)
--- a/core/sequences/sequences.factor
+++ b/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

diff --git a/extra/benchmark/nsieve-bytes/nsieve-bytes.factor b/extra/benchmark/nsieve-bytes/nsieve-bytes.factor
new file mode 100644 (file)
index 0000000..11745e4
--- /dev/null
+++ b/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*

diff --git a/unmaintained/space-invaders/resources/invaders.rom b/unmaintained/space-invaders/resources/invaders.rom
deleted file mode 100644 (file)
index 606ec01..0000000
Binary files a/unmaintained/space-invaders/resources/invaders.rom and /dev/null differ

diff --git a/work/README.txt b/work/README.txt
new file mode 100644 (file)
index 0000000..fd1af07
--- /dev/null
+++ b/work/README.txt
@@ -0,0 +1 @@
+The 'work' directory is for your own personal vocabularies.