src/Compiler/Hoopl/Combinators.hs

   1 {-# LANGUAGE RankNTypes, LiberalTypeSynonyms, ScopedTypeVariables #-}
   2
   3 module Compiler.Hoopl.Combinators
   4   ( SimpleFwdRewrite, noFwdRewrite, thenFwdRw
   5   , shallowFwdRw, shallowFwdRw', deepFwdRw, deepFwdRw', iterFwdRw
   6   , SimpleBwdRewrite, SimpleBwdRewrite', noBwdRewrite, thenBwdRw
   7   , shallowBwdRw, shallowBwdRw', deepBwdRw, deepBwdRw', iterBwdRw
   8   , noRewritePoly
   9   , productFwd, productBwd
  10   )
  11
  12 where
  13
  14 import Data.Function
  15 import Data.Maybe
  16
  17 import Compiler.Hoopl.Collections
  18 import Compiler.Hoopl.Dataflow
  19 import Compiler.Hoopl.Graph (C, O)
  20 import Compiler.Hoopl.Label
  21 import Compiler.Hoopl.MkGraph
  22
  23 type FR m n f = FwdRewrite m n f
  24 type BR m n f = BwdRewrite m n f
  25
  26 type SFRW m n f e x = n e x -> f -> Maybe (AGraph m n e x)
  27 type FRW  m n f e x = n e x -> f -> Maybe (FwdRes m n f e x)
  28 type SimpleFwdRewrite  m n f = ExTriple (SFRW m n f)
  29 type ExTriple a = (a C O, a O O, a O C) -- ^ entry/exit triple
  30 type SimpleFwdRewrite' m n f = forall e x . SFRW m n f e x
  31 type LiftFRW m n f e x = SFRW m n f e x -> FRW m n f e x
  32 type MapFRW  m n f e x = FRW  m n f e x -> FRW m n f e x
  33 type MapFRW2 m n f e x = FRW  m n f e x -> FRW m n f e x -> FRW m n f e x
  34
  35 ----------------------------------------------------------------
  36 -- common operations on triples
  37
  38 uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
  39 uncurry3 f (a, b, c) = f a b c
  40
  41 apply :: (a -> b, d -> e, g -> h) -> (a, d, g) -> (b, e, h)
  42 apply (f1, f2, f3) (x1, x2, x3) = (f1 x1, f2 x2, f3 x3)
  43
  44 applyBinary :: (a -> b -> c, d -> e -> f, g -> h -> i)
  45             -> (a, d, g) -> (b, e, h) -> (c, f, i)
  46 applyBinary (f1, f2, f3) (x1, x2, x3) (y1, y2, y3) = (f1 x1 y1, f2 x2 y2, f3 x3 y3)
  47
  48
  49 ----------------------------------------------------------------
  50
  51 wrapSFRewrites :: ExTriple (LiftFRW m n f) -> SimpleFwdRewrite m n f -> FR m n f
  52 wrapSFRewrites lift rw = uncurry3 mkFRewrite $ apply lift rw
  53
  54 wrapFRewrites :: ExTriple (MapFRW m n f) -> FR m n f -> FR m n f
  55 wrapFRewrites map frw = uncurry3 mkFRewrite $ apply map $ getFRewrites frw
  56
  57 wrapFRewrites2 :: ExTriple (MapFRW2 m n f) -> FR m n f -> FR m n f -> FR m n f
  58 wrapFRewrites2 map frw1 frw2 =
  59   uncurry3 mkFRewrite $ (applyBinary map `on` getFRewrites) frw1 frw2
  60
  61
  62 -- Combinators for higher-rank rewriting functions:
  63 wrapSFRewrites' :: (forall e x . LiftFRW m n f e x) -> SimpleFwdRewrite m n f -> FR m n f
  64 wrapSFRewrites' lift = wrapSFRewrites (lift, lift, lift)
  65
  66 wrapFRewrites' :: (forall e x . MapFRW m n f e x) -> FR m n f -> FR m n f
  67 wrapFRewrites' map = wrapFRewrites (map, map, map)
  68
  69 wrapFRewrites2' :: (forall e x . MapFRW2 m n f e x) -> FR m n f -> FR m n f -> FR m n f
  70 wrapFRewrites2' map = wrapFRewrites2 (map, map, map)
  71
  72 ----------------------------------------------------------------
  73
  74 noFwdRewrite :: FwdRewrite m n f
  75 noFwdRewrite = mkFRewrite' noRewritePoly
  76
  77 noRewritePoly :: a -> b -> Maybe c
  78 noRewritePoly _ _ = Nothing
  79
  80 shallowFwdRw :: forall m n f . SimpleFwdRewrite m n f -> FwdRewrite m n f
  81 shallowFwdRw rw = wrapSFRewrites' lift rw
  82   where lift rw n f = fmap withoutRewrite (rw n f)
  83         withoutRewrite ag = FwdRes ag noFwdRewrite
  84
  85 shallowFwdRw' :: SimpleFwdRewrite' m n f -> FwdRewrite m n f
  86 shallowFwdRw' f = shallowFwdRw (f, f, f)
  87
  88 deepFwdRw  :: SimpleFwdRewrite  m n f -> FwdRewrite m n f
  89 deepFwdRw' :: SimpleFwdRewrite' m n f -> FwdRewrite m n f
  90 deepFwdRw  r = iterFwdRw (shallowFwdRw r)
  91 deepFwdRw' f = deepFwdRw (f, f, f)
  92
  93 thenFwdRw :: FwdRewrite m n f -> FwdRewrite m n f -> FwdRewrite m n f
  94 thenFwdRw rw1 rw2 = wrapFRewrites2' f rw1 rw2
  95   where f rw1 rw2' n f =
  96           case rw1 n f of
  97             Nothing               -> rw2' n f
  98             Just (FwdRes ag rw1a) -> Just (FwdRes ag (rw1a `thenFwdRw` rw2))
  99
 100 iterFwdRw :: FwdRewrite m n f -> FwdRewrite m n f
 101 iterFwdRw rw = wrapFRewrites' f rw
 102   where f rw' n f =
 103           case rw' n f of
 104             Just (FwdRes g rw2) -> Just $ FwdRes g (rw2 `thenFwdRw` iterFwdRw rw)
 105             Nothing             -> Nothing
 106
 107 ----------------------------------------------------------------
 108
 109 type SBRW m n f e x = n e x -> Fact x f -> Maybe (AGraph m n e x)
 110 type BRW  m n f e x = n e x -> Fact x f -> Maybe (BwdRes m n f e x)
 111 type SimpleBwdRewrite  m n f = ExTriple ( SBRW m n f)
 112 type SimpleBwdRewrite' m n f = forall e x . SBRW m n f e x
 113 type LiftBRW m n f e x = SBRW m n f e x -> BRW m n f e x
 114 type MapBRW  m n f e x = BRW  m n f e x -> BRW m n f e x
 115 type MapBRW2 m n f e x = BRW  m n f e x -> BRW m n f e x -> BRW m n f e x
 116
 117 ----------------------------------------------------------------
 118
 119 wrapSBRewrites :: ExTriple (LiftBRW m n f) -> SimpleBwdRewrite m n f -> BwdRewrite m n f
 120 wrapSBRewrites lift rw = uncurry3 mkBRewrite $ apply lift rw
 121
 122 wrapBRewrites :: ExTriple (MapBRW m n f) -> BwdRewrite m n f -> BwdRewrite m n f
 123 wrapBRewrites map rw = uncurry3 mkBRewrite $ apply map $ getBRewrites rw
 124
 125 wrapBRewrites2 :: ExTriple (MapBRW2 m n f) -> BR m n f -> BR m n f -> BR m n f
 126 wrapBRewrites2 map rw1 rw2 =
 127   uncurry3 mkBRewrite $ (applyBinary map `on` getBRewrites) rw1 rw2
 128
 129 -- Combinators for higher-rank rewriting functions:
 130 wrapSBRewrites' :: (forall e x . LiftBRW m n f e x) -> SimpleBwdRewrite m n f -> BR m n f
 131 wrapSBRewrites' lift = wrapSBRewrites (lift, lift, lift)
 132
 133 wrapBRewrites' :: (forall e x . MapBRW m n f e x) -> BwdRewrite m n f -> BwdRewrite m n f
 134 wrapBRewrites' map = wrapBRewrites (map, map, map)
 135
 136 wrapBRewrites2' :: (forall e x . MapBRW2 m n f e x) -> BR m n f -> BR m n f -> BR m n f
 137 wrapBRewrites2' map = wrapBRewrites2 (map, map, map)
 138
 139 ----------------------------------------------------------------
 140
 141 noBwdRewrite :: BwdRewrite m n f
 142 noBwdRewrite = mkBRewrite' $ \ _ _ -> Nothing
 143
 144 shallowBwdRw :: SimpleBwdRewrite m n f -> BwdRewrite m n f
 145 shallowBwdRw rw = wrapSBRewrites' lift rw
 146   where lift rw n f = fmap withoutRewrite (rw n f)
 147         withoutRewrite ag = BwdRes ag noBwdRewrite
 148
 149 shallowBwdRw' :: SimpleBwdRewrite' m n f -> BwdRewrite m n f
 150 shallowBwdRw' f = shallowBwdRw (f, f, f)
 151
 152 deepBwdRw  :: SimpleBwdRewrite  m n f -> BwdRewrite m n f
 153 deepBwdRw' :: SimpleBwdRewrite' m n f -> BwdRewrite m n f
 154 deepBwdRw  r = iterBwdRw (shallowBwdRw r)
 155 deepBwdRw' f = deepBwdRw (f, f, f)
 156
 157
 158 thenBwdRw :: BwdRewrite m n f -> BwdRewrite m n f -> BwdRewrite m n f
 159 thenBwdRw rw1 rw2 = wrapBRewrites2' f rw1 rw2
 160   where f rw1 rw2' n f =
 161           case rw1 n f of
 162             Nothing               -> rw2' n f
 163             Just (BwdRes ag rw1a) -> Just (BwdRes ag (rw1a `thenBwdRw` rw2))
 164
 165 iterBwdRw :: BwdRewrite m n f -> BwdRewrite m n f
 166 iterBwdRw rw = wrapBRewrites' f rw
 167   where f rw' n f =
 168           case rw' n f of
 169             Just (BwdRes g rw2) -> Just $ BwdRes g (rw2 `thenBwdRw` iterBwdRw rw)
 170             Nothing             -> Nothing
 171
 172 productFwd :: forall m n f f' . FwdPass m n f -> FwdPass m n f' -> FwdPass m n (f, f')
 173 productFwd pass1 pass2 = FwdPass lattice transfer rewrite
 174   where
 175     lattice = productLattice (fp_lattice pass1) (fp_lattice pass2)
 176     transfer = mkFTransfer (tf tf1 tf2) (tf tm1 tm2) (tfb tl1 tl2)
 177       where
 178         tf  t1 t2 n (f1, f2) = (t1 n f1, t2 n f2)
 179         tfb t1 t2 n (f1, f2) = mapWithKeyMap withfb2 fb1
 180           where fb1 = t1 n f1
 181                 fb2 = t2 n f2
 182                 withfb2 l f = (f, fromMaybe bot2 $ lookupFact l fb2)
 183                 bot2 = fact_bot (fp_lattice pass2)
 184         (tf1, tm1, tl1) = getFTransfers (fp_transfer pass1)
 185         (tf2, tm2, tl2) = getFTransfers (fp_transfer pass2)
 186     rewrite = liftRW (fp_rewrite pass1) fst `thenFwdRw` liftRW (fp_rewrite pass2) snd
 187       where
 188         liftRW rws proj = mkFRewrite (lift f) (lift m) (lift l)
 189           where lift rw n f = case rw n (proj f) of
 190                                 Just (FwdRes g rws') -> Just (FwdRes g $ liftRW rws' proj)
 191                                 Nothing              -> Nothing
 192                 (f, m, l) = getFRewrites rws
 193
 194 productBwd :: forall m n f f' . BwdPass m n f -> BwdPass m n f' -> BwdPass m n (f, f')
 195 productBwd pass1 pass2 = BwdPass lattice transfer rewrite
 196   where
 197     lattice = productLattice (bp_lattice pass1) (bp_lattice pass2)
 198     transfer = mkBTransfer (tf tf1 tf2) (tf tm1 tm2) (tfb tl1 tl2)
 199       where
 200         tf  t1 t2 n (f1, f2) = (t1 n f1, t2 n f2)
 201         tfb t1 t2 n fb = (t1 n $ mapMap fst fb, t2 n $ mapMap snd fb)
 202         (tf1, tm1, tl1) = getBTransfers (bp_transfer pass1)
 203         (tf2, tm2, tl2) = getBTransfers (bp_transfer pass2)
 204     rewrite = liftRW (bp_rewrite pass1) fst `thenBwdRw` liftRW (bp_rewrite pass2) snd
 205       where
 206         liftRW :: forall f1 . BwdRewrite m n f1 -> ((f, f') -> f1) -> BwdRewrite m n (f, f')
 207         liftRW rws proj = mkBRewrite (lift proj f) (lift proj m) (lift (mapMap proj) l)
 208           where
 209             lift proj' rw n f =
 210               case rw n (proj' f) of
 211                 Just (BwdRes g rws') -> Just (BwdRes g $ liftRW rws' proj)
 212                 Nothing              -> Nothing
 213             (f, m, l) = getBRewrites rws
 214
 215 productLattice :: forall f f' . DataflowLattice f -> DataflowLattice f' -> DataflowLattice (f, f')
 216 productLattice l1 l2 =
 217   DataflowLattice
 218     { fact_name       = fact_name l1 ++ " x " ++ fact_name l2
 219     , fact_bot        = (fact_bot l1, fact_bot l2)
 220     , fact_extend     = extend'
 221     , fact_do_logging = fact_do_logging l1 || fact_do_logging l2
 222     }
 223   where
 224     extend' lbl (OldFact (o1, o2)) (NewFact (n1, n2)) = (c', (f1, f2))
 225       where (c1, f1) = fact_extend l1 lbl (OldFact o1) (NewFact n1)
 226             (c2, f2) = fact_extend l2 lbl (OldFact o2) (NewFact n2)
 227             c' = case (c1, c2) of
 228                    (NoChange, NoChange) -> NoChange
 229                    _                    -> SomeChange