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, mkFunTys, isUnboxedType,
50 applyTyCon, getAppDataTyCon
52 import UniqSet ( mkUniqSet, minusUniqSet, uniqSetToList, UniqSet(..) )
53 import Util ( panic, assertPanic )
55 quantifyTy = panic "DsUtils.quantifyTy"
56 splitDictType = panic "DsUtils.splitDictType"
57 mkCoTyApps = panic "DsUtils.mkCoTyApps"
60 %************************************************************************
62 %* type synonym EquationInfo and access functions for its pieces *
64 %************************************************************************
65 \subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym}
67 The ``equation info'' used by @match@ is relatively complicated and
68 worthy of a type synonym and a few handy functions.
73 [TypecheckedPat] -- the patterns for an eqn
74 MatchResult -- Encapsulates the guards and bindings
81 Type -- Type of argument expression
83 (CoreExpr -> CoreExpr)
84 -- Takes a expression to plug in at the
85 -- failure point(s). The expression should
88 DsMatchContext -- The context info is used when producing warnings
89 -- about shadowed patterns. It's the context
90 -- of the *first* thing matched in this group.
91 -- Should perhaps be a list of them all!
93 data CanItFail = CanFail | CantFail
95 orFail CantFail CantFail = CantFail
99 mkCoLetsMatchResult :: [CoreBinding] -> MatchResult -> MatchResult
100 mkCoLetsMatchResult binds (MatchResult can_it_fail ty body_fn cxt)
101 = MatchResult can_it_fail ty (\body -> mkCoLetsAny binds (body_fn body)) cxt
103 mkGuardedMatchResult :: CoreExpr -> MatchResult -> DsM MatchResult
104 mkGuardedMatchResult pred_expr (MatchResult can_it_fail ty body_fn cxt)
105 = returnDs (MatchResult CanFail
107 (\fail -> mkCoreIfThenElse pred_expr (body_fn fail) fail)
111 mkCoPrimCaseMatchResult :: Id -- Scrutinee
112 -> [(Literal, MatchResult)] -- Alternatives
114 mkCoPrimCaseMatchResult var alts
115 = newSysLocalDs (idType var) `thenDs` \ wild ->
116 returnDs (MatchResult CanFail
121 ((_,MatchResult _ ty1 _ cxt1) : _) = alts
123 mk_case alts wild fail_expr
124 = Case (Var var) (PrimAlts final_alts (BindDefault wild fail_expr))
126 final_alts = [ (lit, body_fn fail_expr)
127 | (lit, MatchResult _ _ body_fn _) <- alts
131 mkCoAlgCaseMatchResult :: Id -- Scrutinee
132 -> [(DataCon, [Id], MatchResult)] -- Alternatives
134 mkCoAlgCaseMatchResult var alts
135 = -- Find all the constructors in the type which aren't
136 -- explicitly mentioned in the alternatives:
137 case un_mentioned_constructors of
138 [] -> -- All constructors mentioned, so no default needed
139 returnDs (MatchResult can_any_alt_fail
141 (mk_case alts (\ignore -> NoDefault))
144 [con] -> -- Just one constructor missing, so add a case for it
145 -- We need to build new locals for the args of the constructor,
146 -- and figuring out their types is somewhat tiresome.
148 arg_tys = dataConArgTys con tycon_arg_tys
150 newSysLocalsDs arg_tys `thenDs` \ arg_ids ->
152 -- Now we are ready to construct the new alternative
154 new_alt = (con, arg_ids, MatchResult CanFail ty1 id NoMatchContext)
156 returnDs (MatchResult CanFail
158 (mk_case (new_alt:alts) (\ignore -> NoDefault))
161 other -> -- Many constructors missing, so use a default case
162 newSysLocalDs scrut_ty `thenDs` \ wild ->
163 returnDs (MatchResult CanFail
165 (mk_case alts (\fail_expr -> BindDefault wild fail_expr))
168 scrut_ty = idType var
169 (tycon, tycon_arg_tys, data_cons) = getAppDataTyCon scrut_ty
171 un_mentioned_constructors
172 = uniqSetToList (mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- alts] )
174 match_results = [match_result | (_,_,match_result) <- alts]
175 (MatchResult _ ty1 _ cxt1 : _) = match_results
176 can_any_alt_fail = foldr1 orFail [can_it_fail | MatchResult can_it_fail _ _ _ <- match_results]
178 mk_case alts deflt_fn fail_expr
179 = Case (Var var) (AlgAlts final_alts (deflt_fn fail_expr))
181 final_alts = [ (con, args, body_fn fail_expr)
182 | (con, args, MatchResult _ _ body_fn _) <- alts
186 combineMatchResults :: MatchResult -> MatchResult -> DsM MatchResult
187 combineMatchResults (MatchResult CanFail ty1 body_fn1 cxt1)
188 (MatchResult can_it_fail2 ty2 body_fn2 cxt2)
189 = mkFailurePair ty1 `thenDs` \ (bind_fn, duplicatable_expr) ->
191 new_body_fn1 = \body1 -> Let (bind_fn body1) (body_fn1 duplicatable_expr)
192 new_body_fn2 = \body2 -> new_body_fn1 (body_fn2 body2)
194 returnDs (MatchResult can_it_fail2 ty1 new_body_fn2 cxt1)
196 combineMatchResults match_result1@(MatchResult CantFail ty body_fn1 cxt1)
198 = returnDs match_result1
201 -- The difference in combineGRHSMatchResults is that there is no
202 -- need to let-bind to avoid code duplication
203 combineGRHSMatchResults :: MatchResult -> MatchResult -> DsM MatchResult
204 combineGRHSMatchResults (MatchResult CanFail ty1 body_fn1 cxt1)
205 (MatchResult can_it_fail ty2 body_fn2 cxt2)
206 = returnDs (MatchResult can_it_fail ty1 (\ body -> body_fn1 (body_fn2 body)) cxt1)
208 combineGRHSMatchResults match_result1 match_result2
209 = -- Delegate to avoid duplication of code
210 combineMatchResults match_result1 match_result2
213 %************************************************************************
215 \subsection[dsExprToAtom]{Take an expression and produce an atom}
217 %************************************************************************
220 dsExprToAtom :: CoreExpr -- The argument expression
221 -> (CoreArg -> DsM CoreExpr) -- Something taking the argument *atom*,
222 -- and delivering an expression E
223 -> DsM CoreExpr -- Either E or let x=arg-expr in E
225 dsExprToAtom (Var v) continue_with = continue_with (VarArg v)
226 dsExprToAtom (Lit v) continue_with = continue_with (LitArg v)
228 dsExprToAtom arg_expr continue_with
230 ty = coreExprType arg_expr
232 newSysLocalDs ty `thenDs` \ arg_id ->
233 continue_with (VarArg arg_id) `thenDs` \ body ->
236 then Case arg_expr (PrimAlts [] (BindDefault arg_id body))
237 else Let (NonRec arg_id arg_expr) body
240 dsExprsToAtoms :: [CoreExpr]
241 -> ([CoreArg] -> DsM CoreExpr)
244 dsExprsToAtoms [] continue_with
247 dsExprsToAtoms (arg:args) continue_with
248 = dsExprToAtom arg $ \ arg_atom ->
249 dsExprsToAtoms args $ \ arg_atoms ->
250 continue_with (arg_atom:arg_atoms)
253 %************************************************************************
255 \subsection{Desugarer's versions of some Core functions}
257 %************************************************************************
260 mkAppDs :: CoreExpr -> [Type] -> [CoreExpr] -> DsM CoreExpr
261 mkConDs :: Id -> [Type] -> [CoreExpr] -> DsM CoreExpr
262 mkPrimDs :: PrimOp -> [Type] -> [CoreExpr] -> DsM CoreExpr
264 mkAppDs fun tys arg_exprs
265 = dsExprsToAtoms arg_exprs $ \ vals ->
266 returnDs (mkApp fun [] tys vals)
268 mkConDs con tys arg_exprs
269 = dsExprsToAtoms arg_exprs $ \ vals ->
270 returnDs (mkCon con [] tys vals)
272 mkPrimDs op tys arg_exprs
273 = dsExprsToAtoms arg_exprs $ \ vals ->
274 returnDs (mkPrim op [] tys vals)
278 showForErr :: Outputable a => a -> String -- Boring but useful
279 showForErr thing = ppShow 80 (ppr PprForUser thing)
281 mkErrorAppDs :: Id -- The error function
282 -> Type -- Type to which it should be applied
283 -> String -- The error message string to pass
286 mkErrorAppDs err_id ty msg
287 = getSrcLocDs `thenDs` \ (file, line) ->
289 full_msg = file ++ "|" ++ line ++ "|" ++msg
290 msg_lit = NoRepStr (_PK_ full_msg)
292 returnDs (mkApp (Var err_id) [] [ty] [LitArg msg_lit])
295 %************************************************************************
297 \subsection[mkSelectorBind]{Make a selector bind}
299 %************************************************************************
301 This is used in various places to do with lazy patterns.
302 For each binder $b$ in the pattern, we create a binding:
304 b = case v of pat' -> b'
306 where pat' is pat with each binder b cloned into b'.
308 ToDo: making these bindings should really depend on whether there's
309 much work to be done per binding. If the pattern is complex, it
310 should be de-mangled once, into a tuple (and then selected from).
311 Otherwise the demangling can be in-line in the bindings (as here).
313 Boring! Boring! One error message per binder. The above ToDo is
314 even more helpful. Something very similar happens for pattern-bound
318 mkSelectorBinds :: [TyVar] -- Variables wrt which the pattern is polymorphic
319 -> TypecheckedPat -- The pattern
320 -> [(Id,Id)] -- Monomorphic and polymorphic binders for
322 -> CoreExpr -- Expression to which the pattern is bound
323 -> DsM [(Id,CoreExpr)]
325 mkSelectorBinds tyvars pat locals_and_globals val_expr
326 = if is_simple_tuple_pat pat then
327 mkTupleBind tyvars [] locals_and_globals val_expr
329 mkErrorAppDs iRREFUT_PAT_ERROR_ID res_ty "" `thenDs` \ error_msg ->
330 matchSimply val_expr pat res_ty local_tuple error_msg `thenDs` \ tuple_expr ->
331 mkTupleBind tyvars [] locals_and_globals tuple_expr
333 locals = [local | (local, _) <- locals_and_globals]
334 local_tuple = mkTupleExpr locals
335 res_ty = coreExprType local_tuple
337 is_simple_tuple_pat (TuplePat ps) = all is_var_pat ps
338 is_simple_tuple_pat other = False
340 is_var_pat (VarPat v) = True
341 is_var_pat other = False -- Even wild-card patterns aren't acceptable
344 We're about to match against some patterns. We want to make some
345 @Ids@ to use as match variables. If a pattern has an @Id@ readily at
346 hand, which should indeed be bound to the pattern as a whole, then use it;
347 otherwise, make one up.
349 selectMatchVars :: [TypecheckedPat] -> DsM [Id]
351 = mapDs var_from_pat_maybe pats
353 var_from_pat_maybe (VarPat var) = returnDs var
354 var_from_pat_maybe (AsPat var pat) = returnDs var
355 var_from_pat_maybe (LazyPat pat) = var_from_pat_maybe pat
356 var_from_pat_maybe other_pat
357 = newSysLocalDs (outPatType other_pat) -- OK, better make up one...
361 mkTupleBind :: [TyVar] -- Abstract wrt these...
362 -> [DictVar] -- ... and these
364 -> [(Id, Id)] -- Local, global pairs, equal in number
365 -- to the size of the tuple. The types
366 -- of the globals is the generalisation of
367 -- the corresp local, wrt the tyvars and dicts
369 -> CoreExpr -- Expr whose value is a tuple; the expression
370 -- may mention the tyvars and dicts
372 -> DsM [(Id, CoreExpr)] -- Bindings for the globals
377 mkTupleBind tyvars dicts [(l1,g1), ..., (ln,gn)] tup_expr
379 If $n=1$, the result is:
381 g1 = /\ tyvars -> \ dicts -> rhs
383 Otherwise, the result is:
385 tup = /\ tyvars -> \ dicts -> tup_expr
386 g1 = /\ tyvars -> \ dicts -> case (tup tyvars dicts) of
392 mkTupleBind tyvars dicts [(local,global)] tuple_expr
393 = returnDs [(global, mkLam tyvars dicts tuple_expr)]
399 mkTupleBind tyvars dicts local_global_prs tuple_expr
400 = newSysLocalDs tuple_var_ty `thenDs` \ tuple_var ->
402 zipWithDs (mk_selector (Var tuple_var))
404 [(0::Int) .. (length local_global_prs - 1)]
405 `thenDs` \ tup_selectors ->
407 (tuple_var, mkLam tyvars dicts tuple_expr)
411 locals, globals :: [Id]
412 locals = [local | (local,global) <- local_global_prs]
413 globals = [global | (local,global) <- local_global_prs]
415 no_of_binders = length local_global_prs
416 tyvar_tys = mkTyVarTys tyvars
420 = case (quantifyTy tyvars (mkRhoTy theta
421 (applyTyCon (mkTupleTyCon no_of_binders)
422 (map idType locals)))) of
423 (_{-tossed templates-}, ty) -> ty
425 theta = map (splitDictType . idType) dicts
427 mk_selector :: CoreExpr -> (Id, Id) -> Int -> DsM (Id, CoreExpr)
429 mk_selector tuple_var_expr (local, global) which_local
430 = mapDs duplicateLocalDs locals{-the whole bunch-} `thenDs` \ binders ->
432 selected = binders !! which_local
437 mkTupleSelector (mkApp_XX (mkCoTyApps tuple_var_expr tyvar_tys) dicts)
441 mkApp_XX :: CoreExpr -> [Id] -> CoreExpr
442 mkApp_XX expr [] = expr
443 mkApp_XX expr (id:ids) = mkApp_XX (App expr (VarArg id)) ids
448 @mkTupleExpr@ builds a tuple; the inverse to @mkTupleSelector@. If it
449 has only one element, it is the identity function.
451 mkTupleExpr :: [Id] -> CoreExpr
453 mkTupleExpr [] = Con (mkTupleCon 0) []
454 mkTupleExpr [id] = Var id
455 mkTupleExpr ids = mkCon (mkTupleCon (length ids))
458 [ VarArg i | i <- ids ]
462 @mkTupleSelector@ builds a selector which scrutises the given
463 expression and extracts the one name from the list given.
464 If you want the no-shadowing rule to apply, the caller
465 is responsible for making sure that none of these names
468 If there is just one id in the ``tuple'', then the selector is
472 mkTupleSelector :: CoreExpr -- Scrutinee
473 -> [Id] -- The tuple args
474 -> Id -- The selected one
477 mkTupleSelector expr [] the_var = panic "mkTupleSelector"
479 mkTupleSelector expr [var] should_be_the_same_var
480 = ASSERT(var == should_be_the_same_var)
483 mkTupleSelector expr vars the_var
484 = Case expr (AlgAlts [(mkTupleCon arity, vars, Var the_var)]
491 %************************************************************************
493 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
495 %************************************************************************
497 Generally, we handle pattern matching failure like this: let-bind a
498 fail-variable, and use that variable if the thing fails:
500 let fail.33 = error "Help"
511 If the case can't fail, then there'll be no mention of fail.33, and the
512 simplifier will later discard it.
515 If it can fail in only one way, then the simplifier will inline it.
518 Only if it is used more than once will the let-binding remain.
521 There's a problem when the result of the case expression is of
522 unboxed type. Then the type of fail.33 is unboxed too, and
523 there is every chance that someone will change the let into a case:
529 which is of course utterly wrong. Rather than drop the condition that
530 only boxed types can be let-bound, we just turn the fail into a function
531 for the primitive case:
533 let fail.33 :: () -> Int#
534 fail.33 = \_ -> error "Help"
543 Now fail.33 is a function, so it can be let-bound.
546 mkFailurePair :: Type -- Result type of the whole case expression
547 -> DsM (CoreExpr -> CoreBinding,
548 -- Binds the newly-created fail variable
549 -- to either the expression or \ _ -> expression
550 CoreExpr) -- Either the fail variable, or fail variable
551 -- applied to unit tuple
554 = newFailLocalDs (mkFunTys [unit_ty] ty) `thenDs` \ fail_fun_var ->
555 newSysLocalDs unit_ty `thenDs` \ fail_fun_arg ->
557 NonRec fail_fun_var (Lam (ValBinder fail_fun_arg) body),
558 App (Var fail_fun_var) (VarArg unit_id))
561 = newFailLocalDs ty `thenDs` \ fail_var ->
562 returnDs (\ body -> NonRec fail_var body, Var fail_var)
564 unit_id :: Id -- out here to avoid CAF (sigh)
565 unit_id = mkTupleCon 0
568 unit_ty = idType unit_id