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,
16 dsExprToAtom, SYN_IE(DsCoreArg),
17 mkCoAlgCaseMatchResult,
18 mkAppDs, mkConDs, mkPrimDs, mkErrorAppDs,
20 mkCoPrimCaseMatchResult,
31 IMPORT_DELOOPER(DsLoop) ( match, matchSimply )
33 import HsSyn ( HsExpr(..), OutPat(..), HsLit(..),
34 Match, HsBinds, Stmt, Qualifier, PolyType, ArithSeqInfo )
35 import TcHsSyn ( SYN_IE(TypecheckedPat) )
36 import DsHsSyn ( outPatType )
41 import CoreUtils ( coreExprType, mkCoreIfThenElse )
42 import PprStyle ( PprStyle(..) )
43 import PrelVals ( iRREFUT_PAT_ERROR_ID, voidId )
44 import Pretty ( ppShow )
45 import Id ( idType, dataConArgTys, mkTupleCon,
47 SYN_IE(DataCon), SYN_IE(DictVar), SYN_IE(Id), GenId )
48 import Literal ( Literal(..) )
49 import TyCon ( mkTupleTyCon, isNewTyCon, tyConDataCons )
50 import Type ( mkTyVarTys, mkRhoTy, mkForAllTys, mkFunTy,
51 mkTheta, isUnboxedType, applyTyCon, getAppTyCon
53 import TysPrim ( voidTy )
54 import UniqSet ( mkUniqSet, minusUniqSet, uniqSetToList, SYN_IE(UniqSet) )
55 import Util ( panic, assertPanic, pprTrace{-ToDo:rm-} )
56 import PprCore{-ToDo:rm-}
57 --import PprType--ToDo:rm
58 import Pretty--ToDo:rm
60 import Unique--ToDo:rm
64 %************************************************************************
66 %* type synonym EquationInfo and access functions for its pieces *
68 %************************************************************************
69 \subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym}
71 The ``equation info'' used by @match@ is relatively complicated and
72 worthy of a type synonym and a few handy functions.
77 [TypecheckedPat] -- the patterns for an eqn
78 MatchResult -- Encapsulates the guards and bindings
85 Type -- Type of argument expression
87 (CoreExpr -> CoreExpr)
88 -- Takes a expression to plug in at the
89 -- failure point(s). The expression should
92 DsMatchContext -- The context info is used when producing warnings
93 -- about shadowed patterns. It's the context
94 -- of the *first* thing matched in this group.
95 -- Should perhaps be a list of them all!
97 data CanItFail = CanFail | CantFail
99 orFail CantFail CantFail = CantFail
103 mkCoLetsMatchResult :: [CoreBinding] -> MatchResult -> MatchResult
104 mkCoLetsMatchResult binds (MatchResult can_it_fail ty body_fn cxt)
105 = MatchResult can_it_fail ty (\body -> mkCoLetsAny binds (body_fn body)) cxt
107 mkGuardedMatchResult :: CoreExpr -> MatchResult -> DsM MatchResult
108 mkGuardedMatchResult pred_expr (MatchResult can_it_fail ty body_fn cxt)
109 = returnDs (MatchResult CanFail
111 (\fail -> mkCoreIfThenElse pred_expr (body_fn fail) fail)
115 mkCoPrimCaseMatchResult :: Id -- Scrutinee
116 -> [(Literal, MatchResult)] -- Alternatives
118 mkCoPrimCaseMatchResult var alts
119 = newSysLocalDs (idType var) `thenDs` \ wild ->
120 returnDs (MatchResult CanFail
125 ((_,MatchResult _ ty1 _ cxt1) : _) = alts
127 mk_case alts wild fail_expr
128 = Case (Var var) (PrimAlts final_alts (BindDefault wild fail_expr))
130 final_alts = [ (lit, body_fn fail_expr)
131 | (lit, MatchResult _ _ body_fn _) <- alts
135 mkCoAlgCaseMatchResult :: Id -- Scrutinee
136 -> [(DataCon, [Id], MatchResult)] -- Alternatives
139 mkCoAlgCaseMatchResult var alts
140 | isNewTyCon tycon -- newtype case; use a let
141 = ASSERT( newtype_sanity )
142 returnDs (mkCoLetsMatchResult [coercion_bind] match_result)
144 | otherwise -- datatype case
145 = -- Find all the constructors in the type which aren't
146 -- explicitly mentioned in the alternatives:
147 case un_mentioned_constructors of
148 [] -> -- All constructors mentioned, so no default needed
149 returnDs (MatchResult can_any_alt_fail
151 (mk_case alts (\ignore -> NoDefault))
154 [con] -> -- Just one constructor missing, so add a case for it
155 -- We need to build new locals for the args of the constructor,
156 -- and figuring out their types is somewhat tiresome.
158 arg_tys = dataConArgTys con tycon_arg_tys
160 newSysLocalsDs arg_tys `thenDs` \ arg_ids ->
162 -- Now we are ready to construct the new alternative
164 new_alt = (con, arg_ids, MatchResult CanFail ty1 id NoMatchContext)
166 returnDs (MatchResult CanFail
168 (mk_case (new_alt:alts) (\ignore -> NoDefault))
171 other -> -- Many constructors missing, so use a default case
172 newSysLocalDs scrut_ty `thenDs` \ wild ->
173 returnDs (MatchResult CanFail
175 (mk_case alts (\fail_expr -> BindDefault wild fail_expr))
179 scrut_ty = idType var
180 (tycon, tycon_arg_tys) = --pprTrace "CoAlgCase:" (pprType PprDebug scrut_ty) $
184 (con_id, arg_ids, match_result) = head alts
185 arg_id = head arg_ids
186 coercion_bind = NonRec arg_id (Coerce (CoerceOut con_id)
189 newtype_sanity = null (tail alts) && null (tail arg_ids)
191 -- Stuff for data types
192 data_cons = tyConDataCons tycon
194 un_mentioned_constructors
195 = uniqSetToList (mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- alts] )
197 match_results = [match_result | (_,_,match_result) <- alts]
198 (MatchResult _ ty1 _ cxt1 : _) = match_results
199 can_any_alt_fail = foldr1 orFail [can_it_fail | MatchResult can_it_fail _ _ _ <- match_results]
201 mk_case alts deflt_fn fail_expr
202 = Case (Var var) (AlgAlts final_alts (deflt_fn fail_expr))
204 final_alts = [ (con, args, body_fn fail_expr)
205 | (con, args, MatchResult _ _ body_fn _) <- alts
209 combineMatchResults :: MatchResult -> MatchResult -> DsM MatchResult
210 combineMatchResults (MatchResult CanFail ty1 body_fn1 cxt1)
211 (MatchResult can_it_fail2 ty2 body_fn2 cxt2)
212 = mkFailurePair ty1 `thenDs` \ (bind_fn, duplicatable_expr) ->
214 new_body_fn1 = \body1 -> Let (bind_fn body1) (body_fn1 duplicatable_expr)
215 new_body_fn2 = \body2 -> new_body_fn1 (body_fn2 body2)
217 returnDs (MatchResult can_it_fail2 ty1 new_body_fn2 cxt1)
219 combineMatchResults match_result1@(MatchResult CantFail ty body_fn1 cxt1)
221 = returnDs match_result1
224 -- The difference in combineGRHSMatchResults is that there is no
225 -- need to let-bind to avoid code duplication
226 combineGRHSMatchResults :: MatchResult -> MatchResult -> DsM MatchResult
227 combineGRHSMatchResults (MatchResult CanFail ty1 body_fn1 cxt1)
228 (MatchResult can_it_fail ty2 body_fn2 cxt2)
229 = returnDs (MatchResult can_it_fail ty1 (\ body -> body_fn1 (body_fn2 body)) cxt1)
231 combineGRHSMatchResults match_result1 match_result2
232 = -- Delegate to avoid duplication of code
233 combineMatchResults match_result1 match_result2
236 %************************************************************************
238 \subsection[dsExprToAtom]{Take an expression and produce an atom}
240 %************************************************************************
243 dsExprToAtom :: DsCoreArg -- The argument expression
244 -> (CoreArg -> DsM CoreExpr) -- Something taking the argument *atom*,
245 -- and delivering an expression E
246 -> DsM CoreExpr -- Either E or let x=arg-expr in E
248 dsExprToAtom (UsageArg u) continue_with = continue_with (UsageArg u)
249 dsExprToAtom (TyArg t) continue_with = continue_with (TyArg t)
250 dsExprToAtom (LitArg l) continue_with = continue_with (LitArg l)
252 dsExprToAtom (VarArg (Var v)) continue_with = continue_with (VarArg v)
253 dsExprToAtom (VarArg (Lit v)) continue_with = continue_with (LitArg v)
255 dsExprToAtom (VarArg arg_expr) continue_with
257 ty = coreExprType arg_expr
259 newSysLocalDs ty `thenDs` \ arg_id ->
260 continue_with (VarArg arg_id) `thenDs` \ body ->
263 then Case arg_expr (PrimAlts [] (BindDefault arg_id body))
264 else Let (NonRec arg_id arg_expr) body
267 dsExprsToAtoms :: [DsCoreArg]
268 -> ([CoreArg] -> DsM CoreExpr)
271 dsExprsToAtoms [] continue_with = continue_with []
273 dsExprsToAtoms (arg:args) continue_with
274 = dsExprToAtom arg $ \ arg_atom ->
275 dsExprsToAtoms args $ \ arg_atoms ->
276 continue_with (arg_atom:arg_atoms)
279 %************************************************************************
281 \subsection{Desugarer's versions of some Core functions}
283 %************************************************************************
286 type DsCoreArg = GenCoreArg CoreExpr{-NB!-} TyVar UVar
288 mkAppDs :: CoreExpr -> [DsCoreArg] -> DsM CoreExpr
289 mkConDs :: Id -> [DsCoreArg] -> DsM CoreExpr
290 mkPrimDs :: PrimOp -> [DsCoreArg] -> DsM CoreExpr
293 = dsExprsToAtoms args $ \ atoms ->
294 returnDs (mkGenApp fun atoms)
297 = dsExprsToAtoms args $ \ atoms ->
298 returnDs (Con con atoms)
301 = dsExprsToAtoms args $ \ atoms ->
302 returnDs (Prim op atoms)
306 showForErr :: Outputable a => a -> String -- Boring but useful
307 showForErr thing = ppShow 80 (ppr PprForUser thing)
309 mkErrorAppDs :: Id -- The error function
310 -> Type -- Type to which it should be applied
311 -> String -- The error message string to pass
314 mkErrorAppDs err_id ty msg
315 = getSrcLocDs `thenDs` \ (file, line) ->
317 full_msg = file ++ "|" ++ line ++ "|" ++msg
318 msg_lit = NoRepStr (_PK_ full_msg)
320 returnDs (mkApp (Var err_id) [] [ty] [LitArg msg_lit])
323 %************************************************************************
325 \subsection[mkSelectorBind]{Make a selector bind}
327 %************************************************************************
329 This is used in various places to do with lazy patterns.
330 For each binder $b$ in the pattern, we create a binding:
332 b = case v of pat' -> b'
334 where pat' is pat with each binder b cloned into b'.
336 ToDo: making these bindings should really depend on whether there's
337 much work to be done per binding. If the pattern is complex, it
338 should be de-mangled once, into a tuple (and then selected from).
339 Otherwise the demangling can be in-line in the bindings (as here).
341 Boring! Boring! One error message per binder. The above ToDo is
342 even more helpful. Something very similar happens for pattern-bound
346 mkSelectorBinds :: [TyVar] -- Variables wrt which the pattern is polymorphic
347 -> TypecheckedPat -- The pattern
348 -> [(Id,Id)] -- Monomorphic and polymorphic binders for
350 -> CoreExpr -- Expression to which the pattern is bound
351 -> DsM [(Id,CoreExpr)]
353 mkSelectorBinds tyvars pat locals_and_globals val_expr
354 = if is_simple_tuple_pat pat then
355 mkTupleBind tyvars [] locals_and_globals val_expr
357 mkErrorAppDs iRREFUT_PAT_ERROR_ID res_ty "" `thenDs` \ error_msg ->
358 matchSimply val_expr pat res_ty local_tuple error_msg `thenDs` \ tuple_expr ->
359 mkTupleBind tyvars [] locals_and_globals tuple_expr
361 locals = [local | (local, _) <- locals_and_globals]
362 local_tuple = mkTupleExpr locals
363 res_ty = coreExprType local_tuple
365 is_simple_tuple_pat (TuplePat ps) = all is_var_pat ps
366 is_simple_tuple_pat other = False
368 is_var_pat (VarPat v) = True
369 is_var_pat other = False -- Even wild-card patterns aren't acceptable
372 We're about to match against some patterns. We want to make some
373 @Ids@ to use as match variables. If a pattern has an @Id@ readily at
374 hand, which should indeed be bound to the pattern as a whole, then use it;
375 otherwise, make one up.
377 selectMatchVars :: [TypecheckedPat] -> DsM [Id]
379 = mapDs var_from_pat_maybe pats
381 var_from_pat_maybe (VarPat var) = returnDs var
382 var_from_pat_maybe (AsPat var pat) = returnDs var
383 var_from_pat_maybe (LazyPat pat) = var_from_pat_maybe pat
384 var_from_pat_maybe other_pat
385 = newSysLocalDs (outPatType other_pat) -- OK, better make up one...
389 mkTupleBind :: [TyVar] -- Abstract wrt these...
390 -> [DictVar] -- ... and these
392 -> [(Id, Id)] -- Local, global pairs, equal in number
393 -- to the size of the tuple. The types
394 -- of the globals is the generalisation of
395 -- the corresp local, wrt the tyvars and dicts
397 -> CoreExpr -- Expr whose value is a tuple; the expression
398 -- may mention the tyvars and dicts
400 -> DsM [(Id, CoreExpr)] -- Bindings for the globals
405 mkTupleBind tyvars dicts [(l1,g1), ..., (ln,gn)] tup_expr
407 If $n=1$, the result is:
409 g1 = /\ tyvars -> \ dicts -> rhs
411 Otherwise, the result is:
413 tup = /\ tyvars -> \ dicts -> tup_expr
414 g1 = /\ tyvars -> \ dicts -> case (tup tyvars dicts) of
420 mkTupleBind tyvars dicts [(local,global)] tuple_expr
421 = returnDs [(global, mkLam tyvars dicts tuple_expr)]
427 mkTupleBind tyvars dicts local_global_prs tuple_expr
428 = --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]) $
430 newSysLocalDs tuple_var_ty `thenDs` \ tuple_var ->
432 zipWithDs (mk_selector (Var tuple_var))
434 [(0::Int) .. (length local_global_prs - 1)]
435 `thenDs` \ tup_selectors ->
437 (tuple_var, mkLam tyvars dicts tuple_expr)
441 locals, globals :: [Id]
442 locals = [local | (local,global) <- local_global_prs]
443 globals = [global | (local,global) <- local_global_prs]
445 no_of_binders = length local_global_prs
446 tyvar_tys = mkTyVarTys tyvars
450 = mkForAllTys tyvars $
452 applyTyCon (mkTupleTyCon no_of_binders)
455 theta = mkTheta (map idType dicts)
457 mk_selector :: CoreExpr -> (Id, Id) -> Int -> DsM (Id, CoreExpr)
459 mk_selector tuple_var_expr (local, global) which_local
460 = mapDs duplicateLocalDs locals{-the whole bunch-} `thenDs` \ binders ->
462 selected = binders !! which_local
468 (mkValApp (mkTyApp tuple_var_expr tyvar_tys)
475 @mkTupleExpr@ builds a tuple; the inverse to @mkTupleSelector@. If it
476 has only one element, it is the identity function.
478 mkTupleExpr :: [Id] -> CoreExpr
480 mkTupleExpr [] = Con (mkTupleCon 0) []
481 mkTupleExpr [id] = Var id
482 mkTupleExpr ids = mkCon (mkTupleCon (length ids))
485 [ VarArg i | i <- ids ]
489 @mkTupleSelector@ builds a selector which scrutises the given
490 expression and extracts the one name from the list given.
491 If you want the no-shadowing rule to apply, the caller
492 is responsible for making sure that none of these names
495 If there is just one id in the ``tuple'', then the selector is
499 mkTupleSelector :: CoreExpr -- Scrutinee
500 -> [Id] -- The tuple args
501 -> Id -- The selected one
504 mkTupleSelector expr [] the_var = panic "mkTupleSelector"
506 mkTupleSelector expr [var] should_be_the_same_var
507 = ASSERT(var == should_be_the_same_var)
510 mkTupleSelector expr vars the_var
511 = Case expr (AlgAlts [(mkTupleCon arity, vars, Var the_var)]
518 %************************************************************************
520 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
522 %************************************************************************
524 Generally, we handle pattern matching failure like this: let-bind a
525 fail-variable, and use that variable if the thing fails:
527 let fail.33 = error "Help"
538 If the case can't fail, then there'll be no mention of fail.33, and the
539 simplifier will later discard it.
542 If it can fail in only one way, then the simplifier will inline it.
545 Only if it is used more than once will the let-binding remain.
548 There's a problem when the result of the case expression is of
549 unboxed type. Then the type of fail.33 is unboxed too, and
550 there is every chance that someone will change the let into a case:
556 which is of course utterly wrong. Rather than drop the condition that
557 only boxed types can be let-bound, we just turn the fail into a function
558 for the primitive case:
560 let fail.33 :: Void -> Int#
561 fail.33 = \_ -> error "Help"
570 Now fail.33 is a function, so it can be let-bound.
573 mkFailurePair :: Type -- Result type of the whole case expression
574 -> DsM (CoreExpr -> CoreBinding,
575 -- Binds the newly-created fail variable
576 -- to either the expression or \ _ -> expression
577 CoreExpr) -- Either the fail variable, or fail variable
578 -- applied to unit tuple
581 = newFailLocalDs (voidTy `mkFunTy` ty) `thenDs` \ fail_fun_var ->
582 newSysLocalDs voidTy `thenDs` \ fail_fun_arg ->
584 NonRec fail_fun_var (Lam (ValBinder fail_fun_arg) body),
585 App (Var fail_fun_var) (VarArg voidId))
588 = newFailLocalDs ty `thenDs` \ fail_var ->
589 returnDs (\ body -> NonRec fail_var body, Var fail_var)