1 ! Copyright (C) 2008, 2010 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs combinators compiler.tree
4 compiler.tree.normalization.introductions
5 compiler.tree.normalization.renaming compiler.utilities fry
6 kernel math math.order namespaces sequences
7 stack-checker.backend stack-checker.branches ;
8 IN: compiler.tree.normalization
10 GENERIC: normalize* ( node -- node' )
12 SYMBOL: introduction-stack
14 : pop-introduction ( -- value )
15 introduction-stack [ unclip-last swap ] change ;
17 : pop-introductions ( n -- values )
18 introduction-stack [ swap cut* swap ] change ;
20 M: #introduce normalize*
21 out-d>> [ length pop-introductions ] keep add-renamings f ;
23 SYMBOL: remaining-introductions
29 [ normalize* ] map-flat
30 introduction-stack get
34 ] change-children swap
35 [ remaining-introductions set ]
36 [ [ length ] [ min ] map-reduce introduction-stack [ swap head ] change ]
39 : eliminate-phi-introductions ( introductions seq terminated -- seq' )
42 dup [ +top+ eq? ] trim-head
43 [ [ length ] bi@ - tail* ] keep append
48 remaining-introductions get swap dup terminated>>
49 '[ _ eliminate-phi-introductions ] change-phi-in-d ;
51 : (normalize) ( nodes introductions -- nodes )
53 [ normalize* ] map-flat
56 M: #recursive normalize*
57 [ [ child>> first ] [ in-d>> ] bi >>in-d drop ]
58 [ dup label>> introductions>> make-values '[ _ (normalize) ] change-child ]
61 M: #enter-recursive normalize*
62 [ introduction-stack get prepend ] change-out-d
63 dup [ label>> ] keep >>enter-recursive drop
64 dup [ label>> ] [ out-d>> ] bi >>enter-out drop ;
66 : unchanged-underneath ( #call-recursive -- n )
67 [ out-d>> length ] [ label>> return>> in-d>> length ] bi - ;
69 : call<return ( #call-recursive n -- nodes )
71 [ pop-introductions '[ _ prepend ] change-in-d ]
72 [ '[ _ prepend ] change-out-d ]
74 ] [ introduction-stack [ prepend ] change ] bi ;
76 : call>return ( #call-recursive n -- #call-recursive )
77 [ [ [ in-d>> ] [ out-d>> ] bi ] [ '[ _ head ] ] bi* bi@ add-renamings ]
78 [ '[ _ tail ] [ change-in-d ] [ change-out-d ] bi ]
81 M: #call-recursive normalize*
82 dup unchanged-underneath {
83 { [ dup 0 < ] [ call<return ] }
84 { [ dup 0 = ] [ drop ] }
85 { [ dup 0 > ] [ call>return ] }
90 : normalize ( nodes -- nodes' )
92 dup count-introductions make-values
93 H{ } clone rename-map set
94 [ (normalize) ] [ nip ] 2bi
95 [ <#introduce> prefix ] unless-empty
99 M: #alien-callback normalize*
100 [ normalize ] change-child ;