Hoopl.hs 4.5 KB
Newer Older
Simon Marlow's avatar
Simon Marlow committed
1 2 3
module Hoopl (
    module Compiler.Hoopl,
    module Hoopl.Dataflow,
4 5
    deepFwdRw, deepFwdRw3,
    deepBwdRw, deepBwdRw3,
Simon Marlow's avatar
Simon Marlow committed
6 7 8 9
    thenFwdRw
  ) where

import Compiler.Hoopl hiding
10 11
  ( (<*>), mkLabel, mkBranch, mkMiddle, mkLast, -- clashes with our MkGraph
    Unique,
Simon Marlow's avatar
Simon Marlow committed
12 13 14
    FwdTransfer(..), FwdRewrite(..), FwdPass(..),
    BwdTransfer(..), BwdRewrite(..), BwdPass(..),
    noFwdRewrite, noBwdRewrite,
15
    analyzeAndRewriteFwd, analyzeAndRewriteBwd,
Simon Marlow's avatar
Simon Marlow committed
16 17 18 19 20 21 22 23 24
    mkFactBase, Fact,
    mkBRewrite, mkBRewrite3, mkBTransfer, mkBTransfer3,
    mkFRewrite, mkFRewrite3, mkFTransfer, mkFTransfer3,
    deepFwdRw, deepFwdRw3, thenFwdRw, iterFwdRw,
    deepBwdRw, deepBwdRw3, thenBwdRw, iterBwdRw
  )

import Hoopl.Dataflow
import Control.Monad
25
import UniqSupply
Simon Marlow's avatar
Simon Marlow committed
26

27 28 29 30 31
deepFwdRw3 :: (n C O -> f -> UniqSM (Maybe (Graph n C O)))
           -> (n O O -> f -> UniqSM (Maybe (Graph n O O)))
           -> (n O C -> f -> UniqSM (Maybe (Graph n O C)))
           -> (FwdRewrite UniqSM n f)
deepFwdRw :: (forall e x . n e x -> f -> UniqSM (Maybe (Graph n e x))) -> FwdRewrite UniqSM n f
Simon Marlow's avatar
Simon Marlow committed
32 33 34 35 36 37
deepFwdRw3 f m l = iterFwdRw $ mkFRewrite3 f m l
deepFwdRw f = deepFwdRw3 f f f

-- N.B. rw3, rw3', and rw3a are triples of functions.
-- But rw and rw' are single functions.
thenFwdRw :: forall n f.
38 39 40
             FwdRewrite UniqSM n f
          -> FwdRewrite UniqSM n f 
          -> FwdRewrite UniqSM n f
Simon Marlow's avatar
Simon Marlow committed
41 42 43
thenFwdRw rw3 rw3' = wrapFR2 thenrw rw3 rw3'
 where
  thenrw :: forall e x t t1.
44 45
               (t -> t1 -> UniqSM (Maybe (Graph n e x, FwdRewrite UniqSM n f)))
            -> (t -> t1 -> UniqSM (Maybe (Graph n e x, FwdRewrite UniqSM n f)))
Simon Marlow's avatar
Simon Marlow committed
46 47
            -> t
            -> t1
48
            -> UniqSM (Maybe (Graph n e x, FwdRewrite UniqSM n f))
Simon Marlow's avatar
Simon Marlow committed
49 50 51 52
  thenrw rw rw' n f = rw n f >>= fwdRes
     where fwdRes Nothing   = rw' n f
           fwdRes (Just gr) = return $ Just $ fadd_rw rw3' gr

53 54 55
iterFwdRw :: forall n f.
             FwdRewrite UniqSM n f
          -> FwdRewrite UniqSM n f
Simon Marlow's avatar
Simon Marlow committed
56 57
iterFwdRw rw3 = wrapFR iter rw3
 where iter :: forall a e x t.
58
               (t -> a -> UniqSM (Maybe (Graph n e x, FwdRewrite UniqSM n f)))
Simon Marlow's avatar
Simon Marlow committed
59 60
               -> t
               -> a
61
               -> UniqSM (Maybe (Graph n e x, FwdRewrite UniqSM n f))
Simon Marlow's avatar
Simon Marlow committed
62 63 64
       iter rw n = (liftM $ liftM $ fadd_rw (iterFwdRw rw3)) . rw n

-- | Function inspired by 'rew' in the paper
65 66 67
_frewrite_cps :: ((Graph n e x, FwdRewrite UniqSM n f) -> UniqSM a)
             -> UniqSM a
             -> (forall e x . n e x -> f -> UniqSM (Maybe (Graph n e x, FwdRewrite UniqSM n f)))
Simon Marlow's avatar
Simon Marlow committed
68 69
             -> n e x
             -> f
70
             -> UniqSM a
Simon Marlow's avatar
Simon Marlow committed
71 72 73 74 75 76 77 78
_frewrite_cps j n rw node f =
    do mg <- rw node f
       case mg of Nothing -> n
                  Just gr -> j gr



-- | Function inspired by 'add' in the paper
79 80 81
fadd_rw :: FwdRewrite UniqSM n f
        -> (Graph n e x, FwdRewrite UniqSM n f)
        -> (Graph n e x, FwdRewrite UniqSM n f)
Simon Marlow's avatar
Simon Marlow committed
82 83 84 85 86
fadd_rw rw2 (g, rw1) = (g, rw1 `thenFwdRw` rw2)



deepBwdRw3 ::
87 88 89 90 91 92
              (n C O -> f          -> UniqSM (Maybe (Graph n C O)))
           -> (n O O -> f          -> UniqSM (Maybe (Graph n O O)))
           -> (n O C -> FactBase f -> UniqSM (Maybe (Graph n O C)))
           -> (BwdRewrite UniqSM n f)
deepBwdRw  :: (forall e x . n e x -> Fact x f -> UniqSM (Maybe (Graph n e x)))
           -> BwdRewrite UniqSM n f
Simon Marlow's avatar
Simon Marlow committed
93 94 95 96
deepBwdRw3 f m l = iterBwdRw $ mkBRewrite3 f m l
deepBwdRw  f = deepBwdRw3 f f f


97
thenBwdRw :: forall n f. BwdRewrite UniqSM n f -> BwdRewrite UniqSM n f -> BwdRewrite UniqSM n f
Simon Marlow's avatar
Simon Marlow committed
98 99 100
thenBwdRw rw1 rw2 = wrapBR2 f rw1 rw2
  where f :: forall t t1 t2 e x.
             t
101 102
             -> (t1 -> t2 -> UniqSM (Maybe (Graph n e x, BwdRewrite UniqSM n f)))
             -> (t1 -> t2 -> UniqSM (Maybe (Graph n e x, BwdRewrite UniqSM n f)))
Simon Marlow's avatar
Simon Marlow committed
103 104
             -> t1
             -> t2
105
             -> UniqSM (Maybe (Graph n e x, BwdRewrite UniqSM n f))
Simon Marlow's avatar
Simon Marlow committed
106 107 108 109 110 111
        f _ rw1 rw2' n f = do
          res1 <- rw1 n f
          case res1 of
            Nothing -> rw2' n f
            Just gr -> return $ Just $ badd_rw rw2 gr

112
iterBwdRw :: forall n f. BwdRewrite UniqSM n f -> BwdRewrite UniqSM n f
Simon Marlow's avatar
Simon Marlow committed
113 114 115
iterBwdRw rw = wrapBR f rw
  where f :: forall t e x t1 t2.
             t
116
             -> (t1 -> t2 -> UniqSM (Maybe (Graph n e x, BwdRewrite UniqSM n f)))
Simon Marlow's avatar
Simon Marlow committed
117 118
             -> t1
             -> t2
119
             -> UniqSM (Maybe (Graph n e x, BwdRewrite UniqSM n f))
Simon Marlow's avatar
Simon Marlow committed
120 121 122
        f _ rw' n f = liftM (liftM (badd_rw (iterBwdRw rw))) (rw' n f)

-- | Function inspired by 'add' in the paper
123 124 125
badd_rw :: BwdRewrite UniqSM n f
        -> (Graph n e x, BwdRewrite UniqSM n f)
        -> (Graph n e x, BwdRewrite UniqSM n f)
Simon Marlow's avatar
Simon Marlow committed
126
badd_rw rw2 (g, rw1) = (g, rw1 `thenBwdRw` rw2)