2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[DsUtils]{Utilities for desugaring}
6 This module exports some utility functions of no great interest.
9 #include "HsVersions.h"
12 CanItFail(..), EquationInfo(..), MatchResult(..),
14 combineGRHSMatchResults,
17 mkCoAlgCaseMatchResult,
18 mkAppDs, mkConDs, mkPrimDs, mkErrorAppDs,
20 mkCoPrimCaseMatchResult,
31 import DsLoop ( match, matchSimply )
33 import HsSyn ( HsExpr(..), OutPat(..), HsLit(..),
34 Match, HsBinds, Stmt, Qual, PolyType, ArithSeqInfo )
35 import TcHsSyn ( TypecheckedPat(..) )
36 import DsHsSyn ( outPatType )
41 import CoreUtils ( coreExprType, mkCoreIfThenElse )
42 import PprStyle ( PprStyle(..) )
43 import PrelInfo ( stringTy, iRREFUT_PAT_ERROR_ID )
44 import Pretty ( ppShow )
45 import Id ( idType, dataConArgTys, mkTupleCon,
46 DataCon(..), DictVar(..), Id(..), GenId )
47 import Literal ( Literal(..) )
48 import TyCon ( mkTupleTyCon )
49 import Type ( mkTyVarTys, mkRhoTy, mkForAllTys, mkFunTys,
50 isUnboxedType, applyTyCon, getAppDataTyCon
52 import UniqSet ( mkUniqSet, minusUniqSet, uniqSetToList, UniqSet(..) )
53 import Util ( panic, assertPanic )
55 splitDictType = panic "DsUtils.splitDictType"
58 %************************************************************************
60 %* type synonym EquationInfo and access functions for its pieces *
62 %************************************************************************
63 \subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym}
65 The ``equation info'' used by @match@ is relatively complicated and
66 worthy of a type synonym and a few handy functions.
71 [TypecheckedPat] -- the patterns for an eqn
72 MatchResult -- Encapsulates the guards and bindings
79 Type -- Type of argument expression
81 (CoreExpr -> CoreExpr)
82 -- Takes a expression to plug in at the
83 -- failure point(s). The expression should
86 DsMatchContext -- The context info is used when producing warnings
87 -- about shadowed patterns. It's the context
88 -- of the *first* thing matched in this group.
89 -- Should perhaps be a list of them all!
91 data CanItFail = CanFail | CantFail
93 orFail CantFail CantFail = CantFail
97 mkCoLetsMatchResult :: [CoreBinding] -> MatchResult -> MatchResult
98 mkCoLetsMatchResult binds (MatchResult can_it_fail ty body_fn cxt)
99 = MatchResult can_it_fail ty (\body -> mkCoLetsAny binds (body_fn body)) cxt
101 mkGuardedMatchResult :: CoreExpr -> MatchResult -> DsM MatchResult
102 mkGuardedMatchResult pred_expr (MatchResult can_it_fail ty body_fn cxt)
103 = returnDs (MatchResult CanFail
105 (\fail -> mkCoreIfThenElse pred_expr (body_fn fail) fail)
109 mkCoPrimCaseMatchResult :: Id -- Scrutinee
110 -> [(Literal, MatchResult)] -- Alternatives
112 mkCoPrimCaseMatchResult var alts
113 = newSysLocalDs (idType var) `thenDs` \ wild ->
114 returnDs (MatchResult CanFail
119 ((_,MatchResult _ ty1 _ cxt1) : _) = alts
121 mk_case alts wild fail_expr
122 = Case (Var var) (PrimAlts final_alts (BindDefault wild fail_expr))
124 final_alts = [ (lit, body_fn fail_expr)
125 | (lit, MatchResult _ _ body_fn _) <- alts
129 mkCoAlgCaseMatchResult :: Id -- Scrutinee
130 -> [(DataCon, [Id], MatchResult)] -- Alternatives
132 mkCoAlgCaseMatchResult var alts
133 = -- Find all the constructors in the type which aren't
134 -- explicitly mentioned in the alternatives:
135 case un_mentioned_constructors of
136 [] -> -- All constructors mentioned, so no default needed
137 returnDs (MatchResult can_any_alt_fail
139 (mk_case alts (\ignore -> NoDefault))
142 [con] -> -- Just one constructor missing, so add a case for it
143 -- We need to build new locals for the args of the constructor,
144 -- and figuring out their types is somewhat tiresome.
146 arg_tys = dataConArgTys con tycon_arg_tys
148 newSysLocalsDs arg_tys `thenDs` \ arg_ids ->
150 -- Now we are ready to construct the new alternative
152 new_alt = (con, arg_ids, MatchResult CanFail ty1 id NoMatchContext)
154 returnDs (MatchResult CanFail
156 (mk_case (new_alt:alts) (\ignore -> NoDefault))
159 other -> -- Many constructors missing, so use a default case
160 newSysLocalDs scrut_ty `thenDs` \ wild ->
161 returnDs (MatchResult CanFail
163 (mk_case alts (\fail_expr -> BindDefault wild fail_expr))
166 scrut_ty = idType var
167 (tycon, tycon_arg_tys, data_cons) = getAppDataTyCon scrut_ty
169 un_mentioned_constructors
170 = uniqSetToList (mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- alts] )
172 match_results = [match_result | (_,_,match_result) <- alts]
173 (MatchResult _ ty1 _ cxt1 : _) = match_results
174 can_any_alt_fail = foldr1 orFail [can_it_fail | MatchResult can_it_fail _ _ _ <- match_results]
176 mk_case alts deflt_fn fail_expr
177 = Case (Var var) (AlgAlts final_alts (deflt_fn fail_expr))
179 final_alts = [ (con, args, body_fn fail_expr)
180 | (con, args, MatchResult _ _ body_fn _) <- alts
184 combineMatchResults :: MatchResult -> MatchResult -> DsM MatchResult
185 combineMatchResults (MatchResult CanFail ty1 body_fn1 cxt1)
186 (MatchResult can_it_fail2 ty2 body_fn2 cxt2)
187 = mkFailurePair ty1 `thenDs` \ (bind_fn, duplicatable_expr) ->
189 new_body_fn1 = \body1 -> Let (bind_fn body1) (body_fn1 duplicatable_expr)
190 new_body_fn2 = \body2 -> new_body_fn1 (body_fn2 body2)
192 returnDs (MatchResult can_it_fail2 ty1 new_body_fn2 cxt1)
194 combineMatchResults match_result1@(MatchResult CantFail ty body_fn1 cxt1)
196 = returnDs match_result1
199 -- The difference in combineGRHSMatchResults is that there is no
200 -- need to let-bind to avoid code duplication
201 combineGRHSMatchResults :: MatchResult -> MatchResult -> DsM MatchResult
202 combineGRHSMatchResults (MatchResult CanFail ty1 body_fn1 cxt1)
203 (MatchResult can_it_fail ty2 body_fn2 cxt2)
204 = returnDs (MatchResult can_it_fail ty1 (\ body -> body_fn1 (body_fn2 body)) cxt1)
206 combineGRHSMatchResults match_result1 match_result2
207 = -- Delegate to avoid duplication of code
208 combineMatchResults match_result1 match_result2
211 %************************************************************************
213 \subsection[dsExprToAtom]{Take an expression and produce an atom}
215 %************************************************************************
218 dsExprToAtom :: CoreExpr -- The argument expression
219 -> (CoreArg -> DsM CoreExpr) -- Something taking the argument *atom*,
220 -- and delivering an expression E
221 -> DsM CoreExpr -- Either E or let x=arg-expr in E
223 dsExprToAtom (Var v) continue_with = continue_with (VarArg v)
224 dsExprToAtom (Lit v) continue_with = continue_with (LitArg v)
226 dsExprToAtom arg_expr continue_with
228 ty = coreExprType arg_expr
230 newSysLocalDs ty `thenDs` \ arg_id ->
231 continue_with (VarArg arg_id) `thenDs` \ body ->
234 then Case arg_expr (PrimAlts [] (BindDefault arg_id body))
235 else Let (NonRec arg_id arg_expr) body
238 dsExprsToAtoms :: [CoreExpr]
239 -> ([CoreArg] -> DsM CoreExpr)
242 dsExprsToAtoms [] continue_with
245 dsExprsToAtoms (arg:args) continue_with
246 = dsExprToAtom arg $ \ arg_atom ->
247 dsExprsToAtoms args $ \ arg_atoms ->
248 continue_with (arg_atom:arg_atoms)
251 %************************************************************************
253 \subsection{Desugarer's versions of some Core functions}
255 %************************************************************************
258 mkAppDs :: CoreExpr -> [Type] -> [CoreExpr] -> DsM CoreExpr
259 mkConDs :: Id -> [Type] -> [CoreExpr] -> DsM CoreExpr
260 mkPrimDs :: PrimOp -> [Type] -> [CoreExpr] -> DsM CoreExpr
262 mkAppDs fun tys arg_exprs
263 = dsExprsToAtoms arg_exprs $ \ vals ->
264 returnDs (mkApp fun [] tys vals)
266 mkConDs con tys arg_exprs
267 = dsExprsToAtoms arg_exprs $ \ vals ->
268 returnDs (mkCon con [] tys vals)
270 mkPrimDs op tys arg_exprs
271 = dsExprsToAtoms arg_exprs $ \ vals ->
272 returnDs (mkPrim op [] tys vals)
276 showForErr :: Outputable a => a -> String -- Boring but useful
277 showForErr thing = ppShow 80 (ppr PprForUser thing)
279 mkErrorAppDs :: Id -- The error function
280 -> Type -- Type to which it should be applied
281 -> String -- The error message string to pass
284 mkErrorAppDs err_id ty msg
285 = getSrcLocDs `thenDs` \ (file, line) ->
287 full_msg = file ++ "|" ++ line ++ "|" ++msg
288 msg_lit = NoRepStr (_PK_ full_msg)
290 returnDs (mkApp (Var err_id) [] [ty] [LitArg msg_lit])
293 %************************************************************************
295 \subsection[mkSelectorBind]{Make a selector bind}
297 %************************************************************************
299 This is used in various places to do with lazy patterns.
300 For each binder $b$ in the pattern, we create a binding:
302 b = case v of pat' -> b'
304 where pat' is pat with each binder b cloned into b'.
306 ToDo: making these bindings should really depend on whether there's
307 much work to be done per binding. If the pattern is complex, it
308 should be de-mangled once, into a tuple (and then selected from).
309 Otherwise the demangling can be in-line in the bindings (as here).
311 Boring! Boring! One error message per binder. The above ToDo is
312 even more helpful. Something very similar happens for pattern-bound
316 mkSelectorBinds :: [TyVar] -- Variables wrt which the pattern is polymorphic
317 -> TypecheckedPat -- The pattern
318 -> [(Id,Id)] -- Monomorphic and polymorphic binders for
320 -> CoreExpr -- Expression to which the pattern is bound
321 -> DsM [(Id,CoreExpr)]
323 mkSelectorBinds tyvars pat locals_and_globals val_expr
324 = if is_simple_tuple_pat pat then
325 mkTupleBind tyvars [] locals_and_globals val_expr
327 mkErrorAppDs iRREFUT_PAT_ERROR_ID res_ty "" `thenDs` \ error_msg ->
328 matchSimply val_expr pat res_ty local_tuple error_msg `thenDs` \ tuple_expr ->
329 mkTupleBind tyvars [] locals_and_globals tuple_expr
331 locals = [local | (local, _) <- locals_and_globals]
332 local_tuple = mkTupleExpr locals
333 res_ty = coreExprType local_tuple
335 is_simple_tuple_pat (TuplePat ps) = all is_var_pat ps
336 is_simple_tuple_pat other = False
338 is_var_pat (VarPat v) = True
339 is_var_pat other = False -- Even wild-card patterns aren't acceptable
342 We're about to match against some patterns. We want to make some
343 @Ids@ to use as match variables. If a pattern has an @Id@ readily at
344 hand, which should indeed be bound to the pattern as a whole, then use it;
345 otherwise, make one up.
347 selectMatchVars :: [TypecheckedPat] -> DsM [Id]
349 = mapDs var_from_pat_maybe pats
351 var_from_pat_maybe (VarPat var) = returnDs var
352 var_from_pat_maybe (AsPat var pat) = returnDs var
353 var_from_pat_maybe (LazyPat pat) = var_from_pat_maybe pat
354 var_from_pat_maybe other_pat
355 = newSysLocalDs (outPatType other_pat) -- OK, better make up one...
359 mkTupleBind :: [TyVar] -- Abstract wrt these...
360 -> [DictVar] -- ... and these
362 -> [(Id, Id)] -- Local, global pairs, equal in number
363 -- to the size of the tuple. The types
364 -- of the globals is the generalisation of
365 -- the corresp local, wrt the tyvars and dicts
367 -> CoreExpr -- Expr whose value is a tuple; the expression
368 -- may mention the tyvars and dicts
370 -> DsM [(Id, CoreExpr)] -- Bindings for the globals
375 mkTupleBind tyvars dicts [(l1,g1), ..., (ln,gn)] tup_expr
377 If $n=1$, the result is:
379 g1 = /\ tyvars -> \ dicts -> rhs
381 Otherwise, the result is:
383 tup = /\ tyvars -> \ dicts -> tup_expr
384 g1 = /\ tyvars -> \ dicts -> case (tup tyvars dicts) of
390 mkTupleBind tyvars dicts [(local,global)] tuple_expr
391 = returnDs [(global, mkLam tyvars dicts tuple_expr)]
397 mkTupleBind tyvars dicts local_global_prs tuple_expr
398 = newSysLocalDs tuple_var_ty `thenDs` \ tuple_var ->
400 zipWithDs (mk_selector (Var tuple_var))
402 [(0::Int) .. (length local_global_prs - 1)]
403 `thenDs` \ tup_selectors ->
405 (tuple_var, mkLam tyvars dicts tuple_expr)
409 locals, globals :: [Id]
410 locals = [local | (local,global) <- local_global_prs]
411 globals = [global | (local,global) <- local_global_prs]
413 no_of_binders = length local_global_prs
414 tyvar_tys = mkTyVarTys tyvars
418 = mkForAllTys tyvars $
420 applyTyCon (mkTupleTyCon no_of_binders)
423 theta = map (splitDictType . idType) dicts
425 mk_selector :: CoreExpr -> (Id, Id) -> Int -> DsM (Id, CoreExpr)
427 mk_selector tuple_var_expr (local, global) which_local
428 = mapDs duplicateLocalDs locals{-the whole bunch-} `thenDs` \ binders ->
430 selected = binders !! which_local
436 (mkValApp (mkTyApp tuple_var_expr tyvar_tys)
443 @mkTupleExpr@ builds a tuple; the inverse to @mkTupleSelector@. If it
444 has only one element, it is the identity function.
446 mkTupleExpr :: [Id] -> CoreExpr
448 mkTupleExpr [] = Con (mkTupleCon 0) []
449 mkTupleExpr [id] = Var id
450 mkTupleExpr ids = mkCon (mkTupleCon (length ids))
453 [ VarArg i | i <- ids ]
457 @mkTupleSelector@ builds a selector which scrutises the given
458 expression and extracts the one name from the list given.
459 If you want the no-shadowing rule to apply, the caller
460 is responsible for making sure that none of these names
463 If there is just one id in the ``tuple'', then the selector is
467 mkTupleSelector :: CoreExpr -- Scrutinee
468 -> [Id] -- The tuple args
469 -> Id -- The selected one
472 mkTupleSelector expr [] the_var = panic "mkTupleSelector"
474 mkTupleSelector expr [var] should_be_the_same_var
475 = ASSERT(var == should_be_the_same_var)
478 mkTupleSelector expr vars the_var
479 = Case expr (AlgAlts [(mkTupleCon arity, vars, Var the_var)]
486 %************************************************************************
488 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
490 %************************************************************************
492 Generally, we handle pattern matching failure like this: let-bind a
493 fail-variable, and use that variable if the thing fails:
495 let fail.33 = error "Help"
506 If the case can't fail, then there'll be no mention of fail.33, and the
507 simplifier will later discard it.
510 If it can fail in only one way, then the simplifier will inline it.
513 Only if it is used more than once will the let-binding remain.
516 There's a problem when the result of the case expression is of
517 unboxed type. Then the type of fail.33 is unboxed too, and
518 there is every chance that someone will change the let into a case:
524 which is of course utterly wrong. Rather than drop the condition that
525 only boxed types can be let-bound, we just turn the fail into a function
526 for the primitive case:
528 let fail.33 :: () -> Int#
529 fail.33 = \_ -> error "Help"
538 Now fail.33 is a function, so it can be let-bound.
541 mkFailurePair :: Type -- Result type of the whole case expression
542 -> DsM (CoreExpr -> CoreBinding,
543 -- Binds the newly-created fail variable
544 -- to either the expression or \ _ -> expression
545 CoreExpr) -- Either the fail variable, or fail variable
546 -- applied to unit tuple
549 = newFailLocalDs (mkFunTys [unit_ty] ty) `thenDs` \ fail_fun_var ->
550 newSysLocalDs unit_ty `thenDs` \ fail_fun_arg ->
552 NonRec fail_fun_var (Lam (ValBinder fail_fun_arg) body),
553 App (Var fail_fun_var) (VarArg unit_id))
556 = newFailLocalDs ty `thenDs` \ fail_var ->
557 returnDs (\ body -> NonRec fail_var body, Var fail_var)
559 unit_id :: Id -- out here to avoid CAF (sigh)
560 unit_id = mkTupleCon 0
563 unit_ty = idType unit_id