2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[CoreUtils]{Utility functions on @Core@ syntax}
7 #include "HsVersions.h"
10 coreExprType, coreAltsType, coreExprCc,
12 substCoreExpr, substCoreBindings
16 , unTagBinders, unTagBindersAlts
20 , squashableDictishCcExpr
27 import CostCentre ( isDictCC, CostCentre, noCostCentre )
28 import Id ( idType, mkSysLocal, isBottomingId,
29 toplevelishId, mkIdWithNewUniq, applyTypeEnvToId,
31 addOneToIdEnv, growIdEnvList, lookupIdEnv,
32 isNullIdEnv, SYN_IE(IdEnv),
33 GenId{-instances-}, SYN_IE(Id)
35 import Literal ( literalType, isNoRepLit, Literal(..) )
36 import Maybes ( catMaybes, maybeToBool )
38 import Outputable ( PprStyle(..), Outputable(..) )
39 import PprType ( GenType{-instances-}, GenTyVar )
40 import Pretty ( Doc, vcat )
41 import PrimOp ( primOpType, PrimOp(..) )
42 import SrcLoc ( noSrcLoc )
43 import TyVar ( cloneTyVar,
44 isNullTyVarEnv, addOneToTyVarEnv, SYN_IE(TyVarEnv),
45 SYN_IE(TyVar), GenTyVar
47 import Type ( mkFunTy, mkForAllTy, mkForAllUsageTy, mkTyVarTy,
48 getFunTyExpandingDicts_maybe, applyTy, isPrimType,
49 splitSigmaTy, splitFunTy, eqTy, applyTypeEnvToTy,
52 import TysWiredIn ( trueDataCon, falseDataCon )
53 import Unique ( Unique )
54 import UniqSupply ( initUs, returnUs, thenUs,
55 mapUs, mapAndUnzipUs, getUnique,
56 SYN_IE(UniqSM), UniqSupply
58 import Usage ( SYN_IE(UVar) )
59 import Util ( zipEqual, panic, pprTrace, pprPanic, assertPanic )
61 type TypeEnv = TyVarEnv Type
62 applyUsage = panic "CoreUtils.applyUsage:ToDo"
65 %************************************************************************
67 \subsection{Find the type of a Core atom/expression}
69 %************************************************************************
72 coreExprType :: CoreExpr -> Type
74 coreExprType (Var var) = idType var
75 coreExprType (Lit lit) = literalType lit
77 coreExprType (Let _ body) = coreExprType body
78 coreExprType (SCC _ expr) = coreExprType expr
79 coreExprType (Case _ alts) = coreAltsType alts
81 coreExprType (Coerce _ ty _) = ty -- that's the whole point!
83 -- a Con is a fully-saturated application of a data constructor
84 -- a Prim is <ditto> of a PrimOp
86 coreExprType (Con con args) =
87 -- pprTrace "appTyArgs" (hsep [ppr PprDebug con, semi,
88 -- ppr PprDebug con_ty, semi,
89 -- ppr PprDebug args]) $
90 applyTypeToArgs con_ty args
92 con_ty = dataConRepType con
94 coreExprType (Prim op args) = applyTypeToArgs (primOpType op) args
96 coreExprType (Lam (ValBinder binder) expr)
97 = idType binder `mkFunTy` coreExprType expr
99 coreExprType (Lam (TyBinder tyvar) expr)
100 = mkForAllTy tyvar (coreExprType expr)
102 coreExprType (Lam (UsageBinder uvar) expr)
103 = mkForAllUsageTy uvar (panic "coreExprType:Lam UsageBinder") (coreExprType expr)
105 coreExprType (App expr (TyArg ty))
107 -- pprTrace "appTy1" (hsep [ppr PprDebug fun_ty, space, ppr PprDebug ty]) $
110 fun_ty = coreExprType expr
112 coreExprType (App expr (UsageArg use))
113 = applyUsage (coreExprType expr) use
115 coreExprType (App expr val_arg)
116 = ASSERT(isValArg val_arg)
118 fun_ty = coreExprType expr
120 case (getFunTyExpandingDicts_maybe False{-no peeking-} fun_ty) of
121 Just (_, result_ty) -> result_ty
123 Nothing -> pprPanic "coreExprType:\n"
124 (vcat [ppr PprDebug fun_ty,
125 ppr PprShowAll (App expr val_arg)])
130 coreAltsType :: CoreCaseAlts -> Type
132 coreAltsType (AlgAlts [] deflt) = default_ty deflt
133 coreAltsType (AlgAlts ((_,_,rhs1):_) _) = coreExprType rhs1
135 coreAltsType (PrimAlts [] deflt) = default_ty deflt
136 coreAltsType (PrimAlts ((_,rhs1):_) _) = coreExprType rhs1
138 default_ty NoDefault = panic "coreExprType:Case:default_ty"
139 default_ty (BindDefault _ rhs) = coreExprType rhs
143 applyTypeToArgs op_ty args = foldl applyTypeToArg op_ty args
145 applyTypeToArg op_ty (TyArg ty) = applyTy op_ty ty
146 applyTypeToArg op_ty (UsageArg _) = panic "applyTypeToArg: UsageArg"
147 applyTypeToArg op_ty val_or_lit_arg = case (getFunTyExpandingDicts_maybe False{-no peeking-} op_ty) of
148 Just (_, res_ty) -> res_ty
151 coreExprCc gets the cost centre enclosing an expression, if any.
152 It looks inside lambdas because (scc "foo" \x.e) = \x.scc "foo" e
155 coreExprCc :: GenCoreExpr val_bdr val_occ tyvar uvar -> CostCentre
156 coreExprCc (SCC cc e) = cc
157 coreExprCc (Lam _ e) = coreExprCc e
158 coreExprCc other = noCostCentre
161 %************************************************************************
163 \subsection{Routines to manufacture bits of @CoreExpr@}
165 %************************************************************************
168 mkCoreIfThenElse (Var bool) then_expr else_expr
169 | bool == trueDataCon = then_expr
170 | bool == falseDataCon = else_expr
172 mkCoreIfThenElse guard then_expr else_expr
174 (AlgAlts [ (trueDataCon, [], then_expr),
175 (falseDataCon, [], else_expr) ]
179 For making @Apps@ and @Lets@, we must take appropriate evasive
180 action if the thing being bound has unboxed type. @mkCoApp@ requires
181 a name supply to do its work.
183 @mkCoApps@, @mkCoCon@ and @mkCoPrim@ also handle the
184 arguments-must-be-atoms constraint.
191 mkCoApps :: CoreExpr -> [CoreArgOrExpr] -> UniqSM CoreExpr
192 mkCoCon :: Id -> [CoreArgOrExpr] -> UniqSM CoreExpr
193 mkCoPrim :: PrimOp -> [CoreArgOrExpr] -> UniqSM CoreExpr
195 mkCoApps fun args = co_thing (mkGenApp fun) args
196 mkCoCon con args = co_thing (Con con) args
197 mkCoPrim op args = co_thing (Prim op) args
199 co_thing :: ([CoreArg] -> CoreExpr)
203 co_thing thing arg_exprs
204 = mapAndUnzipUs expr_to_arg arg_exprs `thenUs` \ (args, maybe_binds) ->
205 returnUs (mkCoLetsUnboxedToCase (catMaybes maybe_binds) (thing args))
207 expr_to_arg :: CoreArgOrExpr
208 -> UniqSM (CoreArg, Maybe CoreBinding)
210 expr_to_arg (AnArg arg) = returnUs (arg, Nothing)
211 expr_to_arg (AnExpr (Var v)) = returnUs (VarArg v, Nothing)
212 expr_to_arg (AnExpr (Lit l)) = returnUs (LitArg l, Nothing)
213 expr_to_arg (AnExpr other_expr)
215 e_ty = coreExprType other_expr
217 getUnique `thenUs` \ uniq ->
219 new_var = mkSysLocal SLIT("a") uniq e_ty noSrcLoc
221 returnUs (VarArg new_var, Just (NonRec new_var other_expr))
226 GenCoreArg val_occ tyvar uvar -> GenCoreExpr val_bdr val_occ tyvar uvar
228 argToExpr (VarArg v) = Var v
229 argToExpr (LitArg lit) = Lit lit
232 All the following functions operate on binders, perform a uniform
233 transformation on them; ie. the function @(\ x -> (x,False))@
234 annotates all binders with False.
237 unTagBinders :: GenCoreExpr (Id,tag) bdee tv uv -> GenCoreExpr Id bdee tv uv
238 unTagBinders expr = bop_expr fst expr
240 unTagBindersAlts :: GenCoreCaseAlts (Id,tag) bdee tv uv -> GenCoreCaseAlts Id bdee tv uv
241 unTagBindersAlts alts = bop_alts fst alts
245 bop_expr :: (a -> b) -> GenCoreExpr a bdee tv uv -> GenCoreExpr b bdee tv uv
247 bop_expr f (Var b) = Var b
248 bop_expr f (Lit lit) = Lit lit
249 bop_expr f (Con con args) = Con con args
250 bop_expr f (Prim op args) = Prim op args
251 bop_expr f (Lam binder expr) = Lam (bop_binder f binder) (bop_expr f expr)
252 bop_expr f (App expr arg) = App (bop_expr f expr) arg
253 bop_expr f (SCC label expr) = SCC label (bop_expr f expr)
254 bop_expr f (Coerce c ty e) = Coerce c ty (bop_expr f e)
255 bop_expr f (Let bind expr) = Let (bop_bind f bind) (bop_expr f expr)
256 bop_expr f (Case expr alts) = Case (bop_expr f expr) (bop_alts f alts)
258 bop_binder f (ValBinder v) = ValBinder (f v)
259 bop_binder f (TyBinder t) = TyBinder t
260 bop_binder f (UsageBinder u) = UsageBinder u
262 bop_bind f (NonRec b e) = NonRec (f b) (bop_expr f e)
263 bop_bind f (Rec pairs) = Rec [(f b, bop_expr f e) | (b, e) <- pairs]
265 bop_alts f (AlgAlts alts deflt)
266 = AlgAlts [ (con, [f b | b <- binders], bop_expr f e)
267 | (con, binders, e) <- alts ]
270 bop_alts f (PrimAlts alts deflt)
271 = PrimAlts [ (lit, bop_expr f e) | (lit, e) <- alts ]
274 bop_deflt f (NoDefault) = NoDefault
275 bop_deflt f (BindDefault b expr) = BindDefault (f b) (bop_expr f expr)
278 OLD (but left here because of the nice example): @singleAlt@ checks
279 whether a bunch of case alternatives is actually just one alternative.
280 It specifically {\em ignores} alternatives which consist of just a
281 call to @error@, because they won't result in any code duplication.
285 case (case <something> of
287 False -> error "Foo") of
293 True -> case <rhs> of
295 False -> case error "Foo" of
301 True -> case <rhs> of
305 Notice that the \tr{<alts>} don't get duplicated.
308 nonErrorRHSs :: GenCoreCaseAlts a Id TyVar UVar -> [GenCoreExpr a Id TyVar UVar]
311 = filter not_error_app (find_rhss alts)
313 find_rhss (AlgAlts as deflt) = [rhs | (_,_,rhs) <- as] ++ deflt_rhs deflt
314 find_rhss (PrimAlts as deflt) = [rhs | (_,rhs) <- as] ++ deflt_rhs deflt
316 deflt_rhs NoDefault = []
317 deflt_rhs (BindDefault _ rhs) = [rhs]
320 = case (maybeErrorApp rhs Nothing) of
325 maybeErrorApp checks whether an expression is of the form
331 Just (error ty' args)
333 where ty' is supplied as an argument to maybeErrorApp.
335 Here's where it is useful:
337 case (error ty "Foo" e1 e2) of <alts>
341 where ty' is the type of any of the alternatives. You might think
342 this never occurs, but see the comments on the definition of
345 Note: we *avoid* the case where ty' might end up as a primitive type:
346 this is very uncool (totally wrong).
348 NOTICE: in the example above we threw away e1 and e2, but not the
349 string "Foo". How did we know to do that?
351 Answer: for now anyway, we only handle the case of a function whose
354 bottomingFn :: forall a. t1 -> ... -> tn -> a
355 ^---------------------^ NB!
357 Furthermore, we only count a bottomingApp if the function is applied
358 to more than n args. If so, we transform:
360 bottomingFn ty e1 ... en en+1 ... em
362 bottomingFn ty' e1 ... en
364 That is, we discard en+1 .. em
368 :: GenCoreExpr a Id TyVar UVar -- Expr to look at
369 -> Maybe Type -- Just ty => a result type *already cloned*;
370 -- Nothing => don't know result ty; we
371 -- *pretend* that the result ty won't be
372 -- primitive -- somebody later must
374 -> Maybe (GenCoreExpr b Id TyVar UVar)
376 maybeErrorApp expr result_ty_maybe
377 = case (collectArgs expr) of
378 (Var fun, [{-no usage???-}], [ty], other_args)
380 && maybeToBool result_ty_maybe -- we *know* the result type
381 -- (otherwise: live a fairy-tale existence...)
382 && not (isPrimType result_ty) ->
384 case (splitSigmaTy (idType fun)) of
385 ([tyvar], [], tau_ty) ->
386 case (splitFunTy tau_ty) of { (arg_tys, res_ty) ->
388 n_args_to_keep = length arg_tys
389 args_to_keep = take n_args_to_keep other_args
391 if (res_ty `eqTy` mkTyVarTy tyvar)
392 && n_args_to_keep <= length other_args
394 -- Phew! We're in business
395 Just (mkGenApp (Var fun) (TyArg result_ty : args_to_keep))
400 other -> Nothing -- Function type wrong shape
403 Just result_ty = result_ty_maybe
407 squashableDictishCcExpr :: CostCentre -> GenCoreExpr a b c d -> Bool
409 squashableDictishCcExpr cc expr
410 = if not (isDictCC cc) then
411 False -- that was easy...
413 squashable expr -- note: quite like the "atomic_rhs" stuff in simplifier
415 squashable (Var _) = True
416 squashable (Con _ _) = True -- I think so... WDP 94/09
417 squashable (Prim _ _) = True -- ditto
419 | notValArg a = squashable f
420 squashable other = False
423 %************************************************************************
425 \subsection{Core-renaming utils}
427 %************************************************************************
430 substCoreBindings :: ValEnv
431 -> TypeEnv -- TyVar=>Type
433 -> UniqSM [CoreBinding]
435 substCoreExpr :: ValEnv
436 -> TypeEnv -- TyVar=>Type
440 substCoreBindings venv tenv binds
441 -- if the envs are empty, then avoid doing anything
442 = if (isNullIdEnv venv && isNullTyVarEnv tenv) then
445 do_CoreBindings venv tenv binds
447 substCoreExpr venv tenv expr
448 = if (isNullIdEnv venv && isNullTyVarEnv tenv) then
451 do_CoreExpr venv tenv expr
454 The equiv code for @Types@ is in @TyUtils@.
456 Because binders aren't necessarily unique: we don't do @plusEnvs@
457 (which check for duplicates); rather, we use the shadowing version,
458 @growIdEnv@ (and shorthand @addOneToIdEnv@).
460 @do_CoreBindings@ takes into account the semantics of a list of
461 @CoreBindings@---things defined early in the list are visible later in
462 the list, but not vice versa.
465 type ValEnv = IdEnv CoreExpr
467 do_CoreBindings :: ValEnv
470 -> UniqSM [CoreBinding]
472 do_CoreBinding :: ValEnv
475 -> UniqSM (CoreBinding, ValEnv)
477 do_CoreBindings venv tenv [] = returnUs []
478 do_CoreBindings venv tenv (b:bs)
479 = do_CoreBinding venv tenv b `thenUs` \ (new_b, new_venv) ->
480 do_CoreBindings new_venv tenv bs `thenUs` \ new_bs ->
481 returnUs (new_b : new_bs)
483 do_CoreBinding venv tenv (NonRec binder rhs)
484 = do_CoreExpr venv tenv rhs `thenUs` \ new_rhs ->
486 dup_binder tenv binder `thenUs` \ (new_binder, (old, new)) ->
487 -- now plug new bindings into envs
488 let new_venv = addOneToIdEnv venv old new in
490 returnUs (NonRec new_binder new_rhs, new_venv)
492 do_CoreBinding venv tenv (Rec binds)
493 = -- for letrec, we plug in new bindings BEFORE cloning rhss
494 mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (new_binders, new_maps) ->
495 let new_venv = growIdEnvList venv new_maps in
497 mapUs (do_CoreExpr new_venv tenv) rhss `thenUs` \ new_rhss ->
498 returnUs (Rec (zipEqual "do_CoreBinding" new_binders new_rhss), new_venv)
500 (binders, rhss) = unzip binds
507 -> UniqSM CoreArgOrExpr
509 do_CoreArg venv tenv a@(VarArg v)
511 case (lookupIdEnv venv v) of
513 Just expr -> AnExpr expr
516 do_CoreArg venv tenv (TyArg ty)
517 = returnUs (AnArg (TyArg (applyTypeEnvToTy tenv ty)))
519 do_CoreArg venv tenv other_arg = returnUs (AnArg other_arg)
523 do_CoreExpr :: ValEnv
528 do_CoreExpr venv tenv orig_expr@(Var var)
530 case (lookupIdEnv venv var) of
531 Nothing -> --false:ASSERT(toplevelishId var) (SIGH)
536 do_CoreExpr venv tenv e@(Lit _) = returnUs e
538 do_CoreExpr venv tenv (Con con as)
539 = mapUs (do_CoreArg venv tenv) as `thenUs` \ new_as ->
542 do_CoreExpr venv tenv (Prim op as)
543 = mapUs (do_CoreArg venv tenv) as `thenUs` \ new_as ->
544 do_PrimOp op `thenUs` \ new_op ->
545 mkCoPrim new_op new_as
547 do_PrimOp (CCallOp label is_asm may_gc arg_tys result_ty)
549 new_arg_tys = map (applyTypeEnvToTy tenv) arg_tys
550 new_result_ty = applyTypeEnvToTy tenv result_ty
552 returnUs (CCallOp label is_asm may_gc new_arg_tys new_result_ty)
554 do_PrimOp other_op = returnUs other_op
556 do_CoreExpr venv tenv (Lam (ValBinder binder) expr)
557 = dup_binder tenv binder `thenUs` \(new_binder, (old,new)) ->
558 let new_venv = addOneToIdEnv venv old new in
559 do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
560 returnUs (Lam (ValBinder new_binder) new_expr)
562 do_CoreExpr venv tenv (Lam (TyBinder tyvar) expr)
563 = dup_tyvar tyvar `thenUs` \ (new_tyvar, (old, new)) ->
565 new_tenv = addOneToTyVarEnv tenv old new
567 do_CoreExpr venv new_tenv expr `thenUs` \ new_expr ->
568 returnUs (Lam (TyBinder new_tyvar) new_expr)
570 do_CoreExpr venv tenv (Lam _ expr) = panic "CoreUtils.do_CoreExpr:Lam UsageBinder"
572 do_CoreExpr venv tenv (App expr arg)
573 = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
574 do_CoreArg venv tenv arg `thenUs` \ new_arg ->
575 mkCoApps new_expr [new_arg] -- ToDo: more efficiently?
577 do_CoreExpr venv tenv (Case expr alts)
578 = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
579 do_alts venv tenv alts `thenUs` \ new_alts ->
580 returnUs (Case new_expr new_alts)
582 do_alts venv tenv (AlgAlts alts deflt)
583 = mapUs (do_boxed_alt venv tenv) alts `thenUs` \ new_alts ->
584 do_default venv tenv deflt `thenUs` \ new_deflt ->
585 returnUs (AlgAlts new_alts new_deflt)
587 do_boxed_alt venv tenv (con, binders, expr)
588 = mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (new_binders, new_vmaps) ->
589 let new_venv = growIdEnvList venv new_vmaps in
590 do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
591 returnUs (con, new_binders, new_expr)
594 do_alts venv tenv (PrimAlts alts deflt)
595 = mapUs (do_unboxed_alt venv tenv) alts `thenUs` \ new_alts ->
596 do_default venv tenv deflt `thenUs` \ new_deflt ->
597 returnUs (PrimAlts new_alts new_deflt)
599 do_unboxed_alt venv tenv (lit, expr)
600 = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
601 returnUs (lit, new_expr)
603 do_default venv tenv NoDefault = returnUs NoDefault
605 do_default venv tenv (BindDefault binder expr)
606 = dup_binder tenv binder `thenUs` \ (new_binder, (old, new)) ->
607 let new_venv = addOneToIdEnv venv old new in
608 do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
609 returnUs (BindDefault new_binder new_expr)
611 do_CoreExpr venv tenv (Let core_bind expr)
612 = do_CoreBinding venv tenv core_bind `thenUs` \ (new_bind, new_venv) ->
613 -- and do the body of the let
614 do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
615 returnUs (Let new_bind new_expr)
617 do_CoreExpr venv tenv (SCC label expr)
618 = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
619 returnUs (SCC label new_expr)
621 do_CoreExpr venv tenv (Coerce c ty expr)
622 = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
623 returnUs (Coerce c (applyTypeEnvToTy tenv ty) new_expr)
627 dup_tyvar :: TyVar -> UniqSM (TyVar, (TyVar, Type))
629 = getUnique `thenUs` \ uniq ->
630 let new_tyvar = cloneTyVar tyvar uniq in
631 returnUs (new_tyvar, (tyvar, mkTyVarTy new_tyvar))
633 -- same thing all over again --------------------
635 dup_binder :: TypeEnv -> Id -> UniqSM (Id, (Id, CoreExpr))
637 = if (toplevelishId b) then
638 -- binder is "top-level-ish"; -- it should *NOT* be renamed
639 -- ToDo: it's unsavoury that we return something to heave in env
640 returnUs (b, (b, Var b))
642 else -- otherwise, the full business
643 getUnique `thenUs` \ uniq ->
645 new_b1 = mkIdWithNewUniq b uniq
646 new_b2 = applyTypeEnvToId tenv new_b1
648 returnUs (new_b2, (b, Var new_b2))