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,
20 mkCoPrimCaseMatchResult,
30 import DsLoop ( match, matchSimply )
32 import HsSyn ( HsExpr(..), OutPat(..), HsLit(..),
33 Match, HsBinds, Stmt, Qual, PolyType, ArithSeqInfo )
34 import TcHsSyn ( TypecheckedPat(..) )
35 import DsHsSyn ( outPatType )
40 import CoreUtils ( coreExprType, escErrorMsg, mkCoreIfThenElse, mkErrorApp )
41 import PrelInfo ( stringTy )
42 import Id ( idType, getInstantiatedDataConSig, mkTupleCon,
43 DataCon(..), DictVar(..), Id(..), GenId )
44 import TyCon ( mkTupleTyCon )
45 import Type ( mkTyVarTys, mkRhoTy, mkFunTys, isUnboxedType,
46 applyTyCon, getAppDataTyCon
48 import UniqSet ( mkUniqSet, minusUniqSet, uniqSetToList, UniqSet(..) )
49 import Util ( panic, assertPanic )
51 quantifyTy = panic "DsUtils.quantifyTy"
52 splitDictType = panic "DsUtils.splitDictType"
53 mkCoTyApps = panic "DsUtils.mkCoTyApps"
56 %************************************************************************
58 %* type synonym EquationInfo and access functions for its pieces *
60 %************************************************************************
61 \subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym}
63 The ``equation info'' used by @match@ is relatively complicated and
64 worthy of a type synonym and a few handy functions.
69 [TypecheckedPat] -- the patterns for an eqn
70 MatchResult -- Encapsulates the guards and bindings
77 Type -- Type of argument expression
79 (CoreExpr -> CoreExpr)
80 -- Takes a expression to plug in at the
81 -- failure point(s). The expression should
84 DsMatchContext -- The context info is used when producing warnings
85 -- about shadowed patterns. It's the context
86 -- of the *first* thing matched in this group.
87 -- Should perhaps be a list of them all!
89 data CanItFail = CanFail | CantFail
91 orFail CantFail CantFail = CantFail
95 mkCoLetsMatchResult :: [CoreBinding] -> MatchResult -> MatchResult
96 mkCoLetsMatchResult binds (MatchResult can_it_fail ty body_fn cxt)
97 = MatchResult can_it_fail ty (\body -> mkCoLetsAny binds (body_fn body)) cxt
99 mkGuardedMatchResult :: CoreExpr -> MatchResult -> DsM MatchResult
100 mkGuardedMatchResult pred_expr (MatchResult can_it_fail ty body_fn cxt)
101 = returnDs (MatchResult CanFail
103 (\fail -> mkCoreIfThenElse pred_expr (body_fn fail) fail)
107 mkCoPrimCaseMatchResult :: Id -- Scrutinee
108 -> [(Literal, MatchResult)] -- Alternatives
110 mkCoPrimCaseMatchResult var alts
111 = newSysLocalDs (idType var) `thenDs` \ wild ->
112 returnDs (MatchResult CanFail
117 ((_,MatchResult _ ty1 _ cxt1) : _) = alts
119 mk_case alts wild fail_expr
120 = Case (Var var) (PrimAlts final_alts (BindDefault wild fail_expr))
122 final_alts = [ (lit, body_fn fail_expr)
123 | (lit, MatchResult _ _ body_fn _) <- alts
127 mkCoAlgCaseMatchResult :: Id -- Scrutinee
128 -> [(DataCon, [Id], MatchResult)] -- Alternatives
130 mkCoAlgCaseMatchResult var alts
131 = -- Find all the constructors in the type which aren't
132 -- explicitly mentioned in the alternatives:
133 case un_mentioned_constructors of
134 [] -> -- All constructors mentioned, so no default needed
135 returnDs (MatchResult can_any_alt_fail
137 (mk_case alts (\ignore -> NoDefault))
140 [con] -> -- Just one constructor missing, so add a case for it
141 -- We need to build new locals for the args of the constructor,
142 -- and figuring out their types is somewhat tiresome.
144 (_,arg_tys,_) = getInstantiatedDataConSig con tycon_arg_tys
146 newSysLocalsDs arg_tys `thenDs` \ arg_ids ->
148 -- Now we are ready to construct the new alternative
150 new_alt = (con, arg_ids, MatchResult CanFail ty1 id NoMatchContext)
152 returnDs (MatchResult CanFail
154 (mk_case (new_alt:alts) (\ignore -> NoDefault))
157 other -> -- Many constructors missing, so use a default case
158 newSysLocalDs scrut_ty `thenDs` \ wild ->
159 returnDs (MatchResult CanFail
161 (mk_case alts (\fail_expr -> BindDefault wild fail_expr))
164 scrut_ty = idType var
165 (tycon, tycon_arg_tys, data_cons) = getAppDataTyCon scrut_ty
167 un_mentioned_constructors
168 = uniqSetToList (mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- alts] )
170 match_results = [match_result | (_,_,match_result) <- alts]
171 (MatchResult _ ty1 _ cxt1 : _) = match_results
172 can_any_alt_fail = foldr1 orFail [can_it_fail | MatchResult can_it_fail _ _ _ <- match_results]
174 mk_case alts deflt_fn fail_expr
175 = Case (Var var) (AlgAlts final_alts (deflt_fn fail_expr))
177 final_alts = [ (con, args, body_fn fail_expr)
178 | (con, args, MatchResult _ _ body_fn _) <- alts
182 combineMatchResults :: MatchResult -> MatchResult -> DsM MatchResult
183 combineMatchResults (MatchResult CanFail ty1 body_fn1 cxt1)
184 (MatchResult can_it_fail2 ty2 body_fn2 cxt2)
185 = mkFailurePair ty1 `thenDs` \ (bind_fn, duplicatable_expr) ->
187 new_body_fn1 = \body1 -> Let (bind_fn body1) (body_fn1 duplicatable_expr)
188 new_body_fn2 = \body2 -> new_body_fn1 (body_fn2 body2)
190 returnDs (MatchResult can_it_fail2 ty1 new_body_fn2 cxt1)
192 combineMatchResults match_result1@(MatchResult CantFail ty body_fn1 cxt1)
194 = returnDs match_result1
197 -- The difference in combineGRHSMatchResults is that there is no
198 -- need to let-bind to avoid code duplication
199 combineGRHSMatchResults :: MatchResult -> MatchResult -> DsM MatchResult
200 combineGRHSMatchResults (MatchResult CanFail ty1 body_fn1 cxt1)
201 (MatchResult can_it_fail ty2 body_fn2 cxt2)
202 = returnDs (MatchResult can_it_fail ty1 (\ body -> body_fn1 (body_fn2 body)) cxt1)
204 combineGRHSMatchResults match_result1 match_result2
205 = -- Delegate to avoid duplication of code
206 combineMatchResults match_result1 match_result2
209 %************************************************************************
211 \subsection[dsExprToAtom]{Take an expression and produce an atom}
213 %************************************************************************
216 dsExprToAtom :: CoreExpr -- The argument expression
217 -> (CoreArg -> DsM CoreExpr) -- Something taking the argument *atom*,
218 -- and delivering an expression E
219 -> DsM CoreExpr -- Either E or let x=arg-expr in E
221 dsExprToAtom (Var v) continue_with = continue_with (VarArg v)
222 dsExprToAtom (Lit v) continue_with = continue_with (LitArg v)
224 dsExprToAtom arg_expr continue_with
226 ty = coreExprType arg_expr
228 newSysLocalDs ty `thenDs` \ arg_id ->
229 continue_with (VarArg arg_id) `thenDs` \ body ->
232 then Case arg_expr (PrimAlts [] (BindDefault arg_id body))
233 else Let (NonRec arg_id arg_expr) body
236 dsExprsToAtoms :: [CoreExpr]
237 -> ([CoreArg] -> DsM CoreExpr)
240 dsExprsToAtoms [] continue_with
243 dsExprsToAtoms (arg:args) continue_with
244 = dsExprToAtom arg $ \ arg_atom ->
245 dsExprsToAtoms args $ \ arg_atoms ->
246 continue_with (arg_atom:arg_atoms)
249 %************************************************************************
251 \subsection{Desugarer's versions of some Core functions}
253 %************************************************************************
255 Plumb the desugarer's @UniqueSupply@ in/out of the @UniqSupply@ monad
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)
275 %************************************************************************
277 \subsection[mkSelectorBind]{Make a selector bind}
279 %************************************************************************
281 This is used in various places to do with lazy patterns.
282 For each binder $b$ in the pattern, we create a binding:
284 b = case v of pat' -> b'
286 where pat' is pat with each binder b cloned into b'.
288 ToDo: making these bindings should really depend on whether there's
289 much work to be done per binding. If the pattern is complex, it
290 should be de-mangled once, into a tuple (and then selected from).
291 Otherwise the demangling can be in-line in the bindings (as here).
293 Boring! Boring! One error message per binder. The above ToDo is
294 even more helpful. Something very similar happens for pattern-bound
298 mkSelectorBinds :: [TyVar] -- Variables wrt which the pattern is polymorphic
299 -> TypecheckedPat -- The pattern
300 -> [(Id,Id)] -- Monomorphic and polymorphic binders for
302 -> CoreExpr -- Expression to which the pattern is bound
303 -> DsM [(Id,CoreExpr)]
305 mkSelectorBinds tyvars pat locals_and_globals val_expr
306 = getSrcLocDs `thenDs` \ (src_file, src_line) ->
308 if is_simple_tuple_pat pat then
309 mkTupleBind tyvars [] locals_and_globals val_expr
311 newSysLocalDs stringTy `thenDs` \ str_var -> -- to hold the string
313 src_loc_str = escErrorMsg ('"' : src_file) ++ "%l" ++ src_line
314 error_string = src_loc_str ++ "%~" --> ": pattern-match failed on an irrefutable pattern"
315 error_msg = mkErrorApp res_ty str_var error_string
317 matchSimply val_expr pat res_ty local_tuple error_msg `thenDs` \ tuple_expr ->
318 mkTupleBind tyvars [] locals_and_globals tuple_expr
320 locals = [local | (local, _) <- locals_and_globals]
321 local_tuple = mkTupleExpr locals
322 res_ty = coreExprType local_tuple
324 is_simple_tuple_pat (TuplePat ps) = all is_var_pat ps
325 is_simple_tuple_pat other = False
327 is_var_pat (VarPat v) = True
328 is_var_pat other = False -- Even wild-card patterns aren't acceptable
331 We're about to match against some patterns. We want to make some
332 @Ids@ to use as match variables. If a pattern has an @Id@ readily at
333 hand, which should indeed be bound to the pattern as a whole, then use it;
334 otherwise, make one up.
336 selectMatchVars :: [TypecheckedPat] -> DsM [Id]
338 = mapDs var_from_pat_maybe pats
340 var_from_pat_maybe (VarPat var) = returnDs var
341 var_from_pat_maybe (AsPat var pat) = returnDs var
342 var_from_pat_maybe (LazyPat pat) = var_from_pat_maybe pat
343 var_from_pat_maybe other_pat
344 = newSysLocalDs (outPatType other_pat) -- OK, better make up one...
348 mkTupleBind :: [TyVar] -- Abstract wrt these...
349 -> [DictVar] -- ... and these
351 -> [(Id, Id)] -- Local, global pairs, equal in number
352 -- to the size of the tuple. The types
353 -- of the globals is the generalisation of
354 -- the corresp local, wrt the tyvars and dicts
356 -> CoreExpr -- Expr whose value is a tuple; the expression
357 -- may mention the tyvars and dicts
359 -> DsM [(Id, CoreExpr)] -- Bindings for the globals
364 mkTupleBind tyvars dicts [(l1,g1), ..., (ln,gn)] tup_expr
366 If $n=1$, the result is:
368 g1 = /\ tyvars -> \ dicts -> rhs
370 Otherwise, the result is:
372 tup = /\ tyvars -> \ dicts -> tup_expr
373 g1 = /\ tyvars -> \ dicts -> case (tup tyvars dicts) of
379 mkTupleBind tyvars dicts [(local,global)] tuple_expr
380 = returnDs [(global, mkLam tyvars dicts tuple_expr)]
386 mkTupleBind tyvars dicts local_global_prs tuple_expr
387 = newSysLocalDs tuple_var_ty `thenDs` \ tuple_var ->
389 zipWithDs (mk_selector (Var tuple_var))
391 [(0::Int) .. (length local_global_prs - 1)]
392 `thenDs` \ tup_selectors ->
394 (tuple_var, mkLam tyvars dicts tuple_expr)
398 locals, globals :: [Id]
399 locals = [local | (local,global) <- local_global_prs]
400 globals = [global | (local,global) <- local_global_prs]
402 no_of_binders = length local_global_prs
403 tyvar_tys = mkTyVarTys tyvars
407 = case (quantifyTy tyvars (mkRhoTy theta
408 (applyTyCon (mkTupleTyCon no_of_binders)
409 (map idType locals)))) of
410 (_{-tossed templates-}, ty) -> ty
412 theta = map (splitDictType . idType) dicts
414 mk_selector :: CoreExpr -> (Id, Id) -> Int -> DsM (Id, CoreExpr)
416 mk_selector tuple_var_expr (local, global) which_local
417 = mapDs duplicateLocalDs locals{-the whole bunch-} `thenDs` \ binders ->
419 selected = binders !! which_local
424 mkTupleSelector (mkApp_XX (mkCoTyApps tuple_var_expr tyvar_tys) dicts)
428 mkApp_XX :: CoreExpr -> [Id] -> CoreExpr
429 mkApp_XX expr [] = expr
430 mkApp_XX expr (id:ids) = mkApp_XX (App expr (VarArg id)) ids
435 @mkTupleExpr@ builds a tuple; the inverse to @mkTupleSelector@. If it
436 has only one element, it is the identity function.
438 mkTupleExpr :: [Id] -> CoreExpr
440 mkTupleExpr [] = Con (mkTupleCon 0) []
441 mkTupleExpr [id] = Var id
442 mkTupleExpr ids = mkCon (mkTupleCon (length ids))
445 [ VarArg i | i <- ids ]
449 @mkTupleSelector@ builds a selector which scrutises the given
450 expression and extracts the one name from the list given.
451 If you want the no-shadowing rule to apply, the caller
452 is responsible for making sure that none of these names
455 If there is just one id in the ``tuple'', then the selector is
459 mkTupleSelector :: CoreExpr -- Scrutinee
460 -> [Id] -- The tuple args
461 -> Id -- The selected one
464 mkTupleSelector expr [] the_var = panic "mkTupleSelector"
466 mkTupleSelector expr [var] should_be_the_same_var
467 = ASSERT(var == should_be_the_same_var)
470 mkTupleSelector expr vars the_var
471 = Case expr (AlgAlts [(mkTupleCon arity, vars, Var the_var)]
478 %************************************************************************
480 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
482 %************************************************************************
484 Generally, we handle pattern matching failure like this: let-bind a
485 fail-variable, and use that variable if the thing fails:
487 let fail.33 = error "Help"
498 If the case can't fail, then there'll be no mention of fail.33, and the
499 simplifier will later discard it.
502 If it can fail in only one way, then the simplifier will inline it.
505 Only if it is used more than once will the let-binding remain.
508 There's a problem when the result of the case expression is of
509 unboxed type. Then the type of fail.33 is unboxed too, and
510 there is every chance that someone will change the let into a case:
516 which is of course utterly wrong. Rather than drop the condition that
517 only boxed types can be let-bound, we just turn the fail into a function
518 for the primitive case:
520 let fail.33 :: () -> Int#
521 fail.33 = \_ -> error "Help"
530 Now fail.33 is a function, so it can be let-bound.
533 mkFailurePair :: Type -- Result type of the whole case expression
534 -> DsM (CoreExpr -> CoreBinding,
535 -- Binds the newly-created fail variable
536 -- to either the expression or \ _ -> expression
537 CoreExpr) -- Either the fail variable, or fail variable
538 -- applied to unit tuple
541 = newFailLocalDs (mkFunTys [unit_ty] ty) `thenDs` \ fail_fun_var ->
542 newSysLocalDs unit_ty `thenDs` \ fail_fun_arg ->
544 NonRec fail_fun_var (Lam (ValBinder fail_fun_arg) body),
545 App (Var fail_fun_var) (VarArg unit_id))
548 = newFailLocalDs ty `thenDs` \ fail_var ->
549 returnDs (\ body -> NonRec fail_var body, Var fail_var)
551 unit_id :: Id -- out here to avoid CAF (sigh)
552 unit_id = mkTupleCon 0
555 unit_ty = idType unit_id