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

basis/math/constants/constants.factor

@@ -1,5 +1,6 @@
-! Copyright (C) 2004, 2005 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
+USE: math
 IN: math.constants
 
 : e ( -- e ) 2.7182818284590452354 ; inline
@@ -7,3 +8,5 @@ IN: math.constants
 : phi ( -- phi ) 1.61803398874989484820 ; inline
 : pi ( -- pi ) 3.14159265358979323846 ; inline
 : epsilon ( -- epsilon ) 2.2204460492503131e-16 ; inline
+: smallest-float ( -- x ) HEX: 1 bits>double ; foldable
+: largest-float ( -- x ) HEX: 7fefffffffffffff bits>double ; foldable

unfinished/compiler/tree/loop/detection/detection-tests.factor

@@ -0,0 +1,150 @@
+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

unfinished/compiler/tree/loop/detection/detection.factor

@@ -1,5 +1,103 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-IN: compiler.tree.loop-detection
+USING: kernel sequences namespaces assocs accessors fry
+compiler.tree ;
+IN: compiler.tree.loop.detection
 
-: detect-loops ( nodes -- nodes' ) ;
+! A loop is a #recursive which only tail calls itself, and those
+! calls are nested inside other loops only.
+
+TUPLE: recursive-call tail? nesting ;
+
+! calls is a sequence of recursive-call instances
+TUPLE: loop-info calls height ;
+
+! Mapping inline-recursive instances to loop-info instances
+SYMBOL: loop-infos
+
+! A sequence of inline-recursive instances
+SYMBOL: label-stack
+
+: (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) ;
+
+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 ( #recursive -- )
+    V{ } clone label-stack get length loop-info boa
+    swap label>> loop-infos get set-at ;
+
+M: #recursive collect-loop-info*
+    nip
+    [
+        [ label-stack [ swap label>> suffix ] change ]
+        [ remember-loop-info ]
+        [ t swap child>> (collect-loop-info) ]
+        tri
+    ] with-scope ;
+
+M: #call-recursive collect-loop-info*
+    label>> loop-infos get at
+    [ label-stack get swap height>> tail recursive-call boa ]
+    [ calls>> ]
+    bi push ;
+
+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 -- )
+    { } label-stack set
+    H{ } clone loop-infos set
+    t swap (collect-loop-info) ;
+
+! Sub-assoc of loop-infos
+SYMBOL: potential-loops
+
+: remove-non-tail-calls ( -- )
+    loop-infos get
+    [ nip calls>> [ tail?>> ] all? ] assoc-filter
+    potential-loops set ;
+
+: (remove-non-loop-calls) ( loop-infos -- )
+    f over [
+        ! If label X is called from within a label Y that is
+        ! no longer a potential loop, then X is no longer a
+        ! potential loop either.
+        over potential-loops get key? [
+            potential-loops get '[ , key? ] all?
+            [ drop ] [ potential-loops get delete-at t or ] if
+        ] [ 2drop ] if
+    ] assoc-each
+    [ (remove-non-loop-calls) ] [ drop ] if ;
+
+: remove-non-loop-calls ( -- )
+    ! Boolean is set to t if something changed.
+    !  We recurse until a fixed point is reached.
+    loop-infos get [ calls>> [ nesting>> ] map concat ] assoc-map
+    (remove-non-loop-calls) ;
+
+: detect-loops ( nodes -- nodes )
+    dup
+    collect-loop-info
+    remove-non-tail-calls
+    remove-non-loop-calls
+    potential-loops get [ drop t >>loop? drop ] assoc-each ;

unfinished/stack-checker/inlining/inlining.factor

@@ -17,15 +17,21 @@ IN: stack-checker.inlining
 : (inline-word) ( word label -- )
     [ [ def>> ] keep ] dip infer-quot-recursive ;
 
-TUPLE: inline-recursive
+TUPLE: inline-recursive < identity-tuple
+id
 word
 enter-out enter-recursive
 return calls
 fixed-point
-introductions ;
+introductions
+loop? ;
+
+M: inline-recursive hashcode* id>> hashcode* ;
 
 : <inline-recursive> ( word -- label )
-    inline-recursive new swap >>word ;
+    inline-recursive new
+        gensym >>id
+        swap >>word ;
 
 : quotation-param? ( obj -- ? )
     dup pair? [ second effect? ] [ drop f ] if ;