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.
10 CanItFail(..), EquationInfo(..), MatchResult(..),
13 combineGRHSMatchResults,
15 dsExprToAtomGivenTy, DsCoreArg,
16 mkCoAlgCaseMatchResult,
17 mkAppDs, mkConDs, mkPrimDs, mkErrorAppDs,
19 mkCoPrimCaseMatchResult,
30 #include "HsVersions.h"
32 import {-# SOURCE #-} Match ( matchSimply )
34 import HsSyn ( OutPat(..), Stmt, DoOrListComp )
35 import TcHsSyn ( TypecheckedPat )
36 import DsHsSyn ( outPatType, collectTypedPatBinders )
41 import CoreUtils ( coreExprType, mkCoreIfThenElse )
42 import PrelVals ( iRREFUT_PAT_ERROR_ID, voidId )
43 import Id ( idType, dataConArgTys,
45 import Literal ( Literal(..) )
46 import PrimOp ( PrimOp )
47 import TyCon ( isNewTyCon, tyConDataCons )
48 import Type ( mkRhoTy, mkFunTy,
49 isUnpointedType, mkTyConApp, splitAlgTyConApp,
52 import BasicTypes ( Unused )
53 import TysPrim ( voidTy )
54 import TysWiredIn ( unitDataCon, tupleCon )
55 import UniqSet ( mkUniqSet, minusUniqSet, uniqSetToList, UniqSet )
56 import Unique ( Unique )
61 %************************************************************************
63 %* Selecting match variables
65 %************************************************************************
67 We're about to match against some patterns. We want to make some
68 @Ids@ to use as match variables. If a pattern has an @Id@ readily at
69 hand, which should indeed be bound to the pattern as a whole, then use it;
70 otherwise, make one up.
73 selectMatchVars :: [TypecheckedPat] -> DsM [Id]
75 = mapDs var_from_pat_maybe pats
77 var_from_pat_maybe (VarPat var) = returnDs var
78 var_from_pat_maybe (AsPat var pat) = returnDs var
79 var_from_pat_maybe (LazyPat pat) = var_from_pat_maybe pat
80 var_from_pat_maybe other_pat
81 = newSysLocalDs (outPatType other_pat) -- OK, better make up one...
85 %************************************************************************
87 %* type synonym EquationInfo and access functions for its pieces *
89 %************************************************************************
90 \subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym}
92 The ``equation info'' used by @match@ is relatively complicated and
93 worthy of a type synonym and a few handy functions.
98 type EqnSet = UniqSet EqnNo
102 EqnNo -- The number of the equation
103 DsMatchContext -- The context info is used when producing warnings
104 -- about shadowed patterns. It's the context
105 -- of the *first* thing matched in this group.
106 -- Should perhaps be a list of them all!
107 [TypecheckedPat] -- the patterns for an eqn
108 MatchResult -- Encapsulates the guards and bindings
115 Type -- Type of argument expression
117 (CoreExpr -> CoreExpr)
118 -- Takes a expression to plug in at the
119 -- failure point(s). The expression should
122 data CanItFail = CanFail | CantFail
124 orFail CantFail CantFail = CantFail
128 mkCoLetsMatchResult :: [CoreBinding] -> MatchResult -> MatchResult
129 mkCoLetsMatchResult binds (MatchResult can_it_fail ty body_fn)
130 = MatchResult can_it_fail ty (\body -> mkCoLetsAny binds (body_fn body))
132 mkGuardedMatchResult :: CoreExpr -> MatchResult -> DsM MatchResult
133 mkGuardedMatchResult pred_expr (MatchResult can_it_fail ty body_fn)
134 = returnDs (MatchResult CanFail
136 (\fail -> mkCoreIfThenElse pred_expr (body_fn fail) fail)
139 mkCoPrimCaseMatchResult :: Id -- Scrutinee
140 -> [(Literal, MatchResult)] -- Alternatives
142 mkCoPrimCaseMatchResult var alts
143 = newSysLocalDs (idType var) `thenDs` \ wild ->
144 returnDs (MatchResult CanFail
148 ((_,MatchResult _ ty1 _) : _) = alts
150 mk_case alts wild fail_expr
151 = Case (Var var) (PrimAlts final_alts (BindDefault wild fail_expr))
153 final_alts = [ (lit, body_fn fail_expr)
154 | (lit, MatchResult _ _ body_fn) <- alts
158 mkCoAlgCaseMatchResult :: Id -- Scrutinee
159 -> [(DataCon, [Id], MatchResult)] -- Alternatives
162 mkCoAlgCaseMatchResult var alts
163 | isNewTyCon tycon -- newtype case; use a let
164 = ASSERT( newtype_sanity )
165 returnDs (mkCoLetsMatchResult [coercion_bind] match_result)
167 | otherwise -- datatype case
168 = -- Find all the constructors in the type which aren't
169 -- explicitly mentioned in the alternatives:
170 case un_mentioned_constructors of
171 [] -> -- All constructors mentioned, so no default needed
172 returnDs (MatchResult can_any_alt_fail
174 (mk_case alts (\ignore -> NoDefault)))
176 [con] -> -- Just one constructor missing, so add a case for it
177 -- We need to build new locals for the args of the constructor,
178 -- and figuring out their types is somewhat tiresome.
180 arg_tys = dataConArgTys con tycon_arg_tys
182 newSysLocalsDs arg_tys `thenDs` \ arg_ids ->
184 -- Now we are ready to construct the new alternative
186 new_alt = (con, arg_ids, MatchResult CanFail ty1 id)
188 returnDs (MatchResult CanFail
190 (mk_case (new_alt:alts) (\ignore -> NoDefault)))
192 other -> -- Many constructors missing, so use a default case
193 newSysLocalDs scrut_ty `thenDs` \ wild ->
194 returnDs (MatchResult CanFail
196 (mk_case alts (\fail_expr -> BindDefault wild fail_expr)))
199 scrut_ty = idType var
200 (tycon, tycon_arg_tys, _) = splitAlgTyConApp scrut_ty
203 (con_id, arg_ids, match_result) = head alts
204 arg_id = head arg_ids
205 coercion_bind = NonRec arg_id (Coerce (CoerceOut con_id)
208 newtype_sanity = null (tail alts) && null (tail arg_ids)
210 -- Stuff for data types
211 data_cons = tyConDataCons tycon
213 un_mentioned_constructors
214 = uniqSetToList (mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- alts] )
216 match_results = [match_result | (_,_,match_result) <- alts]
217 (MatchResult _ ty1 _ : _) = match_results
218 can_any_alt_fail = foldr1 orFail [can_it_fail | MatchResult can_it_fail _ _ <- match_results]
220 mk_case alts deflt_fn fail_expr
221 = Case (Var var) (AlgAlts final_alts (deflt_fn fail_expr))
223 final_alts = [ (con, args, body_fn fail_expr)
224 | (con, args, MatchResult _ _ body_fn) <- alts
228 combineMatchResults :: MatchResult -> MatchResult -> DsM MatchResult
229 combineMatchResults (MatchResult CanFail ty1 body_fn1)
230 (MatchResult can_it_fail2 ty2 body_fn2)
231 = mkFailurePair ty1 `thenDs` \ (bind_fn, duplicatable_expr) ->
233 new_body_fn1 = \body1 -> Let (bind_fn body1) (body_fn1 duplicatable_expr)
234 new_body_fn2 = \body2 -> new_body_fn1 (body_fn2 body2)
236 returnDs (MatchResult can_it_fail2 ty1 new_body_fn2)
238 combineMatchResults match_result1@(MatchResult CantFail ty body_fn1)
240 = returnDs match_result1
243 -- The difference in combineGRHSMatchResults is that there is no
244 -- need to let-bind to avoid code duplication
245 combineGRHSMatchResults :: MatchResult -> MatchResult -> DsM MatchResult
246 combineGRHSMatchResults (MatchResult CanFail ty1 body_fn1)
247 (MatchResult can_it_fail ty2 body_fn2)
248 = returnDs (MatchResult can_it_fail ty1 (\ body -> body_fn1 (body_fn2 body)))
250 combineGRHSMatchResults match_result1 match_result2
251 = -- Delegate to avoid duplication of code
252 combineMatchResults match_result1 match_result2
255 %************************************************************************
257 \subsection[dsExprToAtom]{Take an expression and produce an atom}
259 %************************************************************************
262 dsArgToAtom :: DsCoreArg -- The argument expression
263 -> (CoreArg -> DsM CoreExpr) -- Something taking the argument *atom*,
264 -- and delivering an expression E
265 -> DsM CoreExpr -- Either E or let x=arg-expr in E
267 dsArgToAtom (TyArg t) continue_with = continue_with (TyArg t)
268 dsArgToAtom (LitArg l) continue_with = continue_with (LitArg l)
269 dsArgToAtom (VarArg arg) continue_with = dsExprToAtomGivenTy arg (coreExprType arg) continue_with
272 :: CoreExpr -- The argument expression
273 -> Type -- Type of the argument
274 -> (CoreArg -> DsM CoreExpr) -- Something taking the argument *atom*,
275 -- and delivering an expression E
276 -> DsM CoreExpr -- Either E or let x=arg-expr in E
278 dsExprToAtomGivenTy (Var v) arg_ty continue_with = continue_with (VarArg v)
279 dsExprToAtomGivenTy (Lit v) arg_ty continue_with = continue_with (LitArg v)
280 dsExprToAtomGivenTy arg_expr arg_ty continue_with
281 = newSysLocalDs arg_ty `thenDs` \ arg_id ->
282 continue_with (VarArg arg_id) `thenDs` \ body ->
284 if isUnpointedType arg_ty
285 then Case arg_expr (PrimAlts [] (BindDefault arg_id body))
286 else Let (NonRec arg_id arg_expr) body
289 dsArgsToAtoms :: [DsCoreArg]
290 -> ([CoreArg] -> DsM CoreExpr)
293 dsArgsToAtoms [] continue_with = continue_with []
295 dsArgsToAtoms (arg:args) continue_with
296 = dsArgToAtom arg $ \ arg_atom ->
297 dsArgsToAtoms args $ \ arg_atoms ->
298 continue_with (arg_atom:arg_atoms)
301 %************************************************************************
303 \subsection{Desugarer's versions of some Core functions}
305 %************************************************************************
308 type DsCoreArg = GenCoreArg CoreExpr{-NB!-} Unused
310 mkAppDs :: CoreExpr -> [DsCoreArg] -> DsM CoreExpr
311 mkConDs :: Id -> [DsCoreArg] -> DsM CoreExpr
312 mkPrimDs :: PrimOp -> [DsCoreArg] -> DsM CoreExpr
315 = dsArgsToAtoms args $ \ atoms ->
316 returnDs (mkGenApp fun atoms)
319 = dsArgsToAtoms args $ \ atoms ->
320 returnDs (Con con atoms)
323 = dsArgsToAtoms args $ \ atoms ->
324 returnDs (Prim op atoms)
328 showForErr :: Outputable a => a -> String -- Boring but useful
329 showForErr thing = showSDoc (ppr thing)
331 mkErrorAppDs :: Id -- The error function
332 -> Type -- Type to which it should be applied
333 -> String -- The error message string to pass
336 mkErrorAppDs err_id ty msg
337 = getSrcLocDs `thenDs` \ src_loc ->
339 full_msg = showSDoc (hcat [ppr src_loc, text "|", text msg])
340 msg_lit = NoRepStr (_PK_ full_msg)
342 returnDs (mkApp (Var err_id) [ty] [LitArg msg_lit])
345 %************************************************************************
347 \subsection[mkSelectorBind]{Make a selector bind}
349 %************************************************************************
351 This is used in various places to do with lazy patterns.
352 For each binder $b$ in the pattern, we create a binding:
354 b = case v of pat' -> b'
356 where pat' is pat with each binder b cloned into b'.
358 ToDo: making these bindings should really depend on whether there's
359 much work to be done per binding. If the pattern is complex, it
360 should be de-mangled once, into a tuple (and then selected from).
361 Otherwise the demangling can be in-line in the bindings (as here).
363 Boring! Boring! One error message per binder. The above ToDo is
364 even more helpful. Something very similar happens for pattern-bound
368 mkSelectorBinds :: TypecheckedPat -- The pattern
369 -> CoreExpr -- Expression to which the pattern is bound
370 -> DsM [(Id,CoreExpr)]
372 mkSelectorBinds (VarPat v) val_expr
373 = returnDs [(v, val_expr)]
375 mkSelectorBinds pat val_expr
376 | is_simple_tuple_pat pat
377 = mkTupleBind binders val_expr
380 = mkErrorAppDs iRREFUT_PAT_ERROR_ID res_ty pat_string `thenDs` \ error_expr ->
381 matchSimply val_expr LetMatch pat res_ty local_tuple error_expr `thenDs` \ tuple_expr ->
382 mkTupleBind binders tuple_expr
385 binders = collectTypedPatBinders pat
386 local_tuple = mkTupleExpr binders
387 res_ty = coreExprType local_tuple
389 is_simple_tuple_pat (TuplePat ps) = all is_var_pat ps
390 is_simple_tuple_pat other = False
392 is_var_pat (VarPat v) = True
393 is_var_pat other = False -- Even wild-card patterns aren't acceptable
395 pat_string = showSDoc (ppr pat)
400 mkTupleBind :: [Id] -- Names of tuple components
401 -> CoreExpr -- Expr whose value is a tuple of correct type
402 -> DsM [(Id, CoreExpr)] -- Bindings for the globals
405 mkTupleBind [local] tuple_expr
406 = returnDs [(local, tuple_expr)]
408 mkTupleBind locals tuple_expr
409 = newSysLocalDs (coreExprType tuple_expr) `thenDs` \ tuple_var ->
411 mk_bind local = (local, mkTupleSelector locals local (Var tuple_var))
413 returnDs ( (tuple_var, tuple_expr) :
418 @mkTupleExpr@ builds a tuple; the inverse to @mkTupleSelector@. If it
419 has only one element, it is the identity function.
421 mkTupleExpr :: [Id] -> CoreExpr
423 mkTupleExpr [] = Con unitDataCon []
424 mkTupleExpr [id] = Var id
425 mkTupleExpr ids = mkCon (tupleCon (length ids))
427 [ VarArg i | i <- ids ]
431 @mkTupleSelector@ builds a selector which scrutises the given
432 expression and extracts the one name from the list given.
433 If you want the no-shadowing rule to apply, the caller
434 is responsible for making sure that none of these names
437 If there is just one id in the ``tuple'', then the selector is
441 mkTupleSelector :: [Id] -- The tuple args
442 -> Id -- The selected one
443 -> CoreExpr -- Scrutinee
446 mkTupleSelector [] the_var scrut = panic "mkTupleSelector"
448 mkTupleSelector [var] should_be_the_same_var scrut
449 = ASSERT(var == should_be_the_same_var)
452 mkTupleSelector vars the_var scrut
453 = Case scrut (AlgAlts [(tupleCon arity, vars, Var the_var)]
460 %************************************************************************
462 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
464 %************************************************************************
466 Generally, we handle pattern matching failure like this: let-bind a
467 fail-variable, and use that variable if the thing fails:
469 let fail.33 = error "Help"
480 If the case can't fail, then there'll be no mention of fail.33, and the
481 simplifier will later discard it.
484 If it can fail in only one way, then the simplifier will inline it.
487 Only if it is used more than once will the let-binding remain.
490 There's a problem when the result of the case expression is of
491 unboxed type. Then the type of fail.33 is unboxed too, and
492 there is every chance that someone will change the let into a case:
498 which is of course utterly wrong. Rather than drop the condition that
499 only boxed types can be let-bound, we just turn the fail into a function
500 for the primitive case:
502 let fail.33 :: Void -> Int#
503 fail.33 = \_ -> error "Help"
512 Now fail.33 is a function, so it can be let-bound.
515 mkFailurePair :: Type -- Result type of the whole case expression
516 -> DsM (CoreExpr -> CoreBinding,
517 -- Binds the newly-created fail variable
518 -- to either the expression or \ _ -> expression
519 CoreExpr) -- Either the fail variable, or fail variable
520 -- applied to unit tuple
523 = newFailLocalDs (voidTy `mkFunTy` ty) `thenDs` \ fail_fun_var ->
524 newSysLocalDs voidTy `thenDs` \ fail_fun_arg ->
526 NonRec fail_fun_var (Lam (ValBinder fail_fun_arg) body),
527 App (Var fail_fun_var) (VarArg voidId))
530 = newFailLocalDs ty `thenDs` \ fail_var ->
531 returnDs (\ body -> NonRec fail_var body, Var fail_var)