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,
47 DataCon(..), DictVar(..), Id(..), GenId )
48 import Literal ( Literal(..) )
49 import TyCon ( mkTupleTyCon )
50 import Type ( mkTyVarTys, mkRhoTy, mkForAllTys, mkFunTys,
51 isUnboxedType, applyTyCon, getAppDataTyCon
53 import UniqSet ( mkUniqSet, minusUniqSet, uniqSetToList, UniqSet(..) )
54 import Util ( panic, assertPanic, pprTrace{-ToDo:rm-} )
55 import PprCore{-ToDo:rm-}
56 import PprType--ToDo:rm
57 import Pretty--ToDo:rm
59 import Unique--ToDo:rm
62 splitDictType = panic "DsUtils.splitDictType"
65 %************************************************************************
67 %* type synonym EquationInfo and access functions for its pieces *
69 %************************************************************************
70 \subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym}
72 The ``equation info'' used by @match@ is relatively complicated and
73 worthy of a type synonym and a few handy functions.
78 [TypecheckedPat] -- the patterns for an eqn
79 MatchResult -- Encapsulates the guards and bindings
86 Type -- Type of argument expression
88 (CoreExpr -> CoreExpr)
89 -- Takes a expression to plug in at the
90 -- failure point(s). The expression should
93 DsMatchContext -- The context info is used when producing warnings
94 -- about shadowed patterns. It's the context
95 -- of the *first* thing matched in this group.
96 -- Should perhaps be a list of them all!
98 data CanItFail = CanFail | CantFail
100 orFail CantFail CantFail = CantFail
104 mkCoLetsMatchResult :: [CoreBinding] -> MatchResult -> MatchResult
105 mkCoLetsMatchResult binds (MatchResult can_it_fail ty body_fn cxt)
106 = MatchResult can_it_fail ty (\body -> mkCoLetsAny binds (body_fn body)) cxt
108 mkGuardedMatchResult :: CoreExpr -> MatchResult -> DsM MatchResult
109 mkGuardedMatchResult pred_expr (MatchResult can_it_fail ty body_fn cxt)
110 = returnDs (MatchResult CanFail
112 (\fail -> mkCoreIfThenElse pred_expr (body_fn fail) fail)
116 mkCoPrimCaseMatchResult :: Id -- Scrutinee
117 -> [(Literal, MatchResult)] -- Alternatives
119 mkCoPrimCaseMatchResult var alts
120 = newSysLocalDs (idType var) `thenDs` \ wild ->
121 returnDs (MatchResult CanFail
126 ((_,MatchResult _ ty1 _ cxt1) : _) = alts
128 mk_case alts wild fail_expr
129 = Case (Var var) (PrimAlts final_alts (BindDefault wild fail_expr))
131 final_alts = [ (lit, body_fn fail_expr)
132 | (lit, MatchResult _ _ body_fn _) <- alts
136 mkCoAlgCaseMatchResult :: Id -- Scrutinee
137 -> [(DataCon, [Id], MatchResult)] -- Alternatives
140 mkCoAlgCaseMatchResult var alts
141 = -- Find all the constructors in the type which aren't
142 -- explicitly mentioned in the alternatives:
143 case un_mentioned_constructors of
144 [] -> -- All constructors mentioned, so no default needed
145 returnDs (MatchResult can_any_alt_fail
147 (mk_case alts (\ignore -> NoDefault))
150 [con] -> -- Just one constructor missing, so add a case for it
151 -- We need to build new locals for the args of the constructor,
152 -- and figuring out their types is somewhat tiresome.
154 arg_tys = dataConArgTys con tycon_arg_tys
156 newSysLocalsDs arg_tys `thenDs` \ arg_ids ->
158 -- Now we are ready to construct the new alternative
160 new_alt = (con, arg_ids, MatchResult CanFail ty1 id NoMatchContext)
162 returnDs (MatchResult CanFail
164 (mk_case (new_alt:alts) (\ignore -> NoDefault))
167 other -> -- Many constructors missing, so use a default case
168 newSysLocalDs scrut_ty `thenDs` \ wild ->
169 returnDs (MatchResult CanFail
171 (mk_case alts (\fail_expr -> BindDefault wild fail_expr))
174 scrut_ty = idType var
175 (tycon, tycon_arg_tys, data_cons) = pprTrace "CoAlgCase:" (pprType PprDebug scrut_ty) $ getAppDataTyCon scrut_ty
177 un_mentioned_constructors
178 = uniqSetToList (mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- alts] )
180 match_results = [match_result | (_,_,match_result) <- alts]
181 (MatchResult _ ty1 _ cxt1 : _) = match_results
182 can_any_alt_fail = foldr1 orFail [can_it_fail | MatchResult can_it_fail _ _ _ <- match_results]
184 mk_case alts deflt_fn fail_expr
185 = Case (Var var) (AlgAlts final_alts (deflt_fn fail_expr))
187 final_alts = [ (con, args, body_fn fail_expr)
188 | (con, args, MatchResult _ _ body_fn _) <- alts
192 combineMatchResults :: MatchResult -> MatchResult -> DsM MatchResult
193 combineMatchResults (MatchResult CanFail ty1 body_fn1 cxt1)
194 (MatchResult can_it_fail2 ty2 body_fn2 cxt2)
195 = mkFailurePair ty1 `thenDs` \ (bind_fn, duplicatable_expr) ->
197 new_body_fn1 = \body1 -> Let (bind_fn body1) (body_fn1 duplicatable_expr)
198 new_body_fn2 = \body2 -> new_body_fn1 (body_fn2 body2)
200 returnDs (MatchResult can_it_fail2 ty1 new_body_fn2 cxt1)
202 combineMatchResults match_result1@(MatchResult CantFail ty body_fn1 cxt1)
204 = returnDs match_result1
207 -- The difference in combineGRHSMatchResults is that there is no
208 -- need to let-bind to avoid code duplication
209 combineGRHSMatchResults :: MatchResult -> MatchResult -> DsM MatchResult
210 combineGRHSMatchResults (MatchResult CanFail ty1 body_fn1 cxt1)
211 (MatchResult can_it_fail ty2 body_fn2 cxt2)
212 = returnDs (MatchResult can_it_fail ty1 (\ body -> body_fn1 (body_fn2 body)) cxt1)
214 combineGRHSMatchResults match_result1 match_result2
215 = -- Delegate to avoid duplication of code
216 combineMatchResults match_result1 match_result2
219 %************************************************************************
221 \subsection[dsExprToAtom]{Take an expression and produce an atom}
223 %************************************************************************
226 dsExprToAtom :: CoreExpr -- The argument expression
227 -> (CoreArg -> DsM CoreExpr) -- Something taking the argument *atom*,
228 -- and delivering an expression E
229 -> DsM CoreExpr -- Either E or let x=arg-expr in E
231 dsExprToAtom (Var v) continue_with = continue_with (VarArg v)
232 dsExprToAtom (Lit v) continue_with = continue_with (LitArg v)
234 dsExprToAtom arg_expr continue_with
236 ty = coreExprType arg_expr
238 newSysLocalDs ty `thenDs` \ arg_id ->
239 continue_with (VarArg arg_id) `thenDs` \ body ->
242 then Case arg_expr (PrimAlts [] (BindDefault arg_id body))
243 else Let (NonRec arg_id arg_expr) body
246 dsExprsToAtoms :: [CoreExpr]
247 -> ([CoreArg] -> DsM CoreExpr)
250 dsExprsToAtoms [] continue_with
253 dsExprsToAtoms (arg:args) continue_with
254 = dsExprToAtom arg $ \ arg_atom ->
255 dsExprsToAtoms args $ \ arg_atoms ->
256 continue_with (arg_atom:arg_atoms)
259 %************************************************************************
261 \subsection{Desugarer's versions of some Core functions}
263 %************************************************************************
266 mkAppDs :: CoreExpr -> [Type] -> [CoreExpr] -> DsM CoreExpr
267 mkConDs :: Id -> [Type] -> [CoreExpr] -> DsM CoreExpr
268 mkPrimDs :: PrimOp -> [Type] -> [CoreExpr] -> DsM CoreExpr
270 mkAppDs fun tys arg_exprs
271 = dsExprsToAtoms arg_exprs $ \ vals ->
272 returnDs (mkApp fun [] tys vals)
274 mkConDs con tys arg_exprs
275 = dsExprsToAtoms arg_exprs $ \ vals ->
276 returnDs (mkCon con [] tys vals)
278 mkPrimDs op tys arg_exprs
279 = dsExprsToAtoms arg_exprs $ \ vals ->
280 returnDs (mkPrim op [] tys vals)
284 showForErr :: Outputable a => a -> String -- Boring but useful
285 showForErr thing = ppShow 80 (ppr PprForUser thing)
287 mkErrorAppDs :: Id -- The error function
288 -> Type -- Type to which it should be applied
289 -> String -- The error message string to pass
292 mkErrorAppDs err_id ty msg
293 = getSrcLocDs `thenDs` \ (file, line) ->
295 full_msg = file ++ "|" ++ line ++ "|" ++msg
296 msg_lit = NoRepStr (_PK_ full_msg)
298 returnDs (mkApp (Var err_id) [] [ty] [LitArg msg_lit])
301 %************************************************************************
303 \subsection[mkSelectorBind]{Make a selector bind}
305 %************************************************************************
307 This is used in various places to do with lazy patterns.
308 For each binder $b$ in the pattern, we create a binding:
310 b = case v of pat' -> b'
312 where pat' is pat with each binder b cloned into b'.
314 ToDo: making these bindings should really depend on whether there's
315 much work to be done per binding. If the pattern is complex, it
316 should be de-mangled once, into a tuple (and then selected from).
317 Otherwise the demangling can be in-line in the bindings (as here).
319 Boring! Boring! One error message per binder. The above ToDo is
320 even more helpful. Something very similar happens for pattern-bound
324 mkSelectorBinds :: [TyVar] -- Variables wrt which the pattern is polymorphic
325 -> TypecheckedPat -- The pattern
326 -> [(Id,Id)] -- Monomorphic and polymorphic binders for
328 -> CoreExpr -- Expression to which the pattern is bound
329 -> DsM [(Id,CoreExpr)]
331 mkSelectorBinds tyvars pat locals_and_globals val_expr
332 = if is_simple_tuple_pat pat then
333 mkTupleBind tyvars [] locals_and_globals val_expr
335 mkErrorAppDs iRREFUT_PAT_ERROR_ID res_ty "" `thenDs` \ error_msg ->
336 matchSimply val_expr pat res_ty local_tuple error_msg `thenDs` \ tuple_expr ->
337 mkTupleBind tyvars [] locals_and_globals tuple_expr
339 locals = [local | (local, _) <- locals_and_globals]
340 local_tuple = mkTupleExpr locals
341 res_ty = coreExprType local_tuple
343 is_simple_tuple_pat (TuplePat ps) = all is_var_pat ps
344 is_simple_tuple_pat other = False
346 is_var_pat (VarPat v) = True
347 is_var_pat other = False -- Even wild-card patterns aren't acceptable
350 We're about to match against some patterns. We want to make some
351 @Ids@ to use as match variables. If a pattern has an @Id@ readily at
352 hand, which should indeed be bound to the pattern as a whole, then use it;
353 otherwise, make one up.
355 selectMatchVars :: [TypecheckedPat] -> DsM [Id]
357 = mapDs var_from_pat_maybe pats
359 var_from_pat_maybe (VarPat var) = returnDs var
360 var_from_pat_maybe (AsPat var pat) = returnDs var
361 var_from_pat_maybe (LazyPat pat) = var_from_pat_maybe pat
362 var_from_pat_maybe other_pat
363 = newSysLocalDs (outPatType other_pat) -- OK, better make up one...
367 mkTupleBind :: [TyVar] -- Abstract wrt these...
368 -> [DictVar] -- ... and these
370 -> [(Id, Id)] -- Local, global pairs, equal in number
371 -- to the size of the tuple. The types
372 -- of the globals is the generalisation of
373 -- the corresp local, wrt the tyvars and dicts
375 -> CoreExpr -- Expr whose value is a tuple; the expression
376 -- may mention the tyvars and dicts
378 -> DsM [(Id, CoreExpr)] -- Bindings for the globals
383 mkTupleBind tyvars dicts [(l1,g1), ..., (ln,gn)] tup_expr
385 If $n=1$, the result is:
387 g1 = /\ tyvars -> \ dicts -> rhs
389 Otherwise, the result is:
391 tup = /\ tyvars -> \ dicts -> tup_expr
392 g1 = /\ tyvars -> \ dicts -> case (tup tyvars dicts) of
398 mkTupleBind tyvars dicts [(local,global)] tuple_expr
399 = returnDs [(global, mkLam tyvars dicts tuple_expr)]
405 mkTupleBind tyvars dicts local_global_prs tuple_expr
406 = pprTrace "mkTupleBind:\n" (ppAboves [ppCat (map (pprId PprShowAll) locals), ppCat (map (pprId PprShowAll) globals), {-ppr PprDebug local_tuple, pprType PprDebug res_ty,-} ppr PprDebug tuple_expr]) $
408 newSysLocalDs tuple_var_ty `thenDs` \ tuple_var ->
410 zipWithDs (mk_selector (Var tuple_var))
412 [(0::Int) .. (length local_global_prs - 1)]
413 `thenDs` \ tup_selectors ->
415 (tuple_var, mkLam tyvars dicts tuple_expr)
419 locals, globals :: [Id]
420 locals = [local | (local,global) <- local_global_prs]
421 globals = [global | (local,global) <- local_global_prs]
423 no_of_binders = length local_global_prs
424 tyvar_tys = mkTyVarTys tyvars
428 = mkForAllTys tyvars $
430 applyTyCon (mkTupleTyCon no_of_binders)
433 theta = map (splitDictType . idType) dicts
435 mk_selector :: CoreExpr -> (Id, Id) -> Int -> DsM (Id, CoreExpr)
437 mk_selector tuple_var_expr (local, global) which_local
438 = mapDs duplicateLocalDs locals{-the whole bunch-} `thenDs` \ binders ->
440 selected = binders !! which_local
446 (mkValApp (mkTyApp tuple_var_expr tyvar_tys)
453 @mkTupleExpr@ builds a tuple; the inverse to @mkTupleSelector@. If it
454 has only one element, it is the identity function.
456 mkTupleExpr :: [Id] -> CoreExpr
458 mkTupleExpr [] = Con (mkTupleCon 0) []
459 mkTupleExpr [id] = Var id
460 mkTupleExpr ids = mkCon (mkTupleCon (length ids))
463 [ VarArg i | i <- ids ]
467 @mkTupleSelector@ builds a selector which scrutises the given
468 expression and extracts the one name from the list given.
469 If you want the no-shadowing rule to apply, the caller
470 is responsible for making sure that none of these names
473 If there is just one id in the ``tuple'', then the selector is
477 mkTupleSelector :: CoreExpr -- Scrutinee
478 -> [Id] -- The tuple args
479 -> Id -- The selected one
482 mkTupleSelector expr [] the_var = panic "mkTupleSelector"
484 mkTupleSelector expr [var] should_be_the_same_var
485 = ASSERT(var == should_be_the_same_var)
488 mkTupleSelector expr vars the_var
489 = Case expr (AlgAlts [(mkTupleCon arity, vars, Var the_var)]
496 %************************************************************************
498 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
500 %************************************************************************
502 Generally, we handle pattern matching failure like this: let-bind a
503 fail-variable, and use that variable if the thing fails:
505 let fail.33 = error "Help"
516 If the case can't fail, then there'll be no mention of fail.33, and the
517 simplifier will later discard it.
520 If it can fail in only one way, then the simplifier will inline it.
523 Only if it is used more than once will the let-binding remain.
526 There's a problem when the result of the case expression is of
527 unboxed type. Then the type of fail.33 is unboxed too, and
528 there is every chance that someone will change the let into a case:
534 which is of course utterly wrong. Rather than drop the condition that
535 only boxed types can be let-bound, we just turn the fail into a function
536 for the primitive case:
538 let fail.33 :: () -> Int#
539 fail.33 = \_ -> error "Help"
548 Now fail.33 is a function, so it can be let-bound.
551 mkFailurePair :: Type -- Result type of the whole case expression
552 -> DsM (CoreExpr -> CoreBinding,
553 -- Binds the newly-created fail variable
554 -- to either the expression or \ _ -> expression
555 CoreExpr) -- Either the fail variable, or fail variable
556 -- applied to unit tuple
559 = newFailLocalDs (mkFunTys [unit_ty] ty) `thenDs` \ fail_fun_var ->
560 newSysLocalDs unit_ty `thenDs` \ fail_fun_arg ->
562 NonRec fail_fun_var (Lam (ValBinder fail_fun_arg) body),
563 App (Var fail_fun_var) (VarArg unit_id))
566 = newFailLocalDs ty `thenDs` \ fail_var ->
567 returnDs (\ body -> NonRec fail_var body, Var fail_var)
569 unit_id :: Id -- out here to avoid CAF (sigh)
570 unit_id = mkTupleCon 0
573 unit_ty = idType unit_id