Collect CCs in CorePrep, including CCs in unfoldings
[ghc.git] / compiler / deSugar / DsMonad.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
5
6 @DsMonad@: monadery used in desugaring
7 -}
8
9 {-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
10 {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance MonadThings is necessarily an orphan
11
12 module DsMonad (
13 DsM, mapM, mapAndUnzipM,
14 initDs, initDsTc, initTcDsForSolver, initDsWithModGuts, fixDs,
15 foldlM, foldrM, whenGOptM, unsetGOptM, unsetWOptM, xoptM,
16 Applicative(..),(<$>),
17
18 duplicateLocalDs, newSysLocalDsNoLP, newSysLocalDs,
19 newSysLocalsDsNoLP, newSysLocalsDs, newUniqueId,
20 newFailLocalDs, newPredVarDs,
21 getSrcSpanDs, putSrcSpanDs,
22 mkPrintUnqualifiedDs,
23 newUnique,
24 UniqSupply, newUniqueSupply,
25 getGhcModeDs, dsGetFamInstEnvs,
26 dsLookupGlobal, dsLookupGlobalId, dsDPHBuiltin, dsLookupTyCon,
27 dsLookupDataCon, dsLookupConLike,
28
29 PArrBuiltin(..),
30 dsLookupDPHRdrEnv, dsLookupDPHRdrEnv_maybe,
31 dsInitPArrBuiltin,
32
33 DsMetaEnv, DsMetaVal(..), dsGetMetaEnv, dsLookupMetaEnv, dsExtendMetaEnv,
34
35 -- Getting and setting EvVars and term constraints in local environment
36 getDictsDs, addDictsDs, getTmCsDs, addTmCsDs,
37
38 -- Iterations for pm checking
39 incrCheckPmIterDs, resetPmIterDs, dsGetCompleteMatches,
40
41 -- Warnings and errors
42 DsWarning, warnDs, warnIfSetDs, errDs, errDsCoreExpr,
43 failWithDs, failDs, discardWarningsDs,
44 askNoErrsDs,
45
46 -- Data types
47 DsMatchContext(..),
48 EquationInfo(..), MatchResult(..), DsWrapper, idDsWrapper,
49 CanItFail(..), orFail,
50
51 -- Levity polymorphism
52 dsNoLevPoly, dsNoLevPolyExpr, dsWhenNoErrs,
53
54 -- Trace injection
55 pprRuntimeTrace
56 ) where
57
58 import GhcPrelude
59
60 import TcRnMonad
61 import FamInstEnv
62 import CoreSyn
63 import MkCore ( unitExpr )
64 import CoreUtils ( exprType, isExprLevPoly )
65 import HsSyn
66 import TcIface
67 import TcMType ( checkForLevPolyX, formatLevPolyErr )
68 import LoadIface
69 import Finder
70 import PrelNames
71 import RdrName
72 import HscTypes
73 import Bag
74 import DataCon
75 import ConLike
76 import TyCon
77 import PmExpr
78 import Id
79 import Module
80 import Outputable
81 import SrcLoc
82 import Type
83 import UniqSupply
84 import Name
85 import NameEnv
86 import DynFlags
87 import ErrUtils
88 import FastString
89 import Maybes
90 import Var (EvVar)
91 import qualified GHC.LanguageExtensions as LangExt
92 import UniqFM ( lookupWithDefaultUFM )
93 import Literal ( mkMachString )
94
95 import Data.IORef
96 import Control.Monad
97
98 {-
99 ************************************************************************
100 * *
101 Data types for the desugarer
102 * *
103 ************************************************************************
104 -}
105
106 data DsMatchContext
107 = DsMatchContext (HsMatchContext Name) SrcSpan
108 deriving ()
109
110 instance Outputable DsMatchContext where
111 ppr (DsMatchContext hs_match ss) = ppr ss <+> pprMatchContext hs_match
112
113 data EquationInfo
114 = EqnInfo { eqn_pats :: [Pat GhcTc], -- The patterns for an eqn
115 eqn_rhs :: MatchResult } -- What to do after match
116
117 instance Outputable EquationInfo where
118 ppr (EqnInfo pats _) = ppr pats
119
120 type DsWrapper = CoreExpr -> CoreExpr
121 idDsWrapper :: DsWrapper
122 idDsWrapper e = e
123
124 -- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult
125 -- \fail. wrap (case vs of { pats -> rhs fail })
126 -- where vs are not bound by wrap
127
128
129 -- A MatchResult is an expression with a hole in it
130 data MatchResult
131 = MatchResult
132 CanItFail -- Tells whether the failure expression is used
133 (CoreExpr -> DsM CoreExpr)
134 -- Takes a expression to plug in at the
135 -- failure point(s). The expression should
136 -- be duplicatable!
137
138 data CanItFail = CanFail | CantFail
139
140 orFail :: CanItFail -> CanItFail -> CanItFail
141 orFail CantFail CantFail = CantFail
142 orFail _ _ = CanFail
143
144 {-
145 ************************************************************************
146 * *
147 Monad functions
148 * *
149 ************************************************************************
150 -}
151
152 -- Compatibility functions
153 fixDs :: (a -> DsM a) -> DsM a
154 fixDs = fixM
155
156 type DsWarning = (SrcSpan, SDoc)
157 -- Not quite the same as a WarnMsg, we have an SDoc here
158 -- and we'll do the print_unqual stuff later on to turn it
159 -- into a Doc.
160
161 -- | Run a 'DsM' action inside the 'TcM' monad.
162 initDsTc :: DsM a -> TcM a
163 initDsTc thing_inside
164 = do { tcg_env <- getGblEnv
165 ; msg_var <- getErrsVar
166 ; hsc_env <- getTopEnv
167 ; envs <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
168 ; setEnvs envs $ initDPH thing_inside
169 }
170
171 -- | Run a 'DsM' action inside the 'IO' monad.
172 initDs :: HscEnv -> TcGblEnv -> DsM a -> IO (Messages, Maybe a)
173 initDs hsc_env tcg_env thing_inside
174 = do { msg_var <- newIORef emptyMessages
175 ; envs <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
176 ; runDs hsc_env envs thing_inside
177 }
178
179 -- | Build a set of desugarer environments derived from a 'TcGblEnv'.
180 mkDsEnvsFromTcGbl :: MonadIO m
181 => HscEnv -> IORef Messages -> TcGblEnv
182 -> m (DsGblEnv, DsLclEnv)
183 mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
184 = do { pm_iter_var <- liftIO $ newIORef 0
185 ; let dflags = hsc_dflags hsc_env
186 this_mod = tcg_mod tcg_env
187 type_env = tcg_type_env tcg_env
188 rdr_env = tcg_rdr_env tcg_env
189 fam_inst_env = tcg_fam_inst_env tcg_env
190 complete_matches = hptCompleteSigs hsc_env
191 ++ tcg_complete_matches tcg_env
192 ; return $ mkDsEnvs dflags this_mod rdr_env type_env fam_inst_env
193 msg_var pm_iter_var complete_matches
194 }
195
196 runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages, Maybe a)
197 runDs hsc_env (ds_gbl, ds_lcl) thing_inside
198 = do { res <- initTcRnIf 'd' hsc_env ds_gbl ds_lcl
199 (initDPH $ tryM thing_inside)
200 ; msgs <- readIORef (ds_msgs ds_gbl)
201 ; let final_res
202 | errorsFound dflags msgs = Nothing
203 | Right r <- res = Just r
204 | otherwise = panic "initDs"
205 ; return (msgs, final_res)
206 }
207 where dflags = hsc_dflags hsc_env
208
209 -- | Run a 'DsM' action in the context of an existing 'ModGuts'
210 initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages, Maybe a)
211 initDsWithModGuts hsc_env guts thing_inside
212 = do { pm_iter_var <- newIORef 0
213 ; msg_var <- newIORef emptyMessages
214 ; let dflags = hsc_dflags hsc_env
215 type_env = typeEnvFromEntities ids (mg_tcs guts) (mg_fam_insts guts)
216 rdr_env = mg_rdr_env guts
217 fam_inst_env = mg_fam_inst_env guts
218 this_mod = mg_module guts
219 complete_matches = hptCompleteSigs hsc_env
220 ++ mg_complete_sigs guts
221
222 bindsToIds (NonRec v _) = [v]
223 bindsToIds (Rec binds) = map fst binds
224 ids = concatMap bindsToIds (mg_binds guts)
225
226 envs = mkDsEnvs dflags this_mod rdr_env type_env
227 fam_inst_env msg_var pm_iter_var
228 complete_matches
229 ; runDs hsc_env envs thing_inside
230 }
231
232 initTcDsForSolver :: TcM a -> DsM (Messages, Maybe a)
233 -- Spin up a TcM context so that we can run the constraint solver
234 -- Returns any error messages generated by the constraint solver
235 -- and (Just res) if no error happened; Nothing if an error happened
236 --
237 -- Simon says: I'm not very happy about this. We spin up a complete TcM monad
238 -- only to immediately refine it to a TcS monad.
239 -- Better perhaps to make TcS into its own monad, rather than building on TcS
240 -- But that may in turn interact with plugins
241
242 initTcDsForSolver thing_inside
243 = do { (gbl, lcl) <- getEnvs
244 ; hsc_env <- getTopEnv
245
246 ; let DsGblEnv { ds_mod = mod
247 , ds_fam_inst_env = fam_inst_env } = gbl
248
249 DsLclEnv { dsl_loc = loc } = lcl
250
251 ; liftIO $ initTc hsc_env HsSrcFile False mod loc $
252 updGblEnv (\tc_gbl -> tc_gbl { tcg_fam_inst_env = fam_inst_env }) $
253 thing_inside }
254
255 mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
256 -> IORef Messages -> IORef Int -> [CompleteMatch]
257 -> (DsGblEnv, DsLclEnv)
258 mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var pmvar
259 complete_matches
260 = let if_genv = IfGblEnv { if_doc = text "mkDsEnvs",
261 if_rec_types = Just (mod, return type_env) }
262 if_lenv = mkIfLclEnv mod (text "GHC error in desugarer lookup in" <+> ppr mod)
263 False -- not boot!
264 real_span = realSrcLocSpan (mkRealSrcLoc (moduleNameFS (moduleName mod)) 1 1)
265 completeMatchMap = mkCompleteMatchMap complete_matches
266 gbl_env = DsGblEnv { ds_mod = mod
267 , ds_fam_inst_env = fam_inst_env
268 , ds_if_env = (if_genv, if_lenv)
269 , ds_unqual = mkPrintUnqualified dflags rdr_env
270 , ds_msgs = msg_var
271 , ds_dph_env = emptyGlobalRdrEnv
272 , ds_parr_bi = panic "DsMonad: uninitialised ds_parr_bi"
273 , ds_complete_matches = completeMatchMap
274 }
275 lcl_env = DsLclEnv { dsl_meta = emptyNameEnv
276 , dsl_loc = real_span
277 , dsl_dicts = emptyBag
278 , dsl_tm_cs = emptyBag
279 , dsl_pm_iter = pmvar
280 }
281 in (gbl_env, lcl_env)
282
283
284 {-
285 ************************************************************************
286 * *
287 Operations in the monad
288 * *
289 ************************************************************************
290
291 And all this mysterious stuff is so we can occasionally reach out and
292 grab one or more names. @newLocalDs@ isn't exported---exported
293 functions are defined with it. The difference in name-strings makes
294 it easier to read debugging output.
295
296 Note [Levity polymorphism checking]
297 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
298 According to the "Levity Polymorphism" paper (PLDI '17), levity
299 polymorphism is forbidden in precisely two places: in the type of a bound
300 term-level argument and in the type of an argument to a function. The paper
301 explains it more fully, but briefly: expressions in these contexts need to be
302 stored in registers, and it's hard (read, impossible) to store something
303 that's levity polymorphic.
304
305 We cannot check for bad levity polymorphism conveniently in the type checker,
306 because we can't tell, a priori, which levity metavariables will be solved.
307 At one point, I (Richard) thought we could check in the zonker, but it's hard
308 to know where precisely are the abstracted variables and the arguments. So
309 we check in the desugarer, the only place where we can see the Core code and
310 still report respectable syntax to the user. This covers the vast majority
311 of cases; see calls to DsMonad.dsNoLevPoly and friends.
312
313 Levity polymorphism is also prohibited in the types of binders, and the
314 desugarer checks for this in GHC-generated Ids. (The zonker handles
315 the user-writted ids in zonkIdBndr.) This is done in newSysLocalDsNoLP.
316 The newSysLocalDs variant is used in the vast majority of cases where
317 the binder is obviously not levity polymorphic, omitting the check.
318 It would be nice to ASSERT that there is no levity polymorphism here,
319 but we can't, because of the fixM in DsArrows. It's all OK, though:
320 Core Lint will catch an error here.
321
322 However, the desugarer is the wrong place for certain checks. In particular,
323 the desugarer can't report a sensible error message if an HsWrapper is malformed.
324 After all, GHC itself produced the HsWrapper. So we store some message text
325 in the appropriate HsWrappers (e.g. WpFun) that we can print out in the
326 desugarer.
327
328 There are a few more checks in places where Core is generated outside the
329 desugarer. For example, in datatype and class declarations, where levity
330 polymorphism is checked for during validity checking. It would be nice to
331 have one central place for all this, but that doesn't seem possible while
332 still reporting nice error messages.
333
334 -}
335
336 -- Make a new Id with the same print name, but different type, and new unique
337 newUniqueId :: Id -> Type -> DsM Id
338 newUniqueId id = mk_local (occNameFS (nameOccName (idName id)))
339
340 duplicateLocalDs :: Id -> DsM Id
341 duplicateLocalDs old_local
342 = do { uniq <- newUnique
343 ; return (setIdUnique old_local uniq) }
344
345 newPredVarDs :: PredType -> DsM Var
346 newPredVarDs pred
347 = newSysLocalDs pred
348
349 newSysLocalDsNoLP, newSysLocalDs, newFailLocalDs :: Type -> DsM Id
350 newSysLocalDsNoLP = mk_local (fsLit "ds")
351
352 -- this variant should be used when the caller can be sure that the variable type
353 -- is not levity-polymorphic. It is necessary when the type is knot-tied because
354 -- of the fixM used in DsArrows. See Note [Levity polymorphism checking]
355 newSysLocalDs = mkSysLocalOrCoVarM (fsLit "ds")
356 newFailLocalDs = mkSysLocalOrCoVarM (fsLit "fail")
357 -- the fail variable is used only in a situation where we can tell that
358 -- levity-polymorphism is impossible.
359
360 newSysLocalsDsNoLP, newSysLocalsDs :: [Type] -> DsM [Id]
361 newSysLocalsDsNoLP = mapM newSysLocalDsNoLP
362 newSysLocalsDs = mapM newSysLocalDs
363
364 mk_local :: FastString -> Type -> DsM Id
365 mk_local fs ty = do { dsNoLevPoly ty (text "When trying to create a variable of type:" <+>
366 ppr ty) -- could improve the msg with another
367 -- parameter indicating context
368 ; mkSysLocalOrCoVarM fs ty }
369
370 {-
371 We can also reach out and either set/grab location information from
372 the @SrcSpan@ being carried around.
373 -}
374
375 getGhcModeDs :: DsM GhcMode
376 getGhcModeDs = getDynFlags >>= return . ghcMode
377
378 -- | Get in-scope type constraints (pm check)
379 getDictsDs :: DsM (Bag EvVar)
380 getDictsDs = do { env <- getLclEnv; return (dsl_dicts env) }
381
382 -- | Add in-scope type constraints (pm check)
383 addDictsDs :: Bag EvVar -> DsM a -> DsM a
384 addDictsDs ev_vars
385 = updLclEnv (\env -> env { dsl_dicts = unionBags ev_vars (dsl_dicts env) })
386
387 -- | Get in-scope term constraints (pm check)
388 getTmCsDs :: DsM (Bag SimpleEq)
389 getTmCsDs = do { env <- getLclEnv; return (dsl_tm_cs env) }
390
391 -- | Add in-scope term constraints (pm check)
392 addTmCsDs :: Bag SimpleEq -> DsM a -> DsM a
393 addTmCsDs tm_cs
394 = updLclEnv (\env -> env { dsl_tm_cs = unionBags tm_cs (dsl_tm_cs env) })
395
396 -- | Increase the counter for elapsed pattern match check iterations.
397 -- If the current counter is already over the limit, fail
398 incrCheckPmIterDs :: DsM Int
399 incrCheckPmIterDs = do
400 env <- getLclEnv
401 cnt <- readTcRef (dsl_pm_iter env)
402 max_iters <- maxPmCheckIterations <$> getDynFlags
403 if cnt >= max_iters
404 then failM
405 else updTcRef (dsl_pm_iter env) (+1)
406 return cnt
407
408 -- | Reset the counter for pattern match check iterations to zero
409 resetPmIterDs :: DsM ()
410 resetPmIterDs = do { env <- getLclEnv; writeTcRef (dsl_pm_iter env) 0 }
411
412 getSrcSpanDs :: DsM SrcSpan
413 getSrcSpanDs = do { env <- getLclEnv
414 ; return (RealSrcSpan (dsl_loc env)) }
415
416 putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
417 putSrcSpanDs (UnhelpfulSpan {}) thing_inside
418 = thing_inside
419 putSrcSpanDs (RealSrcSpan real_span) thing_inside
420 = updLclEnv (\ env -> env {dsl_loc = real_span}) thing_inside
421
422 -- | Emit a warning for the current source location
423 -- NB: Warns whether or not -Wxyz is set
424 warnDs :: WarnReason -> SDoc -> DsM ()
425 warnDs reason warn
426 = do { env <- getGblEnv
427 ; loc <- getSrcSpanDs
428 ; dflags <- getDynFlags
429 ; let msg = makeIntoWarning reason $
430 mkWarnMsg dflags loc (ds_unqual env) warn
431 ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) }
432
433 -- | Emit a warning only if the correct WarnReason is set in the DynFlags
434 warnIfSetDs :: WarningFlag -> SDoc -> DsM ()
435 warnIfSetDs flag warn
436 = whenWOptM flag $
437 warnDs (Reason flag) warn
438
439 errDs :: SDoc -> DsM ()
440 errDs err
441 = do { env <- getGblEnv
442 ; loc <- getSrcSpanDs
443 ; dflags <- getDynFlags
444 ; let msg = mkErrMsg dflags loc (ds_unqual env) err
445 ; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg)) }
446
447 -- | Issue an error, but return the expression for (), so that we can continue
448 -- reporting errors.
449 errDsCoreExpr :: SDoc -> DsM CoreExpr
450 errDsCoreExpr err
451 = do { errDs err
452 ; return unitExpr }
453
454 failWithDs :: SDoc -> DsM a
455 failWithDs err
456 = do { errDs err
457 ; failM }
458
459 failDs :: DsM a
460 failDs = failM
461
462 -- (askNoErrsDs m) runs m
463 -- If m fails,
464 -- then (askNoErrsDs m) fails
465 -- If m succeeds with result r,
466 -- then (askNoErrsDs m) succeeds with result (r, b),
467 -- where b is True iff m generated no errors
468 -- Regardless of success or failure,
469 -- propagate any errors/warnings generated by m
470 --
471 -- c.f. TcRnMonad.askNoErrs
472 askNoErrsDs :: DsM a -> DsM (a, Bool)
473 askNoErrsDs thing_inside
474 = do { errs_var <- newMutVar emptyMessages
475 ; env <- getGblEnv
476 ; mb_res <- tryM $ -- Be careful to catch exceptions
477 -- so that we propagate errors correctly
478 -- (Trac #13642)
479 setGblEnv (env { ds_msgs = errs_var }) $
480 thing_inside
481
482 -- Propagate errors
483 ; msgs@(warns, errs) <- readMutVar errs_var
484 ; updMutVar (ds_msgs env) (\ (w,e) -> (w `unionBags` warns, e `unionBags` errs))
485
486 -- And return
487 ; case mb_res of
488 Left _ -> failM
489 Right res -> do { dflags <- getDynFlags
490 ; let errs_found = errorsFound dflags msgs
491 ; return (res, not errs_found) } }
492
493 mkPrintUnqualifiedDs :: DsM PrintUnqualified
494 mkPrintUnqualifiedDs = ds_unqual <$> getGblEnv
495
496 instance MonadThings (IOEnv (Env DsGblEnv DsLclEnv)) where
497 lookupThing = dsLookupGlobal
498
499 -- | Attempt to load the given module and return its exported entities if
500 -- successful.
501 dsLoadModule :: SDoc -> Module -> DsM GlobalRdrEnv
502 dsLoadModule doc mod
503 = do { env <- getGblEnv
504 ; setEnvs (ds_if_env env) $ do
505 { iface <- loadInterface doc mod ImportBySystem
506 ; case iface of
507 Failed err -> pprPanic "DsMonad.dsLoadModule: failed to load" (err $$ doc)
508 Succeeded iface -> return $ mkGlobalRdrEnv . gresFromAvails prov . mi_exports $ iface
509 } }
510 where
511 prov = Just (ImpSpec { is_decl = imp_spec, is_item = ImpAll })
512 imp_spec = ImpDeclSpec { is_mod = name, is_qual = True,
513 is_dloc = wiredInSrcSpan, is_as = name }
514 name = moduleName mod
515
516 dsLookupGlobal :: Name -> DsM TyThing
517 -- Very like TcEnv.tcLookupGlobal
518 dsLookupGlobal name
519 = do { env <- getGblEnv
520 ; setEnvs (ds_if_env env)
521 (tcIfaceGlobal name) }
522
523 dsLookupGlobalId :: Name -> DsM Id
524 dsLookupGlobalId name
525 = tyThingId <$> dsLookupGlobal name
526
527 dsLookupTyCon :: Name -> DsM TyCon
528 dsLookupTyCon name
529 = tyThingTyCon <$> dsLookupGlobal name
530
531 dsLookupDataCon :: Name -> DsM DataCon
532 dsLookupDataCon name
533 = tyThingDataCon <$> dsLookupGlobal name
534
535 dsLookupConLike :: Name -> DsM ConLike
536 dsLookupConLike name
537 = tyThingConLike <$> dsLookupGlobal name
538
539
540 dsGetFamInstEnvs :: DsM FamInstEnvs
541 -- Gets both the external-package inst-env
542 -- and the home-pkg inst env (includes module being compiled)
543 dsGetFamInstEnvs
544 = do { eps <- getEps; env <- getGblEnv
545 ; return (eps_fam_inst_env eps, ds_fam_inst_env env) }
546
547 dsGetMetaEnv :: DsM (NameEnv DsMetaVal)
548 dsGetMetaEnv = do { env <- getLclEnv; return (dsl_meta env) }
549
550 -- | The @COMPLETE@ pragams provided by the user for a given `TyCon`.
551 dsGetCompleteMatches :: TyCon -> DsM [CompleteMatch]
552 dsGetCompleteMatches tc = do
553 eps <- getEps
554 env <- getGblEnv
555 let lookup_completes ufm = lookupWithDefaultUFM ufm [] tc
556 eps_matches_list = lookup_completes $ eps_complete_matches eps
557 env_matches_list = lookup_completes $ ds_complete_matches env
558 return $ eps_matches_list ++ env_matches_list
559
560 dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
561 dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (dsl_meta env) name) }
562
563 dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
564 dsExtendMetaEnv menv thing_inside
565 = updLclEnv (\env -> env { dsl_meta = dsl_meta env `plusNameEnv` menv }) thing_inside
566
567 discardWarningsDs :: DsM a -> DsM a
568 -- Ignore warnings inside the thing inside;
569 -- used to ignore inaccessable cases etc. inside generated code
570 discardWarningsDs thing_inside
571 = do { env <- getGblEnv
572 ; old_msgs <- readTcRef (ds_msgs env)
573
574 ; result <- thing_inside
575
576 -- Revert messages to old_msgs
577 ; writeTcRef (ds_msgs env) old_msgs
578
579 ; return result }
580
581 -- | Fail with an error message if the type is levity polymorphic.
582 dsNoLevPoly :: Type -> SDoc -> DsM ()
583 -- See Note [Levity polymorphism checking]
584 dsNoLevPoly ty doc = checkForLevPolyX errDs doc ty
585
586 -- | Check an expression for levity polymorphism, failing if it is
587 -- levity polymorphic.
588 dsNoLevPolyExpr :: CoreExpr -> SDoc -> DsM ()
589 -- See Note [Levity polymorphism checking]
590 dsNoLevPolyExpr e doc
591 | isExprLevPoly e = errDs (formatLevPolyErr (exprType e) $$ doc)
592 | otherwise = return ()
593
594 -- | Runs the thing_inside. If there are no errors, then returns the expr
595 -- given. Otherwise, returns unitExpr. This is useful for doing a bunch
596 -- of levity polymorphism checks and then avoiding making a core App.
597 -- (If we make a core App on a levity polymorphic argument, detecting how
598 -- to handle the let/app invariant might call isUnliftedType, which panics
599 -- on a levity polymorphic type.)
600 -- See #12709 for an example of why this machinery is necessary.
601 dsWhenNoErrs :: DsM a -> (a -> CoreExpr) -> DsM CoreExpr
602 dsWhenNoErrs thing_inside mk_expr
603 = do { (result, no_errs) <- askNoErrsDs thing_inside
604 ; return $ if no_errs
605 then mk_expr result
606 else unitExpr }
607
608 --------------------------------------------------------------------------
609 -- Data Parallel Haskell
610 --------------------------------------------------------------------------
611
612 -- | Run a 'DsM' with DPH things in scope if necessary.
613 initDPH :: DsM a -> DsM a
614 initDPH = loadDAP . initDPHBuiltins
615
616 -- | Extend the global environment with a 'GlobalRdrEnv' containing the exported
617 -- entities of,
618 --
619 -- * 'Data.Array.Parallel' iff '-XParallelArrays' specified (see also 'checkLoadDAP').
620 -- * 'Data.Array.Parallel.Prim' iff '-fvectorise' specified.
621 loadDAP :: DsM a -> DsM a
622 loadDAP thing_inside
623 = do { dapEnv <- loadOneModule dATA_ARRAY_PARALLEL_NAME checkLoadDAP paErr
624 ; dappEnv <- loadOneModule dATA_ARRAY_PARALLEL_PRIM_NAME (goptM Opt_Vectorise) veErr
625 ; updGblEnv (\env -> env {ds_dph_env = dapEnv `plusOccEnv` dappEnv }) thing_inside
626 }
627 where
628 loadOneModule :: ModuleName -- the module to load
629 -> DsM Bool -- under which condition
630 -> MsgDoc -- error message if module not found
631 -> DsM GlobalRdrEnv -- empty if condition 'False'
632 loadOneModule modname check err
633 = do { doLoad <- check
634 ; if not doLoad
635 then return emptyGlobalRdrEnv
636 else do {
637 ; hsc_env <- getTopEnv
638 ; result <- liftIO $ findImportedModule hsc_env modname Nothing
639 ; case result of
640 Found _ mod -> dsLoadModule err mod
641 _ -> pprPgmError "Unable to use Data Parallel Haskell (DPH):" err
642 } }
643
644 paErr = text "To use ParallelArrays," <+> specBackend $$ hint1 $$ hint2
645 veErr = text "To use -fvectorise," <+> specBackend $$ hint1 $$ hint2
646 specBackend = text "you must specify a DPH backend package"
647 hint1 = text "Look for packages named 'dph-lifted-*' with 'ghc-pkg'"
648 hint2 = text "You may need to install them with 'cabal install dph-examples'"
649
650 -- | If '-XParallelArrays' given, we populate the builtin table for desugaring
651 -- those.
652 initDPHBuiltins :: DsM a -> DsM a
653 initDPHBuiltins thing_inside
654 = do { doInitBuiltins <- checkLoadDAP
655 ; if doInitBuiltins
656 then dsInitPArrBuiltin thing_inside
657 else thing_inside
658 }
659
660 checkLoadDAP :: DsM Bool
661 checkLoadDAP
662 = do { paEnabled <- xoptM LangExt.ParallelArrays
663 ; mod <- getModule
664 -- do not load 'Data.Array.Parallel' iff compiling 'base:GHC.PArr' or a
665 -- module called 'dATA_ARRAY_PARALLEL_NAME'; see also the comments at the top
666 -- of 'base:GHC.PArr' and 'Data.Array.Parallel' in the DPH libraries
667 ; return $ paEnabled &&
668 mod /= gHC_PARR' &&
669 moduleName mod /= dATA_ARRAY_PARALLEL_NAME
670 }
671
672 -- | Populate 'ds_parr_bi' from 'ds_dph_env'.
673 --
674 dsInitPArrBuiltin :: DsM a -> DsM a
675 dsInitPArrBuiltin thing_inside
676 = do { lengthPVar <- externalVar (fsLit "lengthP")
677 ; replicatePVar <- externalVar (fsLit "replicateP")
678 ; singletonPVar <- externalVar (fsLit "singletonP")
679 ; mapPVar <- externalVar (fsLit "mapP")
680 ; filterPVar <- externalVar (fsLit "filterP")
681 ; zipPVar <- externalVar (fsLit "zipP")
682 ; crossMapPVar <- externalVar (fsLit "crossMapP")
683 ; indexPVar <- externalVar (fsLit "!:")
684 ; emptyPVar <- externalVar (fsLit "emptyP")
685 ; appPVar <- externalVar (fsLit "+:+")
686 -- ; enumFromToPVar <- externalVar (fsLit "enumFromToP")
687 -- ; enumFromThenToPVar <- externalVar (fsLit "enumFromThenToP")
688 ; enumFromToPVar <- return arithErr
689 ; enumFromThenToPVar <- return arithErr
690
691 ; updGblEnv (\env -> env {ds_parr_bi = PArrBuiltin
692 { lengthPVar = lengthPVar
693 , replicatePVar = replicatePVar
694 , singletonPVar = singletonPVar
695 , mapPVar = mapPVar
696 , filterPVar = filterPVar
697 , zipPVar = zipPVar
698 , crossMapPVar = crossMapPVar
699 , indexPVar = indexPVar
700 , emptyPVar = emptyPVar
701 , appPVar = appPVar
702 , enumFromToPVar = enumFromToPVar
703 , enumFromThenToPVar = enumFromThenToPVar
704 } })
705 thing_inside
706 }
707 where
708 externalVar :: FastString -> DsM Var
709 externalVar fs = dsLookupDPHRdrEnv (mkVarOccFS fs) >>= dsLookupGlobalId
710
711 arithErr = panic "Arithmetic sequences have to wait until we support type classes"
712
713 -- |Get a name from "Data.Array.Parallel" for the desugarer, from the
714 -- 'ds_parr_bi' component of the global desugerar environment.
715 --
716 dsDPHBuiltin :: (PArrBuiltin -> a) -> DsM a
717 dsDPHBuiltin sel = (sel . ds_parr_bi) <$> getGblEnv
718
719 -- |Lookup a name exported by 'Data.Array.Parallel.Prim' or 'Data.Array.Parallel.Prim'.
720 -- Panic if there isn't one, or if it is defined multiple times.
721 dsLookupDPHRdrEnv :: OccName -> DsM Name
722 dsLookupDPHRdrEnv occ
723 = liftM (fromMaybe (pprPanic nameNotFound (ppr occ)))
724 $ dsLookupDPHRdrEnv_maybe occ
725 where nameNotFound = "Name not found in 'Data.Array.Parallel' or 'Data.Array.Parallel.Prim':"
726
727 -- |Lookup a name exported by 'Data.Array.Parallel.Prim' or 'Data.Array.Parallel.Prim',
728 -- returning `Nothing` if it's not defined. Panic if it's defined multiple times.
729 dsLookupDPHRdrEnv_maybe :: OccName -> DsM (Maybe Name)
730 dsLookupDPHRdrEnv_maybe occ
731 = do { env <- ds_dph_env <$> getGblEnv
732 ; let gres = lookupGlobalRdrEnv env occ
733 ; case gres of
734 [] -> return $ Nothing
735 [gre] -> return $ Just $ gre_name gre
736 _ -> pprPanic multipleNames (ppr occ)
737 }
738 where multipleNames = "Multiple definitions in 'Data.Array.Parallel' and 'Data.Array.Parallel.Prim':"
739
740 -- | Inject a trace message into the compiled program. Whereas
741 -- pprTrace prints out information *while compiling*, pprRuntimeTrace
742 -- captures that information and causes it to be printed *at runtime*
743 -- using Debug.Trace.trace.
744 --
745 -- pprRuntimeTrace hdr doc expr
746 --
747 -- will produce an expression that looks like
748 --
749 -- trace (hdr + doc) expr
750 --
751 -- When using this to debug a module that Debug.Trace depends on,
752 -- it is necessary to import {-# SOURCE #-} Debug.Trace () in that
753 -- module. We could avoid this inconvenience by wiring in Debug.Trace.trace,
754 -- but that doesn't seem worth the effort and maintenance cost.
755 pprRuntimeTrace :: String -- ^ header
756 -> SDoc -- ^ information to output
757 -> CoreExpr -- ^ expression
758 -> DsM CoreExpr
759 pprRuntimeTrace str doc expr = do
760 traceId <- dsLookupGlobalId traceName
761 unpackCStringId <- dsLookupGlobalId unpackCStringName
762 dflags <- getDynFlags
763 let message :: CoreExpr
764 message = App (Var unpackCStringId) $
765 Lit $ mkMachString $ showSDoc dflags (hang (text str) 4 doc)
766 return $ mkApps (Var traceId) [Type (exprType expr), message, expr]