2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
6 Utilities for desugaring
8 This module exports some utility functions of no great interest.
12 -- | Utility functions for constructing Core syntax, principally for desugaring
17 MatchResult(..), CanItFail(..),
18 cantFailMatchResult, alwaysFailMatchResult,
19 extractMatchResult, combineMatchResults,
20 adjustMatchResult, adjustMatchResultDs,
21 mkCoLetMatchResult, mkViewMatchResult, mkGuardedMatchResult,
22 matchCanFail, mkEvalMatchResult,
23 mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult,
31 mkLHsVarTup, mkLHsTup, mkLHsVarPatTup, mkLHsPatTup,
32 mkBigLHsVarTup, mkBigLHsTup, mkBigLHsVarPatTup, mkBigLHsPatTup,
36 dsSyntaxTable, lookupEvidence,
38 selectSimpleMatchVarL, selectMatchVars, selectMatchVar,
39 mkTickBox, mkOptTickBox, mkBinaryTickBox
42 #include "HsVersions.h"
44 import {-# SOURCE #-} Match ( matchSimply )
45 import {-# SOURCE #-} DsExpr( dsExpr )
49 import TcType( tcSplitTyConApp )
82 %************************************************************************
86 %************************************************************************
89 dsSyntaxTable :: SyntaxTable Id
90 -> DsM ([CoreBind], -- Auxiliary bindings
91 [(Name,Id)]) -- Maps the standard name to its value
93 dsSyntaxTable rebound_ids = do
94 (binds_s, prs) <- mapAndUnzipM mk_bind rebound_ids
95 return (concat binds_s, prs)
97 -- The cheapo special case can happen when we
98 -- make an intermediate HsDo when desugaring a RecStmt
99 mk_bind (std_name, HsVar id) = return ([], (std_name, id))
100 mk_bind (std_name, expr) = do
102 id <- newSysLocalDs (exprType rhs)
103 return ([NonRec id rhs], (std_name, id))
105 lookupEvidence :: [(Name, Id)] -> Name -> Id
106 lookupEvidence prs std_name
107 = assocDefault (mk_panic std_name) prs std_name
109 mk_panic std_name = pprPanic "dsSyntaxTable" (ptext (sLit "Not found:") <+> ppr std_name)
112 %************************************************************************
114 \subsection{ Selecting match variables}
116 %************************************************************************
118 We're about to match against some patterns. We want to make some
119 @Ids@ to use as match variables. If a pattern has an @Id@ readily at
120 hand, which should indeed be bound to the pattern as a whole, then use it;
121 otherwise, make one up.
124 selectSimpleMatchVarL :: LPat Id -> DsM Id
125 selectSimpleMatchVarL pat = selectMatchVar (unLoc pat)
127 -- (selectMatchVars ps tys) chooses variables of type tys
128 -- to use for matching ps against. If the pattern is a variable,
129 -- we try to use that, to save inventing lots of fresh variables.
131 -- OLD, but interesting note:
132 -- But even if it is a variable, its type might not match. Consider
134 -- T1 :: Int -> T Int
137 -- f :: T a -> a -> Int
138 -- f (T1 i) (x::Int) = x
139 -- f (T2 i) (y::a) = 0
140 -- Then we must not choose (x::Int) as the matching variable!
141 -- And nowadays we won't, because the (x::Int) will be wrapped in a CoPat
143 selectMatchVars :: [Pat Id] -> DsM [Id]
144 selectMatchVars ps = mapM selectMatchVar ps
146 selectMatchVar :: Pat Id -> DsM Id
147 selectMatchVar (BangPat pat) = selectMatchVar (unLoc pat)
148 selectMatchVar (LazyPat pat) = selectMatchVar (unLoc pat)
149 selectMatchVar (ParPat pat) = selectMatchVar (unLoc pat)
150 selectMatchVar (VarPat var) = return var
151 selectMatchVar (AsPat var _) = return (unLoc var)
152 selectMatchVar other_pat = newSysLocalDs (hsPatType other_pat)
153 -- OK, better make up one...
157 %************************************************************************
159 %* type synonym EquationInfo and access functions for its pieces *
161 %************************************************************************
162 \subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym}
164 The ``equation info'' used by @match@ is relatively complicated and
165 worthy of a type synonym and a few handy functions.
168 firstPat :: EquationInfo -> Pat Id
169 firstPat eqn = ASSERT( notNull (eqn_pats eqn) ) head (eqn_pats eqn)
171 shiftEqns :: [EquationInfo] -> [EquationInfo]
172 -- Drop the first pattern in each equation
173 shiftEqns eqns = [ eqn { eqn_pats = tail (eqn_pats eqn) } | eqn <- eqns ]
176 Functions on MatchResults
179 matchCanFail :: MatchResult -> Bool
180 matchCanFail (MatchResult CanFail _) = True
181 matchCanFail (MatchResult CantFail _) = False
183 alwaysFailMatchResult :: MatchResult
184 alwaysFailMatchResult = MatchResult CanFail (\fail -> return fail)
186 cantFailMatchResult :: CoreExpr -> MatchResult
187 cantFailMatchResult expr = MatchResult CantFail (\_ -> return expr)
189 extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr
190 extractMatchResult (MatchResult CantFail match_fn) _
191 = match_fn (error "It can't fail!")
193 extractMatchResult (MatchResult CanFail match_fn) fail_expr = do
194 (fail_bind, if_it_fails) <- mkFailurePair fail_expr
195 body <- match_fn if_it_fails
196 return (mkCoreLet fail_bind body)
199 combineMatchResults :: MatchResult -> MatchResult -> MatchResult
200 combineMatchResults (MatchResult CanFail body_fn1)
201 (MatchResult can_it_fail2 body_fn2)
202 = MatchResult can_it_fail2 body_fn
204 body_fn fail = do body2 <- body_fn2 fail
205 (fail_bind, duplicatable_expr) <- mkFailurePair body2
206 body1 <- body_fn1 duplicatable_expr
207 return (Let fail_bind body1)
209 combineMatchResults match_result1@(MatchResult CantFail _) _
212 adjustMatchResult :: DsWrapper -> MatchResult -> MatchResult
213 adjustMatchResult encl_fn (MatchResult can_it_fail body_fn)
214 = MatchResult can_it_fail (\fail -> encl_fn <$> body_fn fail)
216 adjustMatchResultDs :: (CoreExpr -> DsM CoreExpr) -> MatchResult -> MatchResult
217 adjustMatchResultDs encl_fn (MatchResult can_it_fail body_fn)
218 = MatchResult can_it_fail (\fail -> encl_fn =<< body_fn fail)
220 wrapBinds :: [(Var,Var)] -> CoreExpr -> CoreExpr
222 wrapBinds ((new,old):prs) e = wrapBind new old (wrapBinds prs e)
224 wrapBind :: Var -> Var -> CoreExpr -> CoreExpr
225 wrapBind new old body -- Can deal with term variables *or* type variables
227 | isTyVar new = Let (mkTyBind new (mkTyVarTy old)) body
228 | otherwise = Let (NonRec new (Var old)) body
230 seqVar :: Var -> CoreExpr -> CoreExpr
231 seqVar var body = Case (Var var) var (exprType body)
232 [(DEFAULT, [], body)]
234 mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult
235 mkCoLetMatchResult bind = adjustMatchResult (mkCoreLet bind)
237 -- (mkViewMatchResult var' viewExpr var mr) makes the expression
238 -- let var' = viewExpr var in mr
239 mkViewMatchResult :: Id -> CoreExpr -> Id -> MatchResult -> MatchResult
240 mkViewMatchResult var' viewExpr var =
241 adjustMatchResult (mkCoreLet (NonRec var' (mkCoreApp viewExpr (Var var))))
243 mkEvalMatchResult :: Id -> Type -> MatchResult -> MatchResult
244 mkEvalMatchResult var ty
245 = adjustMatchResult (\e -> Case (Var var) var ty [(DEFAULT, [], e)])
247 mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult
248 mkGuardedMatchResult pred_expr (MatchResult _ body_fn)
249 = MatchResult CanFail (\fail -> do body <- body_fn fail
250 return (mkIfThenElse pred_expr body fail))
252 mkCoPrimCaseMatchResult :: Id -- Scrutinee
253 -> Type -- Type of the case
254 -> [(Literal, MatchResult)] -- Alternatives
256 mkCoPrimCaseMatchResult var ty match_alts
257 = MatchResult CanFail mk_case
260 alts <- mapM (mk_alt fail) sorted_alts
261 return (Case (Var var) var ty ((DEFAULT, [], fail) : alts))
263 sorted_alts = sortWith fst match_alts -- Right order for a Case
264 mk_alt fail (lit, MatchResult _ body_fn) = do body <- body_fn fail
265 return (LitAlt lit, [], body)
268 mkCoAlgCaseMatchResult :: Id -- Scrutinee
269 -> Type -- Type of exp
270 -> [(DataCon, [CoreBndr], MatchResult)] -- Alternatives
272 mkCoAlgCaseMatchResult var ty match_alts
273 | isNewTyCon tycon -- Newtype case; use a let
274 = ASSERT( null (tail match_alts) && null (tail arg_ids1) )
275 mkCoLetMatchResult (NonRec arg_id1 newtype_rhs) match_result1
277 | isPArrFakeAlts match_alts -- Sugared parallel array; use a literal case
278 = MatchResult CanFail mk_parrCase
280 | otherwise -- Datatype case; use a case
281 = MatchResult fail_flag mk_case
283 tycon = dataConTyCon con1
284 -- [Interesting: becuase of GADTs, we can't rely on the type of
285 -- the scrutinised Id to be sufficiently refined to have a TyCon in it]
288 (con1, arg_ids1, match_result1) = ASSERT( notNull match_alts ) head match_alts
289 arg_id1 = ASSERT( notNull arg_ids1 ) head arg_ids1
291 (tc, ty_args) = tcSplitTyConApp var_ty -- Don't look through newtypes
292 -- (not that splitTyConApp does, these days)
293 newtype_rhs = unwrapNewTypeBody tc ty_args (Var var)
295 -- Stuff for data types
296 data_cons = tyConDataCons tycon
297 match_results = [match_result | (_,_,match_result) <- match_alts]
299 fail_flag | exhaustive_case
300 = foldr1 orFail [can_it_fail | MatchResult can_it_fail _ <- match_results]
304 wild_var = mkWildId (idType var)
305 sorted_alts = sortWith get_tag match_alts
306 get_tag (con, _, _) = dataConTag con
307 mk_case fail = do alts <- mapM (mk_alt fail) sorted_alts
308 return (Case (Var var) wild_var ty (mk_default fail ++ alts))
310 mk_alt fail (con, args, MatchResult _ body_fn) = do
312 us <- newUniqueSupply
313 return (mkReboxingAlt (uniqsFromSupply us) con args body)
315 mk_default fail | exhaustive_case = []
316 | otherwise = [(DEFAULT, [], fail)]
318 un_mentioned_constructors
319 = mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- match_alts]
320 exhaustive_case = isEmptyUniqSet un_mentioned_constructors
322 -- Stuff for parallel arrays
324 -- * the following is to desugar cases over fake constructors for
325 -- parallel arrays, which are introduced by `tidy1' in the `PArrPat'
328 -- Concerning `isPArrFakeAlts':
330 -- * it is *not* sufficient to just check the type of the type
331 -- constructor, as we have to be careful not to confuse the real
332 -- representation of parallel arrays with the fake constructors;
333 -- moreover, a list of alternatives must not mix fake and real
334 -- constructors (this is checked earlier on)
336 -- FIXME: We actually go through the whole list and make sure that
337 -- either all or none of the constructors are fake parallel
338 -- array constructors. This is to spot equations that mix fake
339 -- constructors with the real representation defined in
340 -- `PrelPArr'. It would be nicer to spot this situation
341 -- earlier and raise a proper error message, but it can really
342 -- only happen in `PrelPArr' anyway.
344 isPArrFakeAlts [(dcon, _, _)] = isPArrFakeCon dcon
345 isPArrFakeAlts ((dcon, _, _):alts) =
346 case (isPArrFakeCon dcon, isPArrFakeAlts alts) of
347 (True , True ) -> True
348 (False, False) -> False
349 _ -> panic "DsUtils: you may not mix `[:...:]' with `PArr' patterns"
350 isPArrFakeAlts [] = panic "DsUtils: unexpectedly found an empty list of PArr fake alternatives"
352 mk_parrCase fail = do
353 lengthP <- dsLookupGlobalId lengthPName
355 return (Case (len lengthP) (mkWildId intTy) ty [alt])
357 elemTy = case splitTyConApp (idType var) of
358 (_, [elemTy]) -> elemTy
360 panicMsg = "DsUtils.mkCoAlgCaseMatchResult: not a parallel array?"
361 len lengthP = mkApps (Var lengthP) [Type elemTy, Var var]
364 l <- newSysLocalDs intPrimTy
365 indexP <- dsLookupGlobalId indexPName
366 alts <- mapM (mkAlt indexP) sorted_alts
367 return (DataAlt intDataCon, [l], (Case (Var l) wild ty (dft : alts)))
369 wild = mkWildId intPrimTy
370 dft = (DEFAULT, [], fail)
372 -- each alternative matches one array length (corresponding to one
373 -- fake array constructor), so the match is on a literal; each
374 -- alternative's body is extended by a local binding for each
375 -- constructor argument, which are bound to array elements starting
378 mkAlt indexP (con, args, MatchResult _ bodyFun) = do
380 return (LitAlt lit, [], mkCoreLets binds body)
382 lit = MachInt $ toInteger (dataConSourceArity con)
383 binds = [NonRec arg (indexExpr i) | (i, arg) <- zip [1..] args]
385 indexExpr i = mkApps (Var indexP) [Type elemTy, Var var, mkIntExpr i]
388 %************************************************************************
390 \subsection{Desugarer's versions of some Core functions}
392 %************************************************************************
395 mkErrorAppDs :: Id -- The error function
396 -> Type -- Type to which it should be applied
397 -> String -- The error message string to pass
400 mkErrorAppDs err_id ty msg = do
401 src_loc <- getSrcSpanDs
403 full_msg = showSDoc (hcat [ppr src_loc, text "|", text msg])
404 core_msg = Lit (mkMachString full_msg)
405 -- mkMachString returns a result of type String#
406 return (mkApps (Var err_id) [Type ty, core_msg])
409 %************************************************************************
411 \subsection[mkSelectorBind]{Make a selector bind}
413 %************************************************************************
415 This is used in various places to do with lazy patterns.
416 For each binder $b$ in the pattern, we create a binding:
418 b = case v of pat' -> b'
420 where @pat'@ is @pat@ with each binder @b@ cloned into @b'@.
422 ToDo: making these bindings should really depend on whether there's
423 much work to be done per binding. If the pattern is complex, it
424 should be de-mangled once, into a tuple (and then selected from).
425 Otherwise the demangling can be in-line in the bindings (as here).
427 Boring! Boring! One error message per binder. The above ToDo is
428 even more helpful. Something very similar happens for pattern-bound
432 mkSelectorBinds :: LPat Id -- The pattern
433 -> CoreExpr -- Expression to which the pattern is bound
434 -> DsM [(Id,CoreExpr)]
436 mkSelectorBinds (L _ (VarPat v)) val_expr
437 = return [(v, val_expr)]
439 mkSelectorBinds pat val_expr
440 | isSingleton binders || is_simple_lpat pat = do
441 -- Given p = e, where p binds x,y
442 -- we are going to make
443 -- v = p (where v is fresh)
444 -- x = case v of p -> x
445 -- y = case v of p -> x
448 -- NB: give it the type of *pattern* p, not the type of the *rhs* e.
449 -- This does not matter after desugaring, but there's a subtle
450 -- issue with implicit parameters. Consider
452 -- Then, ?i is given type {?i :: Int}, a PredType, which is opaque
453 -- to the desugarer. (Why opaque? Because newtypes have to be. Why
454 -- does it get that type? So that when we abstract over it we get the
455 -- right top-level type (?i::Int) => ...)
457 -- So to get the type of 'v', use the pattern not the rhs. Often more
459 val_var <- newSysLocalDs (hsLPatType pat)
461 -- For the error message we make one error-app, to avoid duplication.
462 -- But we need it at different types... so we use coerce for that
463 err_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID unitTy (showSDoc (ppr pat))
464 err_var <- newSysLocalDs unitTy
465 binds <- mapM (mk_bind val_var err_var) binders
466 return ( (val_var, val_expr) :
467 (err_var, err_expr) :
472 error_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID tuple_ty (showSDoc (ppr pat))
473 tuple_expr <- matchSimply val_expr PatBindRhs pat local_tuple error_expr
474 tuple_var <- newSysLocalDs tuple_ty
477 = (binder, mkTupleSelector binders binder tuple_var (Var tuple_var))
478 return ( (tuple_var, tuple_expr) : map mk_tup_bind binders )
480 binders = collectPatBinders pat
481 local_tuple = mkBigCoreVarTup binders
482 tuple_ty = exprType local_tuple
484 mk_bind scrut_var err_var bndr_var = do
485 -- (mk_bind sv err_var) generates
486 -- bv = case sv of { pat -> bv; other -> coerce (type-of-bv) err_var }
487 -- Remember, pat binds bv
488 rhs_expr <- matchSimply (Var scrut_var) PatBindRhs pat
489 (Var bndr_var) error_expr
490 return (bndr_var, rhs_expr)
492 error_expr = mkCoerce co (Var err_var)
493 co = mkUnsafeCoercion (exprType (Var err_var)) (idType bndr_var)
495 is_simple_lpat p = is_simple_pat (unLoc p)
497 is_simple_pat (TuplePat ps Boxed _) = all is_triv_lpat ps
498 is_simple_pat (ConPatOut{ pat_args = ps }) = all is_triv_lpat (hsConPatArgs ps)
499 is_simple_pat (VarPat _) = True
500 is_simple_pat (ParPat p) = is_simple_lpat p
501 is_simple_pat _ = False
503 is_triv_lpat p = is_triv_pat (unLoc p)
505 is_triv_pat (VarPat _) = True
506 is_triv_pat (WildPat _) = True
507 is_triv_pat (ParPat p) = is_triv_lpat p
508 is_triv_pat _ = False
512 Creating tuples and their types for full Haskell expressions
516 -- Smart constructors for source tuple expressions
517 mkLHsVarTup :: [Id] -> LHsExpr Id
518 mkLHsVarTup ids = mkLHsTup (map nlHsVar ids)
520 mkLHsTup :: [LHsExpr Id] -> LHsExpr Id
521 mkLHsTup [] = nlHsVar unitDataConId
522 mkLHsTup [lexp] = lexp
523 mkLHsTup lexps = L (getLoc (head lexps)) $
524 ExplicitTuple lexps Boxed
526 -- Smart constructors for source tuple patterns
527 mkLHsVarPatTup :: [Id] -> LPat Id
528 mkLHsVarPatTup bs = mkLHsPatTup (map nlVarPat bs)
530 mkLHsPatTup :: [LPat Id] -> LPat Id
531 mkLHsPatTup [] = noLoc $ mkVanillaTuplePat [] Boxed
532 mkLHsPatTup [lpat] = lpat
533 mkLHsPatTup lpats = L (getLoc (head lpats)) $
534 mkVanillaTuplePat lpats Boxed
536 -- The Big equivalents for the source tuple expressions
537 mkBigLHsVarTup :: [Id] -> LHsExpr Id
538 mkBigLHsVarTup ids = mkBigLHsTup (map nlHsVar ids)
540 mkBigLHsTup :: [LHsExpr Id] -> LHsExpr Id
541 mkBigLHsTup = mkChunkified mkLHsTup
544 -- The Big equivalents for the source tuple patterns
545 mkBigLHsVarPatTup :: [Id] -> LPat Id
546 mkBigLHsVarPatTup bs = mkBigLHsPatTup (map nlVarPat bs)
548 mkBigLHsPatTup :: [LPat Id] -> LPat Id
549 mkBigLHsPatTup = mkChunkified mkLHsPatTup
552 %************************************************************************
554 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
556 %************************************************************************
558 Generally, we handle pattern matching failure like this: let-bind a
559 fail-variable, and use that variable if the thing fails:
561 let fail.33 = error "Help"
572 If the case can't fail, then there'll be no mention of @fail.33@, and the
573 simplifier will later discard it.
576 If it can fail in only one way, then the simplifier will inline it.
579 Only if it is used more than once will the let-binding remain.
582 There's a problem when the result of the case expression is of
583 unboxed type. Then the type of @fail.33@ is unboxed too, and
584 there is every chance that someone will change the let into a case:
590 which is of course utterly wrong. Rather than drop the condition that
591 only boxed types can be let-bound, we just turn the fail into a function
592 for the primitive case:
594 let fail.33 :: Void -> Int#
595 fail.33 = \_ -> error "Help"
604 Now @fail.33@ is a function, so it can be let-bound.
607 mkFailurePair :: CoreExpr -- Result type of the whole case expression
608 -> DsM (CoreBind, -- Binds the newly-created fail variable
609 -- to either the expression or \ _ -> expression
610 CoreExpr) -- Either the fail variable, or fail variable
611 -- applied to unit tuple
613 | isUnLiftedType ty = do
614 fail_fun_var <- newFailLocalDs (unitTy `mkFunTy` ty)
615 fail_fun_arg <- newSysLocalDs unitTy
616 return (NonRec fail_fun_var (Lam fail_fun_arg expr),
617 App (Var fail_fun_var) (Var unitDataConId))
620 fail_var <- newFailLocalDs ty
621 return (NonRec fail_var expr, Var fail_var)
627 mkOptTickBox :: Maybe (Int,[Id]) -> CoreExpr -> DsM CoreExpr
628 mkOptTickBox Nothing e = return e
629 mkOptTickBox (Just (ix,ids)) e = mkTickBox ix ids e
631 mkTickBox :: Int -> [Id] -> CoreExpr -> DsM CoreExpr
632 mkTickBox ix vars e = do
635 let tick | opt_Hpc = mkTickBoxOpId uq mod ix
636 | otherwise = mkBreakPointOpId uq mod ix
638 let occName = mkVarOcc "tick"
639 let name = mkInternalName uq2 occName noSrcSpan -- use mkSysLocal?
640 let var = Id.mkLocalId name realWorldStatePrimTy
643 then return (Var tick)
645 let tickVar = Var tick
646 let tickType = mkFunTys (map idType vars) realWorldStatePrimTy
647 let scrutApTy = App tickVar (Type tickType)
648 return (mkApps scrutApTy (map Var vars) :: Expr Id)
649 return $ Case scrut var ty [(DEFAULT,[],e)]
653 mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr
654 mkBinaryTickBox ixT ixF e = do
656 let bndr1 = mkSysLocal (fsLit "t1") uq boolTy
657 falseBox <- mkTickBox ixF [] $ Var falseDataConId
658 trueBox <- mkTickBox ixT [] $ Var trueDataConId
659 return $ Case e bndr1 boolTy
660 [ (DataAlt falseDataCon, [], falseBox)
661 , (DataAlt trueDataCon, [], trueBox)