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 sorted_alts = sortWith get_tag match_alts
305 get_tag (con, _, _) = dataConTag con
306 mk_case fail = do alts <- mapM (mk_alt fail) sorted_alts
307 return (mkWildCase (Var var) (idType var) ty (mk_default fail ++ alts))
309 mk_alt fail (con, args, MatchResult _ body_fn) = do
311 us <- newUniqueSupply
312 return (mkReboxingAlt (uniqsFromSupply us) con args body)
314 mk_default fail | exhaustive_case = []
315 | otherwise = [(DEFAULT, [], fail)]
317 un_mentioned_constructors
318 = mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- match_alts]
319 exhaustive_case = isEmptyUniqSet un_mentioned_constructors
321 -- Stuff for parallel arrays
323 -- * the following is to desugar cases over fake constructors for
324 -- parallel arrays, which are introduced by `tidy1' in the `PArrPat'
327 -- Concerning `isPArrFakeAlts':
329 -- * it is *not* sufficient to just check the type of the type
330 -- constructor, as we have to be careful not to confuse the real
331 -- representation of parallel arrays with the fake constructors;
332 -- moreover, a list of alternatives must not mix fake and real
333 -- constructors (this is checked earlier on)
335 -- FIXME: We actually go through the whole list and make sure that
336 -- either all or none of the constructors are fake parallel
337 -- array constructors. This is to spot equations that mix fake
338 -- constructors with the real representation defined in
339 -- `PrelPArr'. It would be nicer to spot this situation
340 -- earlier and raise a proper error message, but it can really
341 -- only happen in `PrelPArr' anyway.
343 isPArrFakeAlts [(dcon, _, _)] = isPArrFakeCon dcon
344 isPArrFakeAlts ((dcon, _, _):alts) =
345 case (isPArrFakeCon dcon, isPArrFakeAlts alts) of
346 (True , True ) -> True
347 (False, False) -> False
348 _ -> panic "DsUtils: you may not mix `[:...:]' with `PArr' patterns"
349 isPArrFakeAlts [] = panic "DsUtils: unexpectedly found an empty list of PArr fake alternatives"
351 mk_parrCase fail = do
352 lengthP <- dsLookupGlobalId lengthPName
354 return (mkWildCase (len lengthP) intTy ty [alt])
356 elemTy = case splitTyConApp (idType var) of
357 (_, [elemTy]) -> elemTy
359 panicMsg = "DsUtils.mkCoAlgCaseMatchResult: not a parallel array?"
360 len lengthP = mkApps (Var lengthP) [Type elemTy, Var var]
363 l <- newSysLocalDs intPrimTy
364 indexP <- dsLookupGlobalId indexPName
365 alts <- mapM (mkAlt indexP) sorted_alts
366 return (DataAlt intDataCon, [l], mkWildCase (Var l) intPrimTy ty (dft : alts))
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)