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, isNewTyCon, tyConDataCons )
50 import Type ( mkTyVarTys, mkRhoTy, mkForAllTys, mkFunTys,
51 mkTheta, isUnboxedType, applyTyCon, getAppTyCon
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
63 %************************************************************************
65 %* type synonym EquationInfo and access functions for its pieces *
67 %************************************************************************
68 \subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym}
70 The ``equation info'' used by @match@ is relatively complicated and
71 worthy of a type synonym and a few handy functions.
76 [TypecheckedPat] -- the patterns for an eqn
77 MatchResult -- Encapsulates the guards and bindings
84 Type -- Type of argument expression
86 (CoreExpr -> CoreExpr)
87 -- Takes a expression to plug in at the
88 -- failure point(s). The expression should
91 DsMatchContext -- The context info is used when producing warnings
92 -- about shadowed patterns. It's the context
93 -- of the *first* thing matched in this group.
94 -- Should perhaps be a list of them all!
96 data CanItFail = CanFail | CantFail
98 orFail CantFail CantFail = CantFail
102 mkCoLetsMatchResult :: [CoreBinding] -> MatchResult -> MatchResult
103 mkCoLetsMatchResult binds (MatchResult can_it_fail ty body_fn cxt)
104 = MatchResult can_it_fail ty (\body -> mkCoLetsAny binds (body_fn body)) cxt
106 mkGuardedMatchResult :: CoreExpr -> MatchResult -> DsM MatchResult
107 mkGuardedMatchResult pred_expr (MatchResult can_it_fail ty body_fn cxt)
108 = returnDs (MatchResult CanFail
110 (\fail -> mkCoreIfThenElse pred_expr (body_fn fail) fail)
114 mkCoPrimCaseMatchResult :: Id -- Scrutinee
115 -> [(Literal, MatchResult)] -- Alternatives
117 mkCoPrimCaseMatchResult var alts
118 = newSysLocalDs (idType var) `thenDs` \ wild ->
119 returnDs (MatchResult CanFail
124 ((_,MatchResult _ ty1 _ cxt1) : _) = alts
126 mk_case alts wild fail_expr
127 = Case (Var var) (PrimAlts final_alts (BindDefault wild fail_expr))
129 final_alts = [ (lit, body_fn fail_expr)
130 | (lit, MatchResult _ _ body_fn _) <- alts
134 mkCoAlgCaseMatchResult :: Id -- Scrutinee
135 -> [(DataCon, [Id], MatchResult)] -- Alternatives
138 mkCoAlgCaseMatchResult var alts
139 | isNewTyCon tycon -- newtype case; use a let
140 = ASSERT( newtype_sanity )
141 returnDs (mkCoLetsMatchResult [coercion_bind] match_result)
143 | otherwise -- datatype case
144 = -- Find all the constructors in the type which aren't
145 -- explicitly mentioned in the alternatives:
146 case un_mentioned_constructors of
147 [] -> -- All constructors mentioned, so no default needed
148 returnDs (MatchResult can_any_alt_fail
150 (mk_case alts (\ignore -> NoDefault))
153 [con] -> -- Just one constructor missing, so add a case for it
154 -- We need to build new locals for the args of the constructor,
155 -- and figuring out their types is somewhat tiresome.
157 arg_tys = dataConArgTys con tycon_arg_tys
159 newSysLocalsDs arg_tys `thenDs` \ arg_ids ->
161 -- Now we are ready to construct the new alternative
163 new_alt = (con, arg_ids, MatchResult CanFail ty1 id NoMatchContext)
165 returnDs (MatchResult CanFail
167 (mk_case (new_alt:alts) (\ignore -> NoDefault))
170 other -> -- Many constructors missing, so use a default case
171 newSysLocalDs scrut_ty `thenDs` \ wild ->
172 returnDs (MatchResult CanFail
174 (mk_case alts (\fail_expr -> BindDefault wild fail_expr))
178 scrut_ty = idType var
179 (tycon, tycon_arg_tys) = --pprTrace "CoAlgCase:" (pprType PprDebug scrut_ty) $
183 (con_id, arg_ids, match_result) = head alts
184 arg_id = head arg_ids
185 coercion_bind = NonRec arg_id (Coerce (CoerceOut con_id)
188 newtype_sanity = null (tail alts) && null (tail arg_ids)
190 -- Stuff for data types
191 data_cons = tyConDataCons tycon
193 un_mentioned_constructors
194 = uniqSetToList (mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- alts] )
196 match_results = [match_result | (_,_,match_result) <- alts]
197 (MatchResult _ ty1 _ cxt1 : _) = match_results
198 can_any_alt_fail = foldr1 orFail [can_it_fail | MatchResult can_it_fail _ _ _ <- match_results]
200 mk_case alts deflt_fn fail_expr
201 = Case (Var var) (AlgAlts final_alts (deflt_fn fail_expr))
203 final_alts = [ (con, args, body_fn fail_expr)
204 | (con, args, MatchResult _ _ body_fn _) <- alts
208 combineMatchResults :: MatchResult -> MatchResult -> DsM MatchResult
209 combineMatchResults (MatchResult CanFail ty1 body_fn1 cxt1)
210 (MatchResult can_it_fail2 ty2 body_fn2 cxt2)
211 = mkFailurePair ty1 `thenDs` \ (bind_fn, duplicatable_expr) ->
213 new_body_fn1 = \body1 -> Let (bind_fn body1) (body_fn1 duplicatable_expr)
214 new_body_fn2 = \body2 -> new_body_fn1 (body_fn2 body2)
216 returnDs (MatchResult can_it_fail2 ty1 new_body_fn2 cxt1)
218 combineMatchResults match_result1@(MatchResult CantFail ty body_fn1 cxt1)
220 = returnDs match_result1
223 -- The difference in combineGRHSMatchResults is that there is no
224 -- need to let-bind to avoid code duplication
225 combineGRHSMatchResults :: MatchResult -> MatchResult -> DsM MatchResult
226 combineGRHSMatchResults (MatchResult CanFail ty1 body_fn1 cxt1)
227 (MatchResult can_it_fail ty2 body_fn2 cxt2)
228 = returnDs (MatchResult can_it_fail ty1 (\ body -> body_fn1 (body_fn2 body)) cxt1)
230 combineGRHSMatchResults match_result1 match_result2
231 = -- Delegate to avoid duplication of code
232 combineMatchResults match_result1 match_result2
235 %************************************************************************
237 \subsection[dsExprToAtom]{Take an expression and produce an atom}
239 %************************************************************************
242 dsExprToAtom :: CoreExpr -- The argument expression
243 -> (CoreArg -> DsM CoreExpr) -- Something taking the argument *atom*,
244 -- and delivering an expression E
245 -> DsM CoreExpr -- Either E or let x=arg-expr in E
247 dsExprToAtom (Var v) continue_with = continue_with (VarArg v)
248 dsExprToAtom (Lit v) continue_with = continue_with (LitArg v)
250 dsExprToAtom arg_expr continue_with
252 ty = coreExprType arg_expr
254 newSysLocalDs ty `thenDs` \ arg_id ->
255 continue_with (VarArg arg_id) `thenDs` \ body ->
258 then Case arg_expr (PrimAlts [] (BindDefault arg_id body))
259 else Let (NonRec arg_id arg_expr) body
262 dsExprsToAtoms :: [CoreExpr]
263 -> ([CoreArg] -> DsM CoreExpr)
266 dsExprsToAtoms [] continue_with
269 dsExprsToAtoms (arg:args) continue_with
270 = dsExprToAtom arg $ \ arg_atom ->
271 dsExprsToAtoms args $ \ arg_atoms ->
272 continue_with (arg_atom:arg_atoms)
275 %************************************************************************
277 \subsection{Desugarer's versions of some Core functions}
279 %************************************************************************
282 mkAppDs :: CoreExpr -> [Type] -> [CoreExpr] -> DsM CoreExpr
283 mkConDs :: Id -> [Type] -> [CoreExpr] -> DsM CoreExpr
284 mkPrimDs :: PrimOp -> [Type] -> [CoreExpr] -> DsM CoreExpr
286 mkAppDs fun tys arg_exprs
287 = dsExprsToAtoms arg_exprs $ \ vals ->
288 returnDs (mkApp fun [] tys vals)
290 mkConDs con tys arg_exprs
291 = dsExprsToAtoms arg_exprs $ \ vals ->
292 returnDs (mkCon con [] tys vals)
294 mkPrimDs op tys arg_exprs
295 = dsExprsToAtoms arg_exprs $ \ vals ->
296 returnDs (mkPrim op [] tys vals)
300 showForErr :: Outputable a => a -> String -- Boring but useful
301 showForErr thing = ppShow 80 (ppr PprForUser thing)
303 mkErrorAppDs :: Id -- The error function
304 -> Type -- Type to which it should be applied
305 -> String -- The error message string to pass
308 mkErrorAppDs err_id ty msg
309 = getSrcLocDs `thenDs` \ (file, line) ->
311 full_msg = file ++ "|" ++ line ++ "|" ++msg
312 msg_lit = NoRepStr (_PK_ full_msg)
314 returnDs (mkApp (Var err_id) [] [ty] [LitArg msg_lit])
317 %************************************************************************
319 \subsection[mkSelectorBind]{Make a selector bind}
321 %************************************************************************
323 This is used in various places to do with lazy patterns.
324 For each binder $b$ in the pattern, we create a binding:
326 b = case v of pat' -> b'
328 where pat' is pat with each binder b cloned into b'.
330 ToDo: making these bindings should really depend on whether there's
331 much work to be done per binding. If the pattern is complex, it
332 should be de-mangled once, into a tuple (and then selected from).
333 Otherwise the demangling can be in-line in the bindings (as here).
335 Boring! Boring! One error message per binder. The above ToDo is
336 even more helpful. Something very similar happens for pattern-bound
340 mkSelectorBinds :: [TyVar] -- Variables wrt which the pattern is polymorphic
341 -> TypecheckedPat -- The pattern
342 -> [(Id,Id)] -- Monomorphic and polymorphic binders for
344 -> CoreExpr -- Expression to which the pattern is bound
345 -> DsM [(Id,CoreExpr)]
347 mkSelectorBinds tyvars pat locals_and_globals val_expr
348 = if is_simple_tuple_pat pat then
349 mkTupleBind tyvars [] locals_and_globals val_expr
351 mkErrorAppDs iRREFUT_PAT_ERROR_ID res_ty "" `thenDs` \ error_msg ->
352 matchSimply val_expr pat res_ty local_tuple error_msg `thenDs` \ tuple_expr ->
353 mkTupleBind tyvars [] locals_and_globals tuple_expr
355 locals = [local | (local, _) <- locals_and_globals]
356 local_tuple = mkTupleExpr locals
357 res_ty = coreExprType local_tuple
359 is_simple_tuple_pat (TuplePat ps) = all is_var_pat ps
360 is_simple_tuple_pat other = False
362 is_var_pat (VarPat v) = True
363 is_var_pat other = False -- Even wild-card patterns aren't acceptable
366 We're about to match against some patterns. We want to make some
367 @Ids@ to use as match variables. If a pattern has an @Id@ readily at
368 hand, which should indeed be bound to the pattern as a whole, then use it;
369 otherwise, make one up.
371 selectMatchVars :: [TypecheckedPat] -> DsM [Id]
373 = mapDs var_from_pat_maybe pats
375 var_from_pat_maybe (VarPat var) = returnDs var
376 var_from_pat_maybe (AsPat var pat) = returnDs var
377 var_from_pat_maybe (LazyPat pat) = var_from_pat_maybe pat
378 var_from_pat_maybe other_pat
379 = newSysLocalDs (outPatType other_pat) -- OK, better make up one...
383 mkTupleBind :: [TyVar] -- Abstract wrt these...
384 -> [DictVar] -- ... and these
386 -> [(Id, Id)] -- Local, global pairs, equal in number
387 -- to the size of the tuple. The types
388 -- of the globals is the generalisation of
389 -- the corresp local, wrt the tyvars and dicts
391 -> CoreExpr -- Expr whose value is a tuple; the expression
392 -- may mention the tyvars and dicts
394 -> DsM [(Id, CoreExpr)] -- Bindings for the globals
399 mkTupleBind tyvars dicts [(l1,g1), ..., (ln,gn)] tup_expr
401 If $n=1$, the result is:
403 g1 = /\ tyvars -> \ dicts -> rhs
405 Otherwise, the result is:
407 tup = /\ tyvars -> \ dicts -> tup_expr
408 g1 = /\ tyvars -> \ dicts -> case (tup tyvars dicts) of
414 mkTupleBind tyvars dicts [(local,global)] tuple_expr
415 = returnDs [(global, mkLam tyvars dicts tuple_expr)]
421 mkTupleBind tyvars dicts local_global_prs tuple_expr
422 = --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]) $
424 newSysLocalDs tuple_var_ty `thenDs` \ tuple_var ->
426 zipWithDs (mk_selector (Var tuple_var))
428 [(0::Int) .. (length local_global_prs - 1)]
429 `thenDs` \ tup_selectors ->
431 (tuple_var, mkLam tyvars dicts tuple_expr)
435 locals, globals :: [Id]
436 locals = [local | (local,global) <- local_global_prs]
437 globals = [global | (local,global) <- local_global_prs]
439 no_of_binders = length local_global_prs
440 tyvar_tys = mkTyVarTys tyvars
444 = mkForAllTys tyvars $
446 applyTyCon (mkTupleTyCon no_of_binders)
449 theta = mkTheta (map idType dicts)
451 mk_selector :: CoreExpr -> (Id, Id) -> Int -> DsM (Id, CoreExpr)
453 mk_selector tuple_var_expr (local, global) which_local
454 = mapDs duplicateLocalDs locals{-the whole bunch-} `thenDs` \ binders ->
456 selected = binders !! which_local
462 (mkValApp (mkTyApp tuple_var_expr tyvar_tys)
469 @mkTupleExpr@ builds a tuple; the inverse to @mkTupleSelector@. If it
470 has only one element, it is the identity function.
472 mkTupleExpr :: [Id] -> CoreExpr
474 mkTupleExpr [] = Con (mkTupleCon 0) []
475 mkTupleExpr [id] = Var id
476 mkTupleExpr ids = mkCon (mkTupleCon (length ids))
479 [ VarArg i | i <- ids ]
483 @mkTupleSelector@ builds a selector which scrutises the given
484 expression and extracts the one name from the list given.
485 If you want the no-shadowing rule to apply, the caller
486 is responsible for making sure that none of these names
489 If there is just one id in the ``tuple'', then the selector is
493 mkTupleSelector :: CoreExpr -- Scrutinee
494 -> [Id] -- The tuple args
495 -> Id -- The selected one
498 mkTupleSelector expr [] the_var = panic "mkTupleSelector"
500 mkTupleSelector expr [var] should_be_the_same_var
501 = ASSERT(var == should_be_the_same_var)
504 mkTupleSelector expr vars the_var
505 = Case expr (AlgAlts [(mkTupleCon arity, vars, Var the_var)]
512 %************************************************************************
514 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
516 %************************************************************************
518 Generally, we handle pattern matching failure like this: let-bind a
519 fail-variable, and use that variable if the thing fails:
521 let fail.33 = error "Help"
532 If the case can't fail, then there'll be no mention of fail.33, and the
533 simplifier will later discard it.
536 If it can fail in only one way, then the simplifier will inline it.
539 Only if it is used more than once will the let-binding remain.
542 There's a problem when the result of the case expression is of
543 unboxed type. Then the type of fail.33 is unboxed too, and
544 there is every chance that someone will change the let into a case:
550 which is of course utterly wrong. Rather than drop the condition that
551 only boxed types can be let-bound, we just turn the fail into a function
552 for the primitive case:
554 let fail.33 :: () -> Int#
555 fail.33 = \_ -> error "Help"
564 Now fail.33 is a function, so it can be let-bound.
567 mkFailurePair :: Type -- Result type of the whole case expression
568 -> DsM (CoreExpr -> CoreBinding,
569 -- Binds the newly-created fail variable
570 -- to either the expression or \ _ -> expression
571 CoreExpr) -- Either the fail variable, or fail variable
572 -- applied to unit tuple
575 = newFailLocalDs (mkFunTys [unit_ty] ty) `thenDs` \ fail_fun_var ->
576 newSysLocalDs unit_ty `thenDs` \ fail_fun_arg ->
578 NonRec fail_fun_var (Lam (ValBinder fail_fun_arg) body),
579 App (Var fail_fun_var) (VarArg unit_id))
582 = newFailLocalDs ty `thenDs` \ fail_var ->
583 returnDs (\ body -> NonRec fail_var body, Var fail_var)
585 unit_id :: Id -- out here to avoid CAF (sigh)
586 unit_id = mkTupleCon 0
589 unit_ty = idType unit_id