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 )
81 %************************************************************************
85 %************************************************************************
88 dsSyntaxTable :: SyntaxTable Id
89 -> DsM ([CoreBind], -- Auxiliary bindings
90 [(Name,Id)]) -- Maps the standard name to its value
92 dsSyntaxTable rebound_ids = do
93 (binds_s, prs) <- mapAndUnzipM mk_bind rebound_ids
94 return (concat binds_s, prs)
96 -- The cheapo special case can happen when we
97 -- make an intermediate HsDo when desugaring a RecStmt
98 mk_bind (std_name, HsVar id) = return ([], (std_name, id))
99 mk_bind (std_name, expr) = do
101 id <- newSysLocalDs (exprType rhs)
102 return ([NonRec id rhs], (std_name, id))
104 lookupEvidence :: [(Name, Id)] -> Name -> Id
105 lookupEvidence prs std_name
106 = assocDefault (mk_panic std_name) prs std_name
108 mk_panic std_name = pprPanic "dsSyntaxTable" (ptext (sLit "Not found:") <+> ppr std_name)
111 %************************************************************************
113 \subsection{ Selecting match variables}
115 %************************************************************************
117 We're about to match against some patterns. We want to make some
118 @Ids@ to use as match variables. If a pattern has an @Id@ readily at
119 hand, which should indeed be bound to the pattern as a whole, then use it;
120 otherwise, make one up.
123 selectSimpleMatchVarL :: LPat Id -> DsM Id
124 selectSimpleMatchVarL pat = selectMatchVar (unLoc pat)
126 -- (selectMatchVars ps tys) chooses variables of type tys
127 -- to use for matching ps against. If the pattern is a variable,
128 -- we try to use that, to save inventing lots of fresh variables.
130 -- OLD, but interesting note:
131 -- But even if it is a variable, its type might not match. Consider
133 -- T1 :: Int -> T Int
136 -- f :: T a -> a -> Int
137 -- f (T1 i) (x::Int) = x
138 -- f (T2 i) (y::a) = 0
139 -- Then we must not choose (x::Int) as the matching variable!
140 -- And nowadays we won't, because the (x::Int) will be wrapped in a CoPat
142 selectMatchVars :: [Pat Id] -> DsM [Id]
143 selectMatchVars ps = mapM selectMatchVar ps
145 selectMatchVar :: Pat Id -> DsM Id
146 selectMatchVar (BangPat pat) = selectMatchVar (unLoc pat)
147 selectMatchVar (LazyPat pat) = selectMatchVar (unLoc pat)
148 selectMatchVar (ParPat pat) = selectMatchVar (unLoc pat)
149 selectMatchVar (VarPat var) = return var
150 selectMatchVar (AsPat var _) = return (unLoc var)
151 selectMatchVar other_pat = newSysLocalDs (hsPatType other_pat)
152 -- OK, better make up one...
156 %************************************************************************
158 %* type synonym EquationInfo and access functions for its pieces *
160 %************************************************************************
161 \subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym}
163 The ``equation info'' used by @match@ is relatively complicated and
164 worthy of a type synonym and a few handy functions.
167 firstPat :: EquationInfo -> Pat Id
168 firstPat eqn = ASSERT( notNull (eqn_pats eqn) ) head (eqn_pats eqn)
170 shiftEqns :: [EquationInfo] -> [EquationInfo]
171 -- Drop the first pattern in each equation
172 shiftEqns eqns = [ eqn { eqn_pats = tail (eqn_pats eqn) } | eqn <- eqns ]
175 Functions on MatchResults
178 matchCanFail :: MatchResult -> Bool
179 matchCanFail (MatchResult CanFail _) = True
180 matchCanFail (MatchResult CantFail _) = False
182 alwaysFailMatchResult :: MatchResult
183 alwaysFailMatchResult = MatchResult CanFail (\fail -> return fail)
185 cantFailMatchResult :: CoreExpr -> MatchResult
186 cantFailMatchResult expr = MatchResult CantFail (\_ -> return expr)
188 extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr
189 extractMatchResult (MatchResult CantFail match_fn) _
190 = match_fn (error "It can't fail!")
192 extractMatchResult (MatchResult CanFail match_fn) fail_expr = do
193 (fail_bind, if_it_fails) <- mkFailurePair fail_expr
194 body <- match_fn if_it_fails
195 return (mkCoreLet fail_bind body)
198 combineMatchResults :: MatchResult -> MatchResult -> MatchResult
199 combineMatchResults (MatchResult CanFail body_fn1)
200 (MatchResult can_it_fail2 body_fn2)
201 = MatchResult can_it_fail2 body_fn
203 body_fn fail = do body2 <- body_fn2 fail
204 (fail_bind, duplicatable_expr) <- mkFailurePair body2
205 body1 <- body_fn1 duplicatable_expr
206 return (Let fail_bind body1)
208 combineMatchResults match_result1@(MatchResult CantFail _) _
211 adjustMatchResult :: DsWrapper -> MatchResult -> MatchResult
212 adjustMatchResult encl_fn (MatchResult can_it_fail body_fn)
213 = MatchResult can_it_fail (\fail -> encl_fn <$> body_fn fail)
215 adjustMatchResultDs :: (CoreExpr -> DsM CoreExpr) -> MatchResult -> MatchResult
216 adjustMatchResultDs encl_fn (MatchResult can_it_fail body_fn)
217 = MatchResult can_it_fail (\fail -> encl_fn =<< body_fn fail)
219 wrapBinds :: [(Var,Var)] -> CoreExpr -> CoreExpr
221 wrapBinds ((new,old):prs) e = wrapBind new old (wrapBinds prs e)
223 wrapBind :: Var -> Var -> CoreExpr -> CoreExpr
224 wrapBind new old body -- Can deal with term variables *or* type variables
226 | isTyVar new = Let (mkTyBind new (mkTyVarTy old)) body
227 | otherwise = Let (NonRec new (Var old)) body
229 seqVar :: Var -> CoreExpr -> CoreExpr
230 seqVar var body = Case (Var var) var (exprType body)
231 [(DEFAULT, [], body)]
233 mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult
234 mkCoLetMatchResult bind = adjustMatchResult (mkCoreLet bind)
236 -- (mkViewMatchResult var' viewExpr var mr) makes the expression
237 -- let var' = viewExpr var in mr
238 mkViewMatchResult :: Id -> CoreExpr -> Id -> MatchResult -> MatchResult
239 mkViewMatchResult var' viewExpr var =
240 adjustMatchResult (mkCoreLet (NonRec var' (mkCoreApp viewExpr (Var var))))
242 mkEvalMatchResult :: Id -> Type -> MatchResult -> MatchResult
243 mkEvalMatchResult var ty
244 = adjustMatchResult (\e -> Case (Var var) var ty [(DEFAULT, [], e)])
246 mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult
247 mkGuardedMatchResult pred_expr (MatchResult _ body_fn)
248 = MatchResult CanFail (\fail -> do body <- body_fn fail
249 return (mkIfThenElse pred_expr body fail))
251 mkCoPrimCaseMatchResult :: Id -- Scrutinee
252 -> Type -- Type of the case
253 -> [(Literal, MatchResult)] -- Alternatives
255 mkCoPrimCaseMatchResult var ty match_alts
256 = MatchResult CanFail mk_case
259 alts <- mapM (mk_alt fail) sorted_alts
260 return (Case (Var var) var ty ((DEFAULT, [], fail) : alts))
262 sorted_alts = sortWith fst match_alts -- Right order for a Case
263 mk_alt fail (lit, MatchResult _ body_fn) = do body <- body_fn fail
264 return (LitAlt lit, [], body)
267 mkCoAlgCaseMatchResult :: Id -- Scrutinee
268 -> Type -- Type of exp
269 -> [(DataCon, [CoreBndr], MatchResult)] -- Alternatives
271 mkCoAlgCaseMatchResult var ty match_alts
272 | isNewTyCon tycon -- Newtype case; use a let
273 = ASSERT( null (tail match_alts) && null (tail arg_ids1) )
274 mkCoLetMatchResult (NonRec arg_id1 newtype_rhs) match_result1
276 | isPArrFakeAlts match_alts -- Sugared parallel array; use a literal case
277 = MatchResult CanFail mk_parrCase
279 | otherwise -- Datatype case; use a case
280 = MatchResult fail_flag mk_case
282 tycon = dataConTyCon con1
283 -- [Interesting: becuase of GADTs, we can't rely on the type of
284 -- the scrutinised Id to be sufficiently refined to have a TyCon in it]
287 (con1, arg_ids1, match_result1) = ASSERT( notNull match_alts ) head match_alts
288 arg_id1 = ASSERT( notNull arg_ids1 ) head arg_ids1
290 (tc, ty_args) = splitNewTyConApp var_ty
291 newtype_rhs = unwrapNewTypeBody tc ty_args (Var var)
293 -- Stuff for data types
294 data_cons = tyConDataCons tycon
295 match_results = [match_result | (_,_,match_result) <- match_alts]
297 fail_flag | exhaustive_case
298 = foldr1 orFail [can_it_fail | MatchResult can_it_fail _ <- match_results]
302 wild_var = mkWildId (idType var)
303 sorted_alts = sortWith get_tag match_alts
304 get_tag (con, _, _) = dataConTag con
305 mk_case fail = do alts <- mapM (mk_alt fail) sorted_alts
306 return (Case (Var var) wild_var ty (mk_default fail ++ alts))
308 mk_alt fail (con, args, MatchResult _ body_fn) = do
310 us <- newUniqueSupply
311 return (mkReboxingAlt (uniqsFromSupply us) con args body)
313 mk_default fail | exhaustive_case = []
314 | otherwise = [(DEFAULT, [], fail)]
316 un_mentioned_constructors
317 = mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- match_alts]
318 exhaustive_case = isEmptyUniqSet un_mentioned_constructors
320 -- Stuff for parallel arrays
322 -- * the following is to desugar cases over fake constructors for
323 -- parallel arrays, which are introduced by `tidy1' in the `PArrPat'
326 -- Concerning `isPArrFakeAlts':
328 -- * it is *not* sufficient to just check the type of the type
329 -- constructor, as we have to be careful not to confuse the real
330 -- representation of parallel arrays with the fake constructors;
331 -- moreover, a list of alternatives must not mix fake and real
332 -- constructors (this is checked earlier on)
334 -- FIXME: We actually go through the whole list and make sure that
335 -- either all or none of the constructors are fake parallel
336 -- array constructors. This is to spot equations that mix fake
337 -- constructors with the real representation defined in
338 -- `PrelPArr'. It would be nicer to spot this situation
339 -- earlier and raise a proper error message, but it can really
340 -- only happen in `PrelPArr' anyway.
342 isPArrFakeAlts [(dcon, _, _)] = isPArrFakeCon dcon
343 isPArrFakeAlts ((dcon, _, _):alts) =
344 case (isPArrFakeCon dcon, isPArrFakeAlts alts) of
345 (True , True ) -> True
346 (False, False) -> False
347 _ -> panic "DsUtils: you may not mix `[:...:]' with `PArr' patterns"
348 isPArrFakeAlts [] = panic "DsUtils: unexpectedly found an empty list of PArr fake alternatives"
350 mk_parrCase fail = do
351 lengthP <- dsLookupGlobalId lengthPName
353 return (Case (len lengthP) (mkWildId intTy) ty [alt])
355 elemTy = case splitTyConApp (idType var) of
356 (_, [elemTy]) -> elemTy
358 panicMsg = "DsUtils.mkCoAlgCaseMatchResult: not a parallel array?"
359 len lengthP = mkApps (Var lengthP) [Type elemTy, Var var]
362 l <- newSysLocalDs intPrimTy
363 indexP <- dsLookupGlobalId indexPName
364 alts <- mapM (mkAlt indexP) sorted_alts
365 return (DataAlt intDataCon, [l], (Case (Var l) wild ty (dft : alts)))
367 wild = mkWildId intPrimTy
368 dft = (DEFAULT, [], fail)
370 -- each alternative matches one array length (corresponding to one
371 -- fake array constructor), so the match is on a literal; each
372 -- alternative's body is extended by a local binding for each
373 -- constructor argument, which are bound to array elements starting
376 mkAlt indexP (con, args, MatchResult _ bodyFun) = do
378 return (LitAlt lit, [], mkCoreLets binds body)
380 lit = MachInt $ toInteger (dataConSourceArity con)
381 binds = [NonRec arg (indexExpr i) | (i, arg) <- zip [1..] args]
383 indexExpr i = mkApps (Var indexP) [Type elemTy, Var var, mkIntExpr i]
386 %************************************************************************
388 \subsection{Desugarer's versions of some Core functions}
390 %************************************************************************
393 mkErrorAppDs :: Id -- The error function
394 -> Type -- Type to which it should be applied
395 -> String -- The error message string to pass
398 mkErrorAppDs err_id ty msg = do
399 src_loc <- getSrcSpanDs
401 full_msg = showSDoc (hcat [ppr src_loc, text "|", text msg])
402 core_msg = Lit (mkMachString full_msg)
403 -- mkMachString returns a result of type String#
404 return (mkApps (Var err_id) [Type ty, core_msg])
407 %************************************************************************
409 \subsection[mkSelectorBind]{Make a selector bind}
411 %************************************************************************
413 This is used in various places to do with lazy patterns.
414 For each binder $b$ in the pattern, we create a binding:
416 b = case v of pat' -> b'
418 where @pat'@ is @pat@ with each binder @b@ cloned into @b'@.
420 ToDo: making these bindings should really depend on whether there's
421 much work to be done per binding. If the pattern is complex, it
422 should be de-mangled once, into a tuple (and then selected from).
423 Otherwise the demangling can be in-line in the bindings (as here).
425 Boring! Boring! One error message per binder. The above ToDo is
426 even more helpful. Something very similar happens for pattern-bound
430 mkSelectorBinds :: LPat Id -- The pattern
431 -> CoreExpr -- Expression to which the pattern is bound
432 -> DsM [(Id,CoreExpr)]
434 mkSelectorBinds (L _ (VarPat v)) val_expr
435 = return [(v, val_expr)]
437 mkSelectorBinds pat val_expr
438 | isSingleton binders || is_simple_lpat pat = do
439 -- Given p = e, where p binds x,y
440 -- we are going to make
441 -- v = p (where v is fresh)
442 -- x = case v of p -> x
443 -- y = case v of p -> x
446 -- NB: give it the type of *pattern* p, not the type of the *rhs* e.
447 -- This does not matter after desugaring, but there's a subtle
448 -- issue with implicit parameters. Consider
450 -- Then, ?i is given type {?i :: Int}, a PredType, which is opaque
451 -- to the desugarer. (Why opaque? Because newtypes have to be. Why
452 -- does it get that type? So that when we abstract over it we get the
453 -- right top-level type (?i::Int) => ...)
455 -- So to get the type of 'v', use the pattern not the rhs. Often more
457 val_var <- newSysLocalDs (hsLPatType pat)
459 -- For the error message we make one error-app, to avoid duplication.
460 -- But we need it at different types... so we use coerce for that
461 err_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID unitTy (showSDoc (ppr pat))
462 err_var <- newSysLocalDs unitTy
463 binds <- mapM (mk_bind val_var err_var) binders
464 return ( (val_var, val_expr) :
465 (err_var, err_expr) :
470 error_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID tuple_ty (showSDoc (ppr pat))
471 tuple_expr <- matchSimply val_expr PatBindRhs pat local_tuple error_expr
472 tuple_var <- newSysLocalDs tuple_ty
475 = (binder, mkTupleSelector binders binder tuple_var (Var tuple_var))
476 return ( (tuple_var, tuple_expr) : map mk_tup_bind binders )
478 binders = collectPatBinders pat
479 local_tuple = mkBigCoreVarTup binders
480 tuple_ty = exprType local_tuple
482 mk_bind scrut_var err_var bndr_var = do
483 -- (mk_bind sv err_var) generates
484 -- bv = case sv of { pat -> bv; other -> coerce (type-of-bv) err_var }
485 -- Remember, pat binds bv
486 rhs_expr <- matchSimply (Var scrut_var) PatBindRhs pat
487 (Var bndr_var) error_expr
488 return (bndr_var, rhs_expr)
490 error_expr = mkCoerce co (Var err_var)
491 co = mkUnsafeCoercion (exprType (Var err_var)) (idType bndr_var)
493 is_simple_lpat p = is_simple_pat (unLoc p)
495 is_simple_pat (TuplePat ps Boxed _) = all is_triv_lpat ps
496 is_simple_pat (ConPatOut{ pat_args = ps }) = all is_triv_lpat (hsConPatArgs ps)
497 is_simple_pat (VarPat _) = True
498 is_simple_pat (ParPat p) = is_simple_lpat p
499 is_simple_pat _ = False
501 is_triv_lpat p = is_triv_pat (unLoc p)
503 is_triv_pat (VarPat _) = True
504 is_triv_pat (WildPat _) = True
505 is_triv_pat (ParPat p) = is_triv_lpat p
506 is_triv_pat _ = False
510 Creating tuples and their types for full Haskell expressions
514 -- Smart constructors for source tuple expressions
515 mkLHsVarTup :: [Id] -> LHsExpr Id
516 mkLHsVarTup ids = mkLHsTup (map nlHsVar ids)
518 mkLHsTup :: [LHsExpr Id] -> LHsExpr Id
519 mkLHsTup [] = nlHsVar unitDataConId
520 mkLHsTup [lexp] = lexp
521 mkLHsTup lexps = L (getLoc (head lexps)) $
522 ExplicitTuple lexps Boxed
524 -- Smart constructors for source tuple patterns
525 mkLHsVarPatTup :: [Id] -> LPat Id
526 mkLHsVarPatTup bs = mkLHsPatTup (map nlVarPat bs)
528 mkLHsPatTup :: [LPat Id] -> LPat Id
529 mkLHsPatTup [] = noLoc $ mkVanillaTuplePat [] Boxed
530 mkLHsPatTup [lpat] = lpat
531 mkLHsPatTup lpats = L (getLoc (head lpats)) $
532 mkVanillaTuplePat lpats Boxed
534 -- The Big equivalents for the source tuple expressions
535 mkBigLHsVarTup :: [Id] -> LHsExpr Id
536 mkBigLHsVarTup ids = mkBigLHsTup (map nlHsVar ids)
538 mkBigLHsTup :: [LHsExpr Id] -> LHsExpr Id
539 mkBigLHsTup = mkChunkified mkLHsTup
542 -- The Big equivalents for the source tuple patterns
543 mkBigLHsVarPatTup :: [Id] -> LPat Id
544 mkBigLHsVarPatTup bs = mkBigLHsPatTup (map nlVarPat bs)
546 mkBigLHsPatTup :: [LPat Id] -> LPat Id
547 mkBigLHsPatTup = mkChunkified mkLHsPatTup
550 %************************************************************************
552 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
554 %************************************************************************
556 Generally, we handle pattern matching failure like this: let-bind a
557 fail-variable, and use that variable if the thing fails:
559 let fail.33 = error "Help"
570 If the case can't fail, then there'll be no mention of @fail.33@, and the
571 simplifier will later discard it.
574 If it can fail in only one way, then the simplifier will inline it.
577 Only if it is used more than once will the let-binding remain.
580 There's a problem when the result of the case expression is of
581 unboxed type. Then the type of @fail.33@ is unboxed too, and
582 there is every chance that someone will change the let into a case:
588 which is of course utterly wrong. Rather than drop the condition that
589 only boxed types can be let-bound, we just turn the fail into a function
590 for the primitive case:
592 let fail.33 :: Void -> Int#
593 fail.33 = \_ -> error "Help"
602 Now @fail.33@ is a function, so it can be let-bound.
605 mkFailurePair :: CoreExpr -- Result type of the whole case expression
606 -> DsM (CoreBind, -- Binds the newly-created fail variable
607 -- to either the expression or \ _ -> expression
608 CoreExpr) -- Either the fail variable, or fail variable
609 -- applied to unit tuple
611 | isUnLiftedType ty = do
612 fail_fun_var <- newFailLocalDs (unitTy `mkFunTy` ty)
613 fail_fun_arg <- newSysLocalDs unitTy
614 return (NonRec fail_fun_var (Lam fail_fun_arg expr),
615 App (Var fail_fun_var) (Var unitDataConId))
618 fail_var <- newFailLocalDs ty
619 return (NonRec fail_var expr, Var fail_var)
625 mkOptTickBox :: Maybe (Int,[Id]) -> CoreExpr -> DsM CoreExpr
626 mkOptTickBox Nothing e = return e
627 mkOptTickBox (Just (ix,ids)) e = mkTickBox ix ids e
629 mkTickBox :: Int -> [Id] -> CoreExpr -> DsM CoreExpr
630 mkTickBox ix vars e = do
633 let tick | opt_Hpc = mkTickBoxOpId uq mod ix
634 | otherwise = mkBreakPointOpId uq mod ix
636 let occName = mkVarOcc "tick"
637 let name = mkInternalName uq2 occName noSrcSpan -- use mkSysLocal?
638 let var = Id.mkLocalId name realWorldStatePrimTy
641 then return (Var tick)
643 let tickVar = Var tick
644 let tickType = mkFunTys (map idType vars) realWorldStatePrimTy
645 let scrutApTy = App tickVar (Type tickType)
646 return (mkApps scrutApTy (map Var vars) :: Expr Id)
647 return $ Case scrut var ty [(DEFAULT,[],e)]
651 mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr
652 mkBinaryTickBox ixT ixF e = do
654 let bndr1 = mkSysLocal (fsLit "t1") uq boolTy
655 falseBox <- mkTickBox ixF [] $ Var falseDataConId
656 trueBox <- mkTickBox ixT [] $ Var trueDataConId
657 return $ Case e bndr1 boolTy
658 [ (DataAlt falseDataCon, [], falseBox)
659 , (DataAlt trueDataCon, [], trueBox)