b084da67dc1dce6b2c6b11f786cb80ec1abc88be
[ghc.git] / compiler / vectorise / Vectorise / Monad / Base.hs
1 -- |The Vectorisation monad.
2
3 module Vectorise.Monad.Base (
4 -- * The Vectorisation Monad
5 VResult(..),
6 VM(..),
7
8 -- * Lifting
9 liftDs,
10
11 -- * Error Handling
12 cantVectorise,
13 maybeCantVectorise,
14 maybeCantVectoriseM,
15
16 -- * Debugging
17 emitVt, traceVt, dumpOptVt, dumpVt,
18
19 -- * Control
20 noV, traceNoV,
21 ensureV, traceEnsureV,
22 onlyIfV,
23 tryV, tryErrV,
24 maybeV, traceMaybeV,
25 orElseV, orElseErrV,
26 fixV,
27 ) where
28
29 import Vectorise.Builtins
30 import Vectorise.Env
31
32 import DsMonad
33 import TcRnMonad
34 import ErrUtils
35 import Outputable
36 import DynFlags
37
38 import Control.Monad
39
40
41 -- The Vectorisation Monad ----------------------------------------------------
42
43 -- |Vectorisation can either succeed with new envionment and a value, or return with failure
44 -- (including a description of the reason for failure).
45 --
46 data VResult a
47 = Yes GlobalEnv LocalEnv a
48 | No SDoc
49
50 newtype VM a
51 = VM { runVM :: Builtins -> GlobalEnv -> LocalEnv -> DsM (VResult a) }
52
53 instance Monad VM where
54 VM p >>= f = VM $ \bi genv lenv -> do
55 r <- p bi genv lenv
56 case r of
57 Yes genv' lenv' x -> runVM (f x) bi genv' lenv'
58 No reason -> return $ No reason
59
60 instance Applicative VM where
61 pure x = VM $ \_ genv lenv -> return (Yes genv lenv x)
62 (<*>) = ap
63
64 instance Functor VM where
65 fmap = liftM
66
67 instance MonadIO VM where
68 liftIO = liftDs . liftIO
69
70 instance HasDynFlags VM where
71 getDynFlags = liftDs getDynFlags
72
73 -- Lifting --------------------------------------------------------------------
74
75 -- |Lift a desugaring computation into the vectorisation monad.
76 --
77 liftDs :: DsM a -> VM a
78 liftDs p = VM $ \_ genv lenv -> do { x <- p; return (Yes genv lenv x) }
79
80
81 -- Error Handling -------------------------------------------------------------
82
83 -- |Throw a `pgmError` saying we can't vectorise something.
84 --
85 cantVectorise :: DynFlags -> String -> SDoc -> a
86 cantVectorise dflags s d = pgmError
87 . showSDoc dflags
88 $ vcat [text "*** Vectorisation error ***",
89 nest 4 $ sep [text s, nest 4 d]]
90
91 -- |Like `fromJust`, but `pgmError` on Nothing.
92 --
93 maybeCantVectorise :: DynFlags -> String -> SDoc -> Maybe a -> a
94 maybeCantVectorise dflags s d Nothing = cantVectorise dflags s d
95 maybeCantVectorise _ _ _ (Just x) = x
96
97 -- |Like `maybeCantVectorise` but in a `Monad`.
98 --
99 maybeCantVectoriseM :: (Monad m, HasDynFlags m)
100 => String -> SDoc -> m (Maybe a) -> m a
101 maybeCantVectoriseM s d p
102 = do
103 r <- p
104 case r of
105 Just x -> return x
106 Nothing ->
107 do dflags <- getDynFlags
108 cantVectorise dflags s d
109
110
111 -- Debugging ------------------------------------------------------------------
112
113 -- |Output a trace message if -ddump-vt-trace is active.
114 --
115 emitVt :: String -> SDoc -> VM ()
116 emitVt herald doc
117 = liftDs $ do
118 dflags <- getDynFlags
119 liftIO . printOutputForUser dflags alwaysQualify $
120 hang (text herald) 2 doc
121
122 -- |Output a trace message if -ddump-vt-trace is active.
123 --
124 traceVt :: String -> SDoc -> VM ()
125 traceVt herald doc
126 = do dflags <- getDynFlags
127 when (1 <= traceLevel dflags) $
128 liftDs $ traceOptIf Opt_D_dump_vt_trace $ hang (text herald) 2 doc
129
130 -- |Dump the given program conditionally.
131 --
132 dumpOptVt :: DumpFlag -> String -> SDoc -> VM ()
133 dumpOptVt flag header doc
134 = do { b <- liftDs $ doptM flag
135 ; if b
136 then dumpVt header doc
137 else return ()
138 }
139
140 -- |Dump the given program unconditionally.
141 --
142 dumpVt :: String -> SDoc -> VM ()
143 dumpVt header doc
144 = do { unqual <- liftDs mkPrintUnqualifiedDs
145 ; dflags <- liftDs getDynFlags
146 ; liftIO $ printOutputForUser dflags unqual (mkDumpDoc header doc)
147 }
148
149
150 -- Control --------------------------------------------------------------------
151
152 -- |Return some result saying we've failed.
153 --
154 noV :: SDoc -> VM a
155 noV reason = VM $ \_ _ _ -> return $ No reason
156
157 -- |Like `traceNoV` but also emit some trace message to stderr.
158 --
159 traceNoV :: String -> SDoc -> VM a
160 traceNoV s d = pprTrace s d $ noV d
161
162 -- |If `True` then carry on, otherwise fail.
163 --
164 ensureV :: SDoc -> Bool -> VM ()
165 ensureV reason False = noV reason
166 ensureV _reason True = return ()
167
168 -- |Like `ensureV` but if we fail then emit some trace message to stderr.
169 --
170 traceEnsureV :: String -> SDoc -> Bool -> VM ()
171 traceEnsureV s d False = traceNoV s d
172 traceEnsureV _ _ True = return ()
173
174 -- |If `True` then return the first argument, otherwise fail.
175 --
176 onlyIfV :: SDoc -> Bool -> VM a -> VM a
177 onlyIfV reason b p = ensureV reason b >> p
178
179 -- |Try some vectorisation computaton.
180 --
181 -- If it succeeds then return `Just` the result; otherwise, return `Nothing` after emitting a
182 -- failure message.
183 --
184 tryErrV :: VM a -> VM (Maybe a)
185 tryErrV (VM p) = VM $ \bi genv lenv ->
186 do
187 r <- p bi genv lenv
188 case r of
189 Yes genv' lenv' x -> return (Yes genv' lenv' (Just x))
190 No reason -> do { unqual <- mkPrintUnqualifiedDs
191 ; dflags <- getDynFlags
192 ; liftIO $
193 printInfoForUser dflags unqual $
194 text "Warning: vectorisation failure:" <+> reason
195 ; return (Yes genv lenv Nothing)
196 }
197
198 -- |Try some vectorisation computaton.
199 --
200 -- If it succeeds then return `Just` the result; otherwise, return `Nothing` without emitting a
201 -- failure message.
202 --
203 tryV :: VM a -> VM (Maybe a)
204 tryV (VM p) = VM $ \bi genv lenv ->
205 do
206 r <- p bi genv lenv
207 case r of
208 Yes genv' lenv' x -> return (Yes genv' lenv' (Just x))
209 No _reason -> return (Yes genv lenv Nothing)
210
211 -- |If `Just` then return the value, otherwise fail.
212 --
213 maybeV :: SDoc -> VM (Maybe a) -> VM a
214 maybeV reason p = maybe (noV reason) return =<< p
215
216 -- |Like `maybeV` but emit a message to stderr if we fail.
217 --
218 traceMaybeV :: String -> SDoc -> VM (Maybe a) -> VM a
219 traceMaybeV s d p = maybe (traceNoV s d) return =<< p
220
221 -- |Try the first computation,
222 --
223 -- * if it succeeds then take the returned value,
224 -- * if it fails then run the second computation instead while emitting a failure message.
225 --
226 orElseErrV :: VM a -> VM a -> VM a
227 orElseErrV p q = maybe q return =<< tryErrV p
228
229 -- |Try the first computation,
230 --
231 -- * if it succeeds then take the returned value,
232 -- * if it fails then run the second computation instead without emitting a failure message.
233 --
234 orElseV :: VM a -> VM a -> VM a
235 orElseV p q = maybe q return =<< tryV p
236
237 -- |Fixpoint in the vectorisation monad.
238 --
239 fixV :: (a -> VM a) -> VM a
240 fixV f = VM (\bi genv lenv -> fixDs $ \r -> runVM (f (unYes r)) bi genv lenv )
241 where
242 -- NOTE: It is essential that we are lazy in r above so do not replace
243 -- calls to this function by an explicit case.
244 unYes (Yes _ _ x) = x
245 unYes (No reason) = pprPanic "Vectorise.Monad.Base.fixV: no result" reason