Fold testsuite.git into ghc.git (re #8545)
[ghc.git] / compiler / cmm / Hoopl.hs
1 module Hoopl (
2 module Compiler.Hoopl,
3 module Hoopl.Dataflow,
4 deepFwdRw, deepFwdRw3,
5 deepBwdRw, deepBwdRw3,
6 thenFwdRw
7 ) where
8
9 import Compiler.Hoopl hiding
10 ( (<*>), mkLabel, mkBranch, mkMiddle, mkLast, -- clashes with our MkGraph
11 Unique,
12 FwdTransfer(..), FwdRewrite(..), FwdPass(..),
13 BwdTransfer(..), BwdRewrite(..), BwdPass(..),
14 noFwdRewrite, noBwdRewrite,
15 analyzeAndRewriteFwd, analyzeAndRewriteBwd,
16 mkFactBase, Fact,
17 mkBRewrite, mkBRewrite3, mkBTransfer, mkBTransfer3,
18 mkFRewrite, mkFRewrite3, mkFTransfer, mkFTransfer3,
19 deepFwdRw, deepFwdRw3, thenFwdRw, iterFwdRw,
20 deepBwdRw, deepBwdRw3, thenBwdRw, iterBwdRw
21 )
22
23 import Hoopl.Dataflow
24 import Control.Monad
25 import UniqSupply
26
27 deepFwdRw3 :: (n C O -> f -> UniqSM (Maybe (Graph n C O)))
28 -> (n O O -> f -> UniqSM (Maybe (Graph n O O)))
29 -> (n O C -> f -> UniqSM (Maybe (Graph n O C)))
30 -> (FwdRewrite UniqSM n f)
31 deepFwdRw :: (forall e x . n e x -> f -> UniqSM (Maybe (Graph n e x))) -> FwdRewrite UniqSM n f
32 deepFwdRw3 f m l = iterFwdRw $ mkFRewrite3 f m l
33 deepFwdRw f = deepFwdRw3 f f f
34
35 -- N.B. rw3, rw3', and rw3a are triples of functions.
36 -- But rw and rw' are single functions.
37 thenFwdRw :: forall n f.
38 FwdRewrite UniqSM n f
39 -> FwdRewrite UniqSM n f
40 -> FwdRewrite UniqSM n f
41 thenFwdRw rw3 rw3' = wrapFR2 thenrw rw3 rw3'
42 where
43 thenrw :: forall e x t t1.
44 (t -> t1 -> UniqSM (Maybe (Graph n e x, FwdRewrite UniqSM n f)))
45 -> (t -> t1 -> UniqSM (Maybe (Graph n e x, FwdRewrite UniqSM n f)))
46 -> t
47 -> t1
48 -> UniqSM (Maybe (Graph n e x, FwdRewrite UniqSM n f))
49 thenrw rw rw' n f = rw n f >>= fwdRes
50 where fwdRes Nothing = rw' n f
51 fwdRes (Just gr) = return $ Just $ fadd_rw rw3' gr
52
53 iterFwdRw :: forall n f.
54 FwdRewrite UniqSM n f
55 -> FwdRewrite UniqSM n f
56 iterFwdRw rw3 = wrapFR iter rw3
57 where iter :: forall a e x t.
58 (t -> a -> UniqSM (Maybe (Graph n e x, FwdRewrite UniqSM n f)))
59 -> t
60 -> a
61 -> UniqSM (Maybe (Graph n e x, FwdRewrite UniqSM n f))
62 iter rw n = (liftM $ liftM $ fadd_rw (iterFwdRw rw3)) . rw n
63
64 -- | Function inspired by 'rew' in the paper
65 _frewrite_cps :: ((Graph n e x, FwdRewrite UniqSM n f) -> UniqSM a)
66 -> UniqSM a
67 -> (forall e x . n e x -> f -> UniqSM (Maybe (Graph n e x, FwdRewrite UniqSM n f)))
68 -> n e x
69 -> f
70 -> UniqSM a
71 _frewrite_cps j n rw node f =
72 do mg <- rw node f
73 case mg of Nothing -> n
74 Just gr -> j gr
75
76
77
78 -- | Function inspired by 'add' in the paper
79 fadd_rw :: FwdRewrite UniqSM n f
80 -> (Graph n e x, FwdRewrite UniqSM n f)
81 -> (Graph n e x, FwdRewrite UniqSM n f)
82 fadd_rw rw2 (g, rw1) = (g, rw1 `thenFwdRw` rw2)
83
84
85
86 deepBwdRw3 ::
87 (n C O -> f -> UniqSM (Maybe (Graph n C O)))
88 -> (n O O -> f -> UniqSM (Maybe (Graph n O O)))
89 -> (n O C -> FactBase f -> UniqSM (Maybe (Graph n O C)))
90 -> (BwdRewrite UniqSM n f)
91 deepBwdRw :: (forall e x . n e x -> Fact x f -> UniqSM (Maybe (Graph n e x)))
92 -> BwdRewrite UniqSM n f
93 deepBwdRw3 f m l = iterBwdRw $ mkBRewrite3 f m l
94 deepBwdRw f = deepBwdRw3 f f f
95
96
97 thenBwdRw :: forall n f. BwdRewrite UniqSM n f -> BwdRewrite UniqSM n f -> BwdRewrite UniqSM n f
98 thenBwdRw rw1 rw2 = wrapBR2 f rw1 rw2
99 where f :: forall t t1 t2 e x.
100 t
101 -> (t1 -> t2 -> UniqSM (Maybe (Graph n e x, BwdRewrite UniqSM n f)))
102 -> (t1 -> t2 -> UniqSM (Maybe (Graph n e x, BwdRewrite UniqSM n f)))
103 -> t1
104 -> t2
105 -> UniqSM (Maybe (Graph n e x, BwdRewrite UniqSM n f))
106 f _ rw1 rw2' n f = do
107 res1 <- rw1 n f
108 case res1 of
109 Nothing -> rw2' n f
110 Just gr -> return $ Just $ badd_rw rw2 gr
111
112 iterBwdRw :: forall n f. BwdRewrite UniqSM n f -> BwdRewrite UniqSM n f
113 iterBwdRw rw = wrapBR f rw
114 where f :: forall t e x t1 t2.
115 t
116 -> (t1 -> t2 -> UniqSM (Maybe (Graph n e x, BwdRewrite UniqSM n f)))
117 -> t1
118 -> t2
119 -> UniqSM (Maybe (Graph n e x, BwdRewrite UniqSM n f))
120 f _ rw' n f = liftM (liftM (badd_rw (iterBwdRw rw))) (rw' n f)
121
122 -- | Function inspired by 'add' in the paper
123 badd_rw :: BwdRewrite UniqSM n f
124 -> (Graph n e x, BwdRewrite UniqSM n f)
125 -> (Graph n e x, BwdRewrite UniqSM n f)
126 badd_rw rw2 (g, rw1) = (g, rw1 `thenBwdRw` rw2)