2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[CoreUtils]{Utility functions on @Core@ syntax}
8 coreExprType, coreAltsType, coreExprCc,
12 unTagBinders, unTagBindersAlts,
16 squashableDictishCcExpr
19 #include "HsVersions.h"
23 import CostCentre ( isDictCC, CostCentre, noCostCentre )
24 import MkId ( mkSysLocal )
25 import Id ( idType, isBottomingId,
28 addOneToIdEnv, growIdEnvList, lookupIdEnv,
29 isNullIdEnv, IdEnv, Id
31 import Literal ( literalType, Literal(..) )
32 import Maybes ( catMaybes, maybeToBool )
34 import PrimOp ( primOpType, PrimOp(..) )
35 import SrcLoc ( noSrcLoc )
36 import TyVar ( cloneTyVar,
37 isEmptyTyVarEnv, addToTyVarEnv, TyVarEnv,
40 import Type ( mkFunTy, mkForAllTy, mkTyVarTy,
41 splitFunTy_maybe, applyTys, isUnpointedType,
42 splitSigmaTy, splitFunTys, instantiateTy,
45 import TysWiredIn ( trueDataCon, falseDataCon )
46 import Unique ( Unique )
47 import BasicTypes ( Unused )
48 import UniqSupply ( returnUs, thenUs,
49 mapUs, mapAndUnzipUs, getUnique,
52 import Util ( zipEqual )
55 type TypeEnv = TyVarEnv Type
58 %************************************************************************
60 \subsection{Find the type of a Core atom/expression}
62 %************************************************************************
65 coreExprType :: CoreExpr -> Type
67 coreExprType (Var var) = idType var
68 coreExprType (Lit lit) = literalType lit
70 coreExprType (Let _ body) = coreExprType body
71 coreExprType (Case _ alts) = coreAltsType alts
73 coreExprType (Note (Coerce ty _) e) = ty
74 coreExprType (Note other_note e) = coreExprType e
76 -- a Con is a fully-saturated application of a data constructor
77 -- a Prim is <ditto> of a PrimOp
79 coreExprType (Con con args) =
80 -- pprTrace "appTyArgs" (hsep [ppr con, semi,
83 applyTypeToArgs con_ty args
85 con_ty = dataConRepType con
87 coreExprType (Prim op args) = applyTypeToArgs (primOpType op) args
89 coreExprType (Lam (ValBinder binder) expr)
90 = idType binder `mkFunTy` coreExprType expr
92 coreExprType (Lam (TyBinder tyvar) expr)
93 = mkForAllTy tyvar (coreExprType expr)
95 coreExprType (App expr (TyArg ty))
96 = -- Gather type args; more efficient to instantiate the type all at once
99 go (App expr (TyArg ty)) tys = go expr (ty:tys)
100 go expr tys = applyTys (coreExprType expr) tys
102 coreExprType (App expr val_arg)
103 = ASSERT(isValArg val_arg)
105 fun_ty = coreExprType expr
107 case (splitFunTy_maybe fun_ty) of
108 Just (_, result_ty) -> result_ty
110 Nothing -> pprPanic "coreExprType:\n"
111 (vcat [ppr fun_ty, ppr (App expr val_arg)])
116 coreAltsType :: CoreCaseAlts -> Type
118 coreAltsType (AlgAlts [] deflt) = default_ty deflt
119 coreAltsType (AlgAlts ((_,_,rhs1):_) _) = coreExprType rhs1
121 coreAltsType (PrimAlts [] deflt) = default_ty deflt
122 coreAltsType (PrimAlts ((_,rhs1):_) _) = coreExprType rhs1
124 default_ty NoDefault = panic "coreExprType:Case:default_ty"
125 default_ty (BindDefault _ rhs) = coreExprType rhs
129 applyTypeToArgs op_ty (TyArg ty : args)
130 = -- Accumulate type arguments so we can instantiate all at once
131 applyTypeToArgs (applyTys op_ty tys) rest_args
133 (tys, rest_args) = go [ty] args
134 go tys (TyArg ty : args) = go (ty:tys) args
135 go tys rest_args = (reverse tys, rest_args)
137 applyTypeToArgs op_ty (val_or_lit_arg:args)
138 = case (splitFunTy_maybe op_ty) of
139 Just (_, res_ty) -> applyTypeToArgs res_ty args
141 applyTypeToArgs op_ty [] = op_ty
144 coreExprCc gets the cost centre enclosing an expression, if any.
145 It looks inside lambdas because (scc "foo" \x.e) = \x.scc "foo" e
148 coreExprCc :: GenCoreExpr val_bdr val_occ flexi -> CostCentre
149 coreExprCc (Note (SCC cc) e) = cc
150 coreExprCc (Note other_note e) = coreExprCc e
151 coreExprCc (Lam _ e) = coreExprCc e
152 coreExprCc other = noCostCentre
155 %************************************************************************
157 \subsection{Routines to manufacture bits of @CoreExpr@}
159 %************************************************************************
162 mkCoreIfThenElse (Var bool) then_expr else_expr
163 | bool == trueDataCon = then_expr
164 | bool == falseDataCon = else_expr
166 mkCoreIfThenElse guard then_expr else_expr
168 (AlgAlts [ (trueDataCon, [], then_expr),
169 (falseDataCon, [], else_expr) ]
173 For making @Apps@ and @Lets@, we must take appropriate evasive
174 action if the thing being bound has unboxed type. @mkCoApp@ requires
175 a name supply to do its work.
177 @mkCoApps@, @mkCoCon@ and @mkCoPrim@ also handle the
178 arguments-must-be-atoms constraint.
185 mkCoApps :: CoreExpr -> [CoreArgOrExpr] -> UniqSM CoreExpr
186 mkCoCon :: Id -> [CoreArgOrExpr] -> UniqSM CoreExpr
187 mkCoPrim :: PrimOp -> [CoreArgOrExpr] -> UniqSM CoreExpr
189 mkCoApps fun args = co_thing (mkGenApp fun) args
190 mkCoCon con args = co_thing (Con con) args
191 mkCoPrim op args = co_thing (Prim op) args
193 co_thing :: ([CoreArg] -> CoreExpr)
197 co_thing thing arg_exprs
198 = mapAndUnzipUs expr_to_arg arg_exprs `thenUs` \ (args, maybe_binds) ->
199 returnUs (mkCoLetsUnboxedToCase (catMaybes maybe_binds) (thing args))
201 expr_to_arg :: CoreArgOrExpr
202 -> UniqSM (CoreArg, Maybe CoreBinding)
204 expr_to_arg (AnArg arg) = returnUs (arg, Nothing)
205 expr_to_arg (AnExpr (Var v)) = returnUs (VarArg v, Nothing)
206 expr_to_arg (AnExpr (Lit l)) = returnUs (LitArg l, Nothing)
207 expr_to_arg (AnExpr other_expr)
209 e_ty = coreExprType other_expr
211 getUnique `thenUs` \ uniq ->
213 new_var = mkSysLocal SLIT("a") uniq e_ty noSrcLoc
215 returnUs (VarArg new_var, Just (NonRec new_var other_expr))
220 GenCoreArg val_occ flexi -> GenCoreExpr val_bdr val_occ flexi
222 argToExpr (VarArg v) = Var v
223 argToExpr (LitArg lit) = Lit lit
226 All the following functions operate on binders, perform a uniform
227 transformation on them; ie. the function @(\ x -> (x,False))@
228 annotates all binders with False.
231 unTagBinders :: GenCoreExpr (Id,tag) bdee flexi -> GenCoreExpr Id bdee flexi
232 unTagBinders expr = bop_expr fst expr
234 unTagBindersAlts :: GenCoreCaseAlts (Id,tag) bdee flexi -> GenCoreCaseAlts Id bdee flexi
235 unTagBindersAlts alts = bop_alts fst alts
239 bop_expr :: (a -> b) -> GenCoreExpr a bdee flexi -> GenCoreExpr b bdee flexi
241 bop_expr f (Var b) = Var b
242 bop_expr f (Lit lit) = Lit lit
243 bop_expr f (Con con args) = Con con args
244 bop_expr f (Prim op args) = Prim op args
245 bop_expr f (Lam binder expr) = Lam (bop_binder f binder) (bop_expr f expr)
246 bop_expr f (App expr arg) = App (bop_expr f expr) arg
247 bop_expr f (Note note expr) = Note note (bop_expr f expr)
248 bop_expr f (Let bind expr) = Let (bop_bind f bind) (bop_expr f expr)
249 bop_expr f (Case expr alts) = Case (bop_expr f expr) (bop_alts f alts)
251 bop_binder f (ValBinder v) = ValBinder (f v)
252 bop_binder f (TyBinder t) = TyBinder t
254 bop_bind f (NonRec b e) = NonRec (f b) (bop_expr f e)
255 bop_bind f (Rec pairs) = Rec [(f b, bop_expr f e) | (b, e) <- pairs]
257 bop_alts f (AlgAlts alts deflt)
258 = AlgAlts [ (con, [f b | b <- binders], bop_expr f e)
259 | (con, binders, e) <- alts ]
262 bop_alts f (PrimAlts alts deflt)
263 = PrimAlts [ (lit, bop_expr f e) | (lit, e) <- alts ]
266 bop_deflt f (NoDefault) = NoDefault
267 bop_deflt f (BindDefault b expr) = BindDefault (f b) (bop_expr f expr)
270 OLD (but left here because of the nice example): @singleAlt@ checks
271 whether a bunch of case alternatives is actually just one alternative.
272 It specifically {\em ignores} alternatives which consist of just a
273 call to @error@, because they won't result in any code duplication.
277 case (case <something> of
279 False -> error "Foo") of
285 True -> case <rhs> of
287 False -> case error "Foo" of
293 True -> case <rhs> of
297 Notice that the \tr{<alts>} don't get duplicated.
300 nonErrorRHSs :: GenCoreCaseAlts a Id Unused -> [GenCoreExpr a Id Unused]
303 = filter not_error_app (find_rhss alts)
305 find_rhss (AlgAlts as deflt) = [rhs | (_,_,rhs) <- as] ++ deflt_rhs deflt
306 find_rhss (PrimAlts as deflt) = [rhs | (_,rhs) <- as] ++ deflt_rhs deflt
308 deflt_rhs NoDefault = []
309 deflt_rhs (BindDefault _ rhs) = [rhs]
312 = case (maybeErrorApp rhs Nothing) of
317 maybeErrorApp checks whether an expression is of the form
323 Just (error ty' args)
325 where ty' is supplied as an argument to maybeErrorApp.
327 Here's where it is useful:
329 case (error ty "Foo" e1 e2) of <alts>
333 where ty' is the type of any of the alternatives. You might think
334 this never occurs, but see the comments on the definition of
337 Note: we *avoid* the case where ty' might end up as a primitive type:
338 this is very uncool (totally wrong).
340 NOTICE: in the example above we threw away e1 and e2, but not the
341 string "Foo". How did we know to do that?
343 Answer: for now anyway, we only handle the case of a function whose
346 bottomingFn :: forall a. t1 -> ... -> tn -> a
347 ^---------------------^ NB!
349 Furthermore, we only count a bottomingApp if the function is applied
350 to more than n args. If so, we transform:
352 bottomingFn ty e1 ... en en+1 ... em
354 bottomingFn ty' e1 ... en
356 That is, we discard en+1 .. em
360 :: GenCoreExpr a Id Unused -- Expr to look at
361 -> Maybe Type -- Just ty => a result type *already cloned*;
362 -- Nothing => don't know result ty; we
363 -- *pretend* that the result ty won't be
364 -- primitive -- somebody later must
366 -> Maybe (GenCoreExpr b Id Unused)
368 maybeErrorApp expr result_ty_maybe
369 = case (collectArgs expr) of
370 (Var fun, [ty], other_args)
372 && maybeToBool result_ty_maybe -- we *know* the result type
373 -- (otherwise: live a fairy-tale existence...)
374 && not (isUnpointedType result_ty) ->
376 case (splitSigmaTy (idType fun)) of
377 ([tyvar], [], tau_ty) ->
378 case (splitFunTys tau_ty) of { (arg_tys, res_ty) ->
380 n_args_to_keep = length arg_tys
381 args_to_keep = take n_args_to_keep other_args
383 if (res_ty == mkTyVarTy tyvar)
384 && n_args_to_keep <= length other_args
386 -- Phew! We're in business
387 Just (mkGenApp (Var fun) (TyArg result_ty : args_to_keep))
392 other -> Nothing -- Function type wrong shape
395 Just result_ty = result_ty_maybe
399 squashableDictishCcExpr :: CostCentre -> GenCoreExpr a b c -> Bool
401 squashableDictishCcExpr cc expr
402 = if not (isDictCC cc) then
403 False -- that was easy...
405 squashable expr -- note: quite like the "atomic_rhs" stuff in simplifier
407 squashable (Var _) = True
408 squashable (Con _ _) = True -- I think so... WDP 94/09
409 squashable (Prim _ _) = True -- ditto
411 | notValArg a = squashable f
412 squashable other = False