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 (match, matchSimply )
34 import HsSyn ( HsExpr(..), OutPat(..), HsLit(..), Fixity,
35 Match, HsBinds, Stmt, DoOrListComp, HsType, ArithSeqInfo )
36 import TcHsSyn ( TypecheckedPat )
37 import DsHsSyn ( outPatType, collectTypedPatBinders )
42 import CoreUtils ( coreExprType, mkCoreIfThenElse )
43 import PrelVals ( iRREFUT_PAT_ERROR_ID, voidId )
44 import Id ( idType, dataConArgTys,
45 DataCon, DictVar, Id, GenId )
46 import Literal ( Literal(..) )
47 import PrimOp ( PrimOp )
48 import TyCon ( isNewTyCon, tyConDataCons )
49 import Type ( mkTyVarTys, mkRhoTy, mkForAllTys, mkFunTy,
50 isUnpointedType, mkTyConApp, splitAlgTyConApp,
53 import BasicTypes ( Unused )
54 import TysPrim ( voidTy )
55 import TysWiredIn ( tupleTyCon, unitDataCon, tupleCon )
56 import UniqSet ( mkUniqSet, minusUniqSet, uniqSetToList, UniqSet )
57 import Unique ( Unique )
62 %************************************************************************
64 %* Selecting match variables
66 %************************************************************************
68 We're about to match against some patterns. We want to make some
69 @Ids@ to use as match variables. If a pattern has an @Id@ readily at
70 hand, which should indeed be bound to the pattern as a whole, then use it;
71 otherwise, make one up.
74 selectMatchVars :: [TypecheckedPat] -> DsM [Id]
76 = mapDs var_from_pat_maybe pats
78 var_from_pat_maybe (VarPat var) = returnDs var
79 var_from_pat_maybe (AsPat var pat) = returnDs var
80 var_from_pat_maybe (LazyPat pat) = var_from_pat_maybe pat
81 var_from_pat_maybe other_pat
82 = newSysLocalDs (outPatType other_pat) -- OK, better make up one...
86 %************************************************************************
88 %* type synonym EquationInfo and access functions for its pieces *
90 %************************************************************************
91 \subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym}
93 The ``equation info'' used by @match@ is relatively complicated and
94 worthy of a type synonym and a few handy functions.
99 type EqnSet = UniqSet EqnNo
103 EqnNo -- The number of the equation
104 DsMatchContext -- The context info is used when producing warnings
105 -- about shadowed patterns. It's the context
106 -- of the *first* thing matched in this group.
107 -- Should perhaps be a list of them all!
108 [TypecheckedPat] -- the patterns for an eqn
109 MatchResult -- Encapsulates the guards and bindings
116 Type -- Type of argument expression
118 (CoreExpr -> CoreExpr)
119 -- Takes a expression to plug in at the
120 -- failure point(s). The expression should
123 data CanItFail = CanFail | CantFail
125 orFail CantFail CantFail = CantFail
129 mkCoLetsMatchResult :: [CoreBinding] -> MatchResult -> MatchResult
130 mkCoLetsMatchResult binds (MatchResult can_it_fail ty body_fn)
131 = MatchResult can_it_fail ty (\body -> mkCoLetsAny binds (body_fn body))
133 mkGuardedMatchResult :: CoreExpr -> MatchResult -> DsM MatchResult
134 mkGuardedMatchResult pred_expr (MatchResult can_it_fail ty body_fn)
135 = returnDs (MatchResult CanFail
137 (\fail -> mkCoreIfThenElse pred_expr (body_fn fail) fail)
140 mkCoPrimCaseMatchResult :: Id -- Scrutinee
141 -> [(Literal, MatchResult)] -- Alternatives
143 mkCoPrimCaseMatchResult var alts
144 = newSysLocalDs (idType var) `thenDs` \ wild ->
145 returnDs (MatchResult CanFail
149 ((_,MatchResult _ ty1 _) : _) = alts
151 mk_case alts wild fail_expr
152 = Case (Var var) (PrimAlts final_alts (BindDefault wild fail_expr))
154 final_alts = [ (lit, body_fn fail_expr)
155 | (lit, MatchResult _ _ body_fn) <- alts
159 mkCoAlgCaseMatchResult :: Id -- Scrutinee
160 -> [(DataCon, [Id], MatchResult)] -- Alternatives
163 mkCoAlgCaseMatchResult var alts
164 | isNewTyCon tycon -- newtype case; use a let
165 = ASSERT( newtype_sanity )
166 returnDs (mkCoLetsMatchResult [coercion_bind] match_result)
168 | otherwise -- datatype case
169 = -- Find all the constructors in the type which aren't
170 -- explicitly mentioned in the alternatives:
171 case un_mentioned_constructors of
172 [] -> -- All constructors mentioned, so no default needed
173 returnDs (MatchResult can_any_alt_fail
175 (mk_case alts (\ignore -> NoDefault)))
177 [con] -> -- Just one constructor missing, so add a case for it
178 -- We need to build new locals for the args of the constructor,
179 -- and figuring out their types is somewhat tiresome.
181 arg_tys = dataConArgTys con tycon_arg_tys
183 newSysLocalsDs arg_tys `thenDs` \ arg_ids ->
185 -- Now we are ready to construct the new alternative
187 new_alt = (con, arg_ids, MatchResult CanFail ty1 id)
189 returnDs (MatchResult CanFail
191 (mk_case (new_alt:alts) (\ignore -> NoDefault)))
193 other -> -- Many constructors missing, so use a default case
194 newSysLocalDs scrut_ty `thenDs` \ wild ->
195 returnDs (MatchResult CanFail
197 (mk_case alts (\fail_expr -> BindDefault wild fail_expr)))
200 scrut_ty = idType var
201 (tycon, tycon_arg_tys, _) = splitAlgTyConApp scrut_ty
204 (con_id, arg_ids, match_result) = head alts
205 arg_id = head arg_ids
206 coercion_bind = NonRec arg_id (Coerce (CoerceOut con_id)
209 newtype_sanity = null (tail alts) && null (tail arg_ids)
211 -- Stuff for data types
212 data_cons = tyConDataCons tycon
214 un_mentioned_constructors
215 = uniqSetToList (mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- alts] )
217 match_results = [match_result | (_,_,match_result) <- alts]
218 (MatchResult _ ty1 _ : _) = match_results
219 can_any_alt_fail = foldr1 orFail [can_it_fail | MatchResult can_it_fail _ _ <- match_results]
221 mk_case alts deflt_fn fail_expr
222 = Case (Var var) (AlgAlts final_alts (deflt_fn fail_expr))
224 final_alts = [ (con, args, body_fn fail_expr)
225 | (con, args, MatchResult _ _ body_fn) <- alts
229 combineMatchResults :: MatchResult -> MatchResult -> DsM MatchResult
230 combineMatchResults (MatchResult CanFail ty1 body_fn1)
231 (MatchResult can_it_fail2 ty2 body_fn2)
232 = mkFailurePair ty1 `thenDs` \ (bind_fn, duplicatable_expr) ->
234 new_body_fn1 = \body1 -> Let (bind_fn body1) (body_fn1 duplicatable_expr)
235 new_body_fn2 = \body2 -> new_body_fn1 (body_fn2 body2)
237 returnDs (MatchResult can_it_fail2 ty1 new_body_fn2)
239 combineMatchResults match_result1@(MatchResult CantFail ty body_fn1)
241 = returnDs match_result1
244 -- The difference in combineGRHSMatchResults is that there is no
245 -- need to let-bind to avoid code duplication
246 combineGRHSMatchResults :: MatchResult -> MatchResult -> DsM MatchResult
247 combineGRHSMatchResults (MatchResult CanFail ty1 body_fn1)
248 (MatchResult can_it_fail ty2 body_fn2)
249 = returnDs (MatchResult can_it_fail ty1 (\ body -> body_fn1 (body_fn2 body)))
251 combineGRHSMatchResults match_result1 match_result2
252 = -- Delegate to avoid duplication of code
253 combineMatchResults match_result1 match_result2
256 %************************************************************************
258 \subsection[dsExprToAtom]{Take an expression and produce an atom}
260 %************************************************************************
263 dsArgToAtom :: DsCoreArg -- The argument expression
264 -> (CoreArg -> DsM CoreExpr) -- Something taking the argument *atom*,
265 -- and delivering an expression E
266 -> DsM CoreExpr -- Either E or let x=arg-expr in E
268 dsArgToAtom (TyArg t) continue_with = continue_with (TyArg t)
269 dsArgToAtom (LitArg l) continue_with = continue_with (LitArg l)
270 dsArgToAtom (VarArg arg) continue_with = dsExprToAtomGivenTy arg (coreExprType arg) continue_with
273 :: CoreExpr -- The argument expression
274 -> Type -- Type of the argument
275 -> (CoreArg -> DsM CoreExpr) -- Something taking the argument *atom*,
276 -- and delivering an expression E
277 -> DsM CoreExpr -- Either E or let x=arg-expr in E
279 dsExprToAtomGivenTy (Var v) arg_ty continue_with = continue_with (VarArg v)
280 dsExprToAtomGivenTy (Lit v) arg_ty continue_with = continue_with (LitArg v)
281 dsExprToAtomGivenTy arg_expr arg_ty continue_with
282 = newSysLocalDs arg_ty `thenDs` \ arg_id ->
283 continue_with (VarArg arg_id) `thenDs` \ body ->
285 if isUnpointedType arg_ty
286 then Case arg_expr (PrimAlts [] (BindDefault arg_id body))
287 else Let (NonRec arg_id arg_expr) body
290 dsArgsToAtoms :: [DsCoreArg]
291 -> ([CoreArg] -> DsM CoreExpr)
294 dsArgsToAtoms [] continue_with = continue_with []
296 dsArgsToAtoms (arg:args) continue_with
297 = dsArgToAtom arg $ \ arg_atom ->
298 dsArgsToAtoms args $ \ arg_atoms ->
299 continue_with (arg_atom:arg_atoms)
302 %************************************************************************
304 \subsection{Desugarer's versions of some Core functions}
306 %************************************************************************
309 type DsCoreArg = GenCoreArg CoreExpr{-NB!-} Unused
311 mkAppDs :: CoreExpr -> [DsCoreArg] -> DsM CoreExpr
312 mkConDs :: Id -> [DsCoreArg] -> DsM CoreExpr
313 mkPrimDs :: PrimOp -> [DsCoreArg] -> DsM CoreExpr
316 = dsArgsToAtoms args $ \ atoms ->
317 returnDs (mkGenApp fun atoms)
320 = dsArgsToAtoms args $ \ atoms ->
321 returnDs (Con con atoms)
324 = dsArgsToAtoms args $ \ atoms ->
325 returnDs (Prim op atoms)
329 showForErr :: Outputable a => a -> String -- Boring but useful
330 showForErr thing = showSDoc (ppr thing)
332 mkErrorAppDs :: Id -- The error function
333 -> Type -- Type to which it should be applied
334 -> String -- The error message string to pass
337 mkErrorAppDs err_id ty msg
338 = getSrcLocDs `thenDs` \ src_loc ->
340 full_msg = showSDoc (hcat [ppr src_loc, text "|", text msg])
341 msg_lit = NoRepStr (_PK_ full_msg)
343 returnDs (mkApp (Var err_id) [ty] [LitArg msg_lit])
346 %************************************************************************
348 \subsection[mkSelectorBind]{Make a selector bind}
350 %************************************************************************
352 This is used in various places to do with lazy patterns.
353 For each binder $b$ in the pattern, we create a binding:
355 b = case v of pat' -> b'
357 where pat' is pat with each binder b cloned into b'.
359 ToDo: making these bindings should really depend on whether there's
360 much work to be done per binding. If the pattern is complex, it
361 should be de-mangled once, into a tuple (and then selected from).
362 Otherwise the demangling can be in-line in the bindings (as here).
364 Boring! Boring! One error message per binder. The above ToDo is
365 even more helpful. Something very similar happens for pattern-bound
369 mkSelectorBinds :: TypecheckedPat -- The pattern
370 -> CoreExpr -- Expression to which the pattern is bound
371 -> DsM [(Id,CoreExpr)]
373 mkSelectorBinds (VarPat v) val_expr
374 = returnDs [(v, val_expr)]
376 mkSelectorBinds pat val_expr
377 | is_simple_tuple_pat pat
378 = mkTupleBind binders val_expr
381 = mkErrorAppDs iRREFUT_PAT_ERROR_ID res_ty pat_string `thenDs` \ error_expr ->
382 matchSimply val_expr LetMatch pat res_ty local_tuple error_expr `thenDs` \ tuple_expr ->
383 mkTupleBind binders tuple_expr
386 binders = collectTypedPatBinders pat
387 local_tuple = mkTupleExpr binders
388 res_ty = coreExprType local_tuple
390 is_simple_tuple_pat (TuplePat ps) = all is_var_pat ps
391 is_simple_tuple_pat other = False
393 is_var_pat (VarPat v) = True
394 is_var_pat other = False -- Even wild-card patterns aren't acceptable
396 pat_string = showSDoc (ppr pat)
401 mkTupleBind :: [Id] -- Names of tuple components
402 -> CoreExpr -- Expr whose value is a tuple of correct type
403 -> DsM [(Id, CoreExpr)] -- Bindings for the globals
406 mkTupleBind [local] tuple_expr
407 = returnDs [(local, tuple_expr)]
409 mkTupleBind locals tuple_expr
410 = newSysLocalDs (coreExprType tuple_expr) `thenDs` \ tuple_var ->
412 mk_bind local = (local, mkTupleSelector locals local (Var tuple_var))
414 returnDs ( (tuple_var, tuple_expr) :
419 @mkTupleExpr@ builds a tuple; the inverse to @mkTupleSelector@. If it
420 has only one element, it is the identity function.
422 mkTupleExpr :: [Id] -> CoreExpr
424 mkTupleExpr [] = Con unitDataCon []
425 mkTupleExpr [id] = Var id
426 mkTupleExpr ids = mkCon (tupleCon (length ids))
428 [ VarArg i | i <- ids ]
432 @mkTupleSelector@ builds a selector which scrutises the given
433 expression and extracts the one name from the list given.
434 If you want the no-shadowing rule to apply, the caller
435 is responsible for making sure that none of these names
438 If there is just one id in the ``tuple'', then the selector is
442 mkTupleSelector :: [Id] -- The tuple args
443 -> Id -- The selected one
444 -> CoreExpr -- Scrutinee
447 mkTupleSelector [] the_var scrut = panic "mkTupleSelector"
449 mkTupleSelector [var] should_be_the_same_var scrut
450 = ASSERT(var == should_be_the_same_var)
453 mkTupleSelector vars the_var scrut
454 = Case scrut (AlgAlts [(tupleCon arity, vars, Var the_var)]
461 %************************************************************************
463 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
465 %************************************************************************
467 Generally, we handle pattern matching failure like this: let-bind a
468 fail-variable, and use that variable if the thing fails:
470 let fail.33 = error "Help"
481 If the case can't fail, then there'll be no mention of fail.33, and the
482 simplifier will later discard it.
485 If it can fail in only one way, then the simplifier will inline it.
488 Only if it is used more than once will the let-binding remain.
491 There's a problem when the result of the case expression is of
492 unboxed type. Then the type of fail.33 is unboxed too, and
493 there is every chance that someone will change the let into a case:
499 which is of course utterly wrong. Rather than drop the condition that
500 only boxed types can be let-bound, we just turn the fail into a function
501 for the primitive case:
503 let fail.33 :: Void -> Int#
504 fail.33 = \_ -> error "Help"
513 Now fail.33 is a function, so it can be let-bound.
516 mkFailurePair :: Type -- Result type of the whole case expression
517 -> DsM (CoreExpr -> CoreBinding,
518 -- Binds the newly-created fail variable
519 -- to either the expression or \ _ -> expression
520 CoreExpr) -- Either the fail variable, or fail variable
521 -- applied to unit tuple
524 = newFailLocalDs (voidTy `mkFunTy` ty) `thenDs` \ fail_fun_var ->
525 newSysLocalDs voidTy `thenDs` \ fail_fun_arg ->
527 NonRec fail_fun_var (Lam (ValBinder fail_fun_arg) body),
528 App (Var fail_fun_var) (VarArg voidId))
531 = newFailLocalDs ty `thenDs` \ fail_var ->
532 returnDs (\ body -> NonRec fail_var body, Var fail_var)