basis/compiler/tree/propagation/recursive/recursive.factor

   1 ! Copyright (C) 2008, 2010 Slava Pestov.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors classes.algebra combinators compiler.tree
   4 compiler.tree.combinators compiler.tree.propagation.constraints
   5 compiler.tree.propagation.copy compiler.tree.propagation.info
   6 compiler.tree.propagation.nodes compiler.tree.propagation.simple
   7 kernel locals math math.intervals namespaces sequences ;
   8 FROM: sequences.private => array-capacity ;
   9 IN: compiler.tree.propagation.recursive
  10
  11 : check-fixed-point ( node infos1 infos2 -- )
  12     [ value-info<= ] 2all?
  13     [ drop ] [ label>> f >>fixed-point drop ] if ;
  14
  15 : latest-input-infos ( node -- infos )
  16     in-d>> [ value-info ] map ;
  17
  18 : recursive-stacks ( #enter-recursive -- stacks initial )
  19     [ label>> calls>> [ node>> node-input-infos ] map flip ]
  20     [ latest-input-infos ] bi ;
  21
  22 : counter-class ( interval class -- class' )
  23     dup fixnum class<= rot array-capacity-interval interval-subset? and
  24     [ drop array-capacity ] when ;
  25
  26 :: generalize-counter-interval ( interval initial-interval class -- interval' )
  27     interval class counter-class :> class
  28     {
  29         { [ interval initial-interval interval-subset? ] [ initial-interval ] }
  30         { [ interval empty-interval? ] [ initial-interval ] }
  31         {
  32             [ interval initial-interval interval>= t eq? ]
  33             [ class max-value [a,a] initial-interval interval-union ]
  34         }
  35         {
  36             [ interval initial-interval interval<= t eq? ]
  37             [ class min-value [a,a] initial-interval interval-union ]
  38         }
  39         [ class class-interval ]
  40     } cond ;
  41
  42 : generalize-counter ( info' initial -- info )
  43     2dup [ not ] either? [ drop ] [
  44         2dup [ class>> null-class? ] either? [ drop ] [
  45             [ clone ] dip
  46             [
  47                 [ drop ] [
  48                     [ [ interval>> ] bi@ ] [ drop class>> ] 2bi
  49                     generalize-counter-interval
  50                 ] 2bi >>interval
  51             ]
  52             [ [ drop ] [ [ slots>> ] bi@ [ generalize-counter ] 2map ] 2bi >>slots ]
  53             bi
  54         ] if
  55     ] if ;
  56
  57 : unify-recursive-stacks ( stacks initial -- infos )
  58     over empty? [ nip ] [
  59         [
  60             [ value-infos-union ] dip
  61             [ generalize-counter ] keep
  62             value-info-union
  63         ] 2map
  64     ] if ;
  65
  66 : propagate-recursive-phi ( #enter-recursive -- )
  67     [ recursive-stacks unify-recursive-stacks ] keep
  68     out-d>> set-value-infos ;
  69
  70 M: #recursive propagate-around ( #recursive -- )
  71     constraints [ H{ } clone suffix ] change
  72     [
  73         constraints [ but-last H{ } clone suffix ] change
  74
  75         child>>
  76         [ first compute-copy-equiv ]
  77         [ first propagate-recursive-phi ]
  78         [ (propagate) ]
  79         tri
  80     ] until-fixed-point ;
  81
  82 : recursive-phi-infos ( node -- infos )
  83     label>> enter-recursive>> node-output-infos ;
  84
  85 : generalize-return-interval ( info -- info' )
  86     dup [ literal?>> ] [ class>> null-class? ] bi or
  87     [ clone dup class>> class-interval >>interval ] unless ;
  88
  89 : generalize-return ( infos -- infos' )
  90     [ generalize-return-interval ] map ;
  91
  92 : return-infos ( node -- infos )
  93     label>> return>> node-input-infos generalize-return ;
  94
  95 : save-return-infos ( node infos -- )
  96     swap out-d>> set-value-infos ;
  97
  98 : unless-loop ( node quot -- )
  99     [ dup label>> loop?>> [ drop ] ] dip if ; inline
 100
 101 M: #call-recursive propagate-before ( #call-recursive -- )
 102     [
 103         [ ] [ latest-input-infos ] [ recursive-phi-infos ] tri
 104         check-fixed-point
 105     ]
 106     [
 107         [
 108             [ ] [ return-infos ] [ node-output-infos ] tri
 109             [ check-fixed-point ] [ drop save-return-infos ] 3bi
 110         ] unless-loop
 111     ] bi ;
 112
 113 M: #call-recursive annotate-node
 114     dup [ in-d>> ] [ out-d>> ] bi append (annotate-node) ;
 115
 116 M: #enter-recursive annotate-node
 117     dup out-d>> (annotate-node) ;
 118
 119 M: #return-recursive propagate-before ( #return-recursive -- )
 120     [
 121         [ ] [ latest-input-infos ] [ node-input-infos ] tri
 122         check-fixed-point
 123     ] unless-loop ;
 124
 125 M: #return-recursive annotate-node
 126     dup in-d>> (annotate-node) ;