basis/compiler/tree/normalization/normalization.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: fry namespaces sequences math math.order accessors kernel arrays
   4 combinators assocs
   5 stack-checker.backend
   6 stack-checker.branches
   7 stack-checker.inlining
   8 compiler.utilities
   9 compiler.tree
  10 compiler.tree.combinators
  11 compiler.tree.normalization.introductions
  12 compiler.tree.normalization.renaming ;
  13 IN: compiler.tree.normalization
  14
  15 ! A transform pass done before optimization can begin to
  16 ! fix up some oddities in the tree output by the stack checker:
  17 !
  18 ! - We rewrite the code so that all #introduce nodes are
  19 ! replaced with a single one, at the beginning of a program.
  20 ! This simplifies subsequent analysis.
  21 !
  22 ! - We normalize #call-recursive as follows. The stack checker
  23 ! says that the inputs of a #call-recursive are the entire stack
  24 ! at the time of the call. This is a conservative estimate; we
  25 ! don't know the exact number of stack values it touches until
  26 ! the #return-recursive node has been visited, because of row
  27 ! polymorphism. So in the normalize pass, we split a
  28 ! #call-recursive into a #copy of the unchanged values and a
  29 ! #call-recursive with trimmed inputs and outputs.
  30
  31 GENERIC: normalize* ( node -- node' )
  32
  33 SYMBOL: introduction-stack
  34
  35 : pop-introduction ( -- value )
  36     introduction-stack [ unclip-last swap ] change ;
  37
  38 : pop-introductions ( n -- values )
  39     introduction-stack [ swap cut* swap ] change ;
  40
  41 M: #introduce normalize*
  42     out-d>> [ length pop-introductions ] keep add-renamings f ;
  43
  44 SYMBOL: remaining-introductions
  45
  46 M: #branch normalize*
  47     [
  48         [
  49             [
  50                 [ normalize* ] map-flat
  51                 introduction-stack get
  52                 2array
  53             ] with-scope
  54         ] map unzip swap
  55     ] change-children swap
  56     [ remaining-introductions set ]
  57     [ [ length ] [ min ] map-reduce introduction-stack [ swap head ] change ]
  58     bi ;
  59
  60 : eliminate-phi-introductions ( introductions seq terminated -- seq' )
  61     [
  62         [ nip ] [
  63             dup [ +bottom+ eq? ] trim-head
  64             [ [ length ] bi@ - tail* ] keep append
  65         ] if
  66     ] 3map ;
  67
  68 M: #phi normalize*
  69     remaining-introductions get swap dup terminated>>
  70     '[ _ eliminate-phi-introductions ] change-phi-in-d ;
  71
  72 : (normalize) ( nodes introductions -- nodes )
  73     introduction-stack [
  74         [ normalize* ] map-flat
  75     ] with-variable ;
  76
  77 M: #recursive normalize*
  78     dup label>> introductions>>
  79     [ drop [ child>> first ] [ in-d>> ] bi >>in-d drop ]
  80     [ make-values '[ _ (normalize) ] change-child ]
  81     2bi ;
  82
  83 M: #enter-recursive normalize*
  84     [ introduction-stack get prepend ] change-out-d
  85     dup [ label>> ] keep >>enter-recursive drop
  86     dup [ label>> ] [ out-d>> ] bi >>enter-out drop ;
  87
  88 : unchanged-underneath ( #call-recursive -- n )
  89     [ out-d>> length ] [ label>> return>> in-d>> length ] bi - ;
  90
  91 : call<return ( #call-recursive n -- nodes )
  92     neg dup make-values [
  93         [ pop-introductions '[ _ prepend ] change-in-d ]
  94         [ '[ _ prepend ] change-out-d ]
  95         bi*
  96     ] [ introduction-stack [ prepend ] change ] bi ;
  97
  98 : call>return ( #call-recursive n -- #call-recursive )
  99     [ [ [ in-d>> ] [ out-d>> ] bi ] [ '[ _ head ] ] bi* bi@ add-renamings ]
 100     [ '[ _ tail ] [ change-in-d ] [ change-out-d ] bi ]
 101     2bi ;
 102
 103 M: #call-recursive normalize*
 104     dup unchanged-underneath {
 105         { [ dup 0 < ] [ call<return ] }
 106         { [ dup 0 = ] [ drop ] }
 107         { [ dup 0 > ] [ call>return ] }
 108     } cond ;
 109
 110 M: node normalize* ;
 111
 112 : normalize ( nodes -- nodes' )
 113     dup count-introductions make-values
 114     H{ } clone rename-map set
 115     [ (normalize) ] [ nip ] 2bi
 116     [ #introduce prefix ] unless-empty
 117     rename-node-values ;