basis/compiler/tree/normalization/normalization.factor

   1 ! Copyright (C) 2008, 2010 Slava Pestov.
   2 ! See https://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
   9
  10 GENERIC: normalize* ( node -- node' )
  11
  12 SYMBOL: introduction-stack
  13
  14 : pop-introduction ( -- value )
  15     introduction-stack [ unclip-last swap ] change ;
  16
  17 : pop-introductions ( n -- values )
  18     introduction-stack [ swap cut* swap ] change ;
  19
  20 M: #introduce normalize*
  21     out-d>> [ length pop-introductions ] keep add-renamings f ;
  22
  23 SYMBOL: remaining-introductions
  24
  25 M: #branch normalize*
  26     [
  27         [
  28             [
  29                 [ normalize* ] map-flat
  30                 introduction-stack get
  31                 2array
  32             ] with-scope
  33         ] map unzip swap
  34     ] change-children swap
  35     [ remaining-introductions set ]
  36     [ [ length ] [ min ] map-reduce introduction-stack [ swap head ] change ]
  37     bi ;
  38
  39 : eliminate-phi-introductions ( introductions seq terminated -- seq' )
  40     [
  41         [ nip ] [
  42             dup [ +top+ eq? ] trim-head
  43             [ [ length ] bi@ - tail* ] keep append
  44         ] if
  45     ] 3map ;
  46
  47 M: #phi normalize*
  48     remaining-introductions get swap dup terminated>>
  49     '[ _ eliminate-phi-introductions ] change-phi-in-d ;
  50
  51 : (normalize) ( nodes introductions -- nodes )
  52     introduction-stack [
  53         [ normalize* ] map-flat
  54     ] with-variable ;
  55
  56 M: #recursive normalize*
  57     [ [ child>> first ] [ in-d>> ] bi >>in-d drop ]
  58     [ dup label>> introductions>> make-values '[ _ (normalize) ] change-child ]
  59     bi ;
  60
  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 ;
  65
  66 : unchanged-underneath ( #call-recursive -- n )
  67     [ out-d>> length ] [ label>> return>> in-d>> length ] bi - ;
  68
  69 : call<return ( #call-recursive n -- nodes )
  70     neg dup make-values [
  71         [ pop-introductions '[ _ prepend ] change-in-d ]
  72         [ '[ _ prepend ] change-out-d ]
  73         bi*
  74     ] [ introduction-stack [ prepend ] change ] bi ;
  75
  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 ]
  79     2bi ;
  80
  81 M: #call-recursive normalize*
  82     dup unchanged-underneath {
  83         { [ dup 0 < ] [ call<return ] }
  84         { [ dup 0 = ] [ drop ] }
  85         { [ dup 0 > ] [ call>return ] }
  86     } cond ;
  87
  88 M: node normalize* ;
  89
  90 : normalize ( nodes -- nodes' )
  91     [
  92         dup count-introductions make-values
  93         H{ } clone rename-map set
  94         [ (normalize) ] [ nip ] 2bi
  95         [ <#introduce> prefix ] unless-empty
  96         rename-node-values
  97     ] with-scope ;
  98
  99 M: #alien-callback normalize*
 100     [ normalize ] change-child ;