Fix #11407.
[ghc.git] / compiler / cmm / Hoopl.hs
1 {-# LANGUAGE RankNTypes, ScopedTypeVariables #-}
2
3 module Hoopl (
4 module Compiler.Hoopl,
5 module Hoopl.Dataflow,
6 deepFwdRw, deepFwdRw3,
7 deepBwdRw, deepBwdRw3,
8 thenFwdRw
9 ) where
10
11 import Compiler.Hoopl hiding
12 ( (<*>), mkLabel, mkBranch, mkMiddle, mkLast, -- clashes with our MkGraph
13 Unique,
14 FwdTransfer(..), FwdRewrite(..), FwdPass(..),
15 BwdTransfer(..), BwdRewrite(..), BwdPass(..),
16 noFwdRewrite, noBwdRewrite,
17 analyzeAndRewriteFwd, analyzeAndRewriteBwd,
18 mkFactBase, Fact,
19 mkBRewrite, mkBRewrite3, mkBTransfer, mkBTransfer3,
20 mkFRewrite, mkFRewrite3, mkFTransfer, mkFTransfer3,
21 deepFwdRw, deepFwdRw3, thenFwdRw, iterFwdRw,
22 deepBwdRw, deepBwdRw3, thenBwdRw, iterBwdRw
23 )
24
25 import Hoopl.Dataflow
26 import Control.Monad
27 import UniqSupply
28
29 deepFwdRw3 :: (n C O -> f -> UniqSM (Maybe (Graph n C O)))
30 -> (n O O -> f -> UniqSM (Maybe (Graph n O O)))
31 -> (n O C -> f -> UniqSM (Maybe (Graph n O C)))
32 -> (FwdRewrite UniqSM n f)
33 deepFwdRw :: (forall e x . n e x -> f -> UniqSM (Maybe (Graph n e x))) -> FwdRewrite UniqSM n f
34 deepFwdRw3 f m l = iterFwdRw $ mkFRewrite3 f m l
35 deepFwdRw f = deepFwdRw3 f f f
36
37 -- N.B. rw3, rw3', and rw3a are triples of functions.
38 -- But rw and rw' are single functions.
39 thenFwdRw :: forall n f.
40 FwdRewrite UniqSM n f
41 -> FwdRewrite UniqSM n f
42 -> FwdRewrite UniqSM n f
43 thenFwdRw rw3 rw3' = wrapFR2 thenrw rw3 rw3'
44 where
45 thenrw :: forall e x t t1.
46 (t -> t1 -> UniqSM (Maybe (Graph n e x, FwdRewrite UniqSM n f)))
47 -> (t -> t1 -> UniqSM (Maybe (Graph n e x, FwdRewrite UniqSM n f)))
48 -> t
49 -> t1
50 -> UniqSM (Maybe (Graph n e x, FwdRewrite UniqSM n f))
51 thenrw rw rw' n f = rw n f >>= fwdRes
52 where fwdRes Nothing = rw' n f
53 fwdRes (Just gr) = return $ Just $ fadd_rw rw3' gr
54
55 iterFwdRw :: forall n f.
56 FwdRewrite UniqSM n f
57 -> FwdRewrite UniqSM n f
58 iterFwdRw rw3 = wrapFR iter rw3
59 where iter :: forall a e x t.
60 (t -> a -> UniqSM (Maybe (Graph n e x, FwdRewrite UniqSM n f)))
61 -> t
62 -> a
63 -> UniqSM (Maybe (Graph n e x, FwdRewrite UniqSM n f))
64 iter rw n = (liftM $ liftM $ fadd_rw (iterFwdRw rw3)) . rw n
65
66 -- | Function inspired by 'rew' in the paper
67 _frewrite_cps :: ((Graph n e x, FwdRewrite UniqSM n f) -> UniqSM a)
68 -> UniqSM a
69 -> (forall e x . n e x -> f -> UniqSM (Maybe (Graph n e x, FwdRewrite UniqSM n f)))
70 -> n e x
71 -> f
72 -> UniqSM a
73 _frewrite_cps j n rw node f =
74 do mg <- rw node f
75 case mg of Nothing -> n
76 Just gr -> j gr
77
78
79
80 -- | Function inspired by 'add' in the paper
81 fadd_rw :: FwdRewrite UniqSM n f
82 -> (Graph n e x, FwdRewrite UniqSM n f)
83 -> (Graph n e x, FwdRewrite UniqSM n f)
84 fadd_rw rw2 (g, rw1) = (g, rw1 `thenFwdRw` rw2)
85
86
87
88 deepBwdRw3 ::
89 (n C O -> f -> UniqSM (Maybe (Graph n C O)))
90 -> (n O O -> f -> UniqSM (Maybe (Graph n O O)))
91 -> (n O C -> FactBase f -> UniqSM (Maybe (Graph n O C)))
92 -> (BwdRewrite UniqSM n f)
93 deepBwdRw :: (forall e x . n e x -> Fact x f -> UniqSM (Maybe (Graph n e x)))
94 -> BwdRewrite UniqSM n f
95 deepBwdRw3 f m l = iterBwdRw $ mkBRewrite3 f m l
96 deepBwdRw f = deepBwdRw3 f f f
97
98
99 thenBwdRw :: forall n f. BwdRewrite UniqSM n f -> BwdRewrite UniqSM n f -> BwdRewrite UniqSM n f
100 thenBwdRw rw1 rw2 = wrapBR2 f rw1 rw2
101 where f :: forall t t1 t2 e x.
102 t
103 -> (t1 -> t2 -> UniqSM (Maybe (Graph n e x, BwdRewrite UniqSM n f)))
104 -> (t1 -> t2 -> UniqSM (Maybe (Graph n e x, BwdRewrite UniqSM n f)))
105 -> t1
106 -> t2
107 -> UniqSM (Maybe (Graph n e x, BwdRewrite UniqSM n f))
108 f _ rw1 rw2' n f = do
109 res1 <- rw1 n f
110 case res1 of
111 Nothing -> rw2' n f
112 Just gr -> return $ Just $ badd_rw rw2 gr
113
114 iterBwdRw :: forall n f. BwdRewrite UniqSM n f -> BwdRewrite UniqSM n f
115 iterBwdRw rw = wrapBR f rw
116 where f :: forall t e x t1 t2.
117 t
118 -> (t1 -> t2 -> UniqSM (Maybe (Graph n e x, BwdRewrite UniqSM n f)))
119 -> t1
120 -> t2
121 -> UniqSM (Maybe (Graph n e x, BwdRewrite UniqSM n f))
122 f _ rw' n f = liftM (liftM (badd_rw (iterBwdRw rw))) (rw' n f)
123
124 -- | Function inspired by 'add' in the paper
125 badd_rw :: BwdRewrite UniqSM n f
126 -> (Graph n e x, BwdRewrite UniqSM n f)
127 -> (Graph n e x, BwdRewrite UniqSM n f)
128 badd_rw rw2 (g, rw1) = (g, rw1 `thenBwdRw` rw2)
129
130 -- Note [Deprecations in Hoopl]
131 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
132 --
133 -- CmmLive and CmmBuildInfoTables modules enable -fno-warn-warnings-deprecations
134 -- flag because they import deprecated functions from Hoopl. I spent some time
135 -- trying to figure out what is going on, so here's a brief explanation. The
136 -- culprit is the joinOutFacts function, which should be replaced with
137 -- joinFacts. The difference between them is that the latter one needs extra
138 -- Label parameter. Labels identify blocks and are used in the fact base to
139 -- assign facts to a block (in case you're wondering, Label is an Int wrapped in
140 -- a newtype). Lattice join function is also required to accept a Label but the
141 -- only reason why it is so are the debugging purposes: see joinInFacts function
142 -- which is a no-op and is run only because join function might produce
143 -- debugging output. Now, going back to the Cmm modules. The "problem" with the
144 -- deprecated joinOutFacts function is that it passes wrong label when calling
145 -- lattice join function: instead of label of a block for which we are joining
146 -- facts it uses labels of successors of that block. So the joinFacts function
147 -- expects to be given a label of a block for which we are joining facts. I
148 -- don't see an obvious way of recovering that Label at the call sites of
149 -- joinOutFacts (if that was easily done then joinFacts function could do it
150 -- internally without requiring label as a parameter). A cheap way of
151 -- eliminating these warnings would be to create a bogus Label, since none of
152 -- our join functions is actually using the Label parameter. But that doesn't
153 -- feel right. I think the real solution here is to fix Hoopl API, which is
154 -- already broken in several ways. See Hoopl/Cleanup page on the wiki for more
155 -- notes on improving Hoopl.