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
24 IMPORT_DELOOPER(IdLoop) -- for pananoia-checking purposes
28 import CostCentre ( isDictCC, CostCentre, noCostCentre )
29 import Id ( idType, mkSysLocal, isBottomingId,
30 toplevelishId, mkIdWithNewUniq, applyTypeEnvToId,
32 addOneToIdEnv, growIdEnvList, lookupIdEnv,
33 isNullIdEnv, SYN_IE(IdEnv),
36 import Literal ( literalType, isNoRepLit, Literal(..) )
37 import Maybes ( catMaybes, maybeToBool )
39 import PprStyle ( PprStyle(..) )
40 import PprType ( GenType{-instances-} )
41 import Pretty ( ppAboves, ppStr )
42 import PrelVals ( augmentId, buildId )
43 import PrimOp ( primOpType, PrimOp(..) )
44 import SrcLoc ( noSrcLoc )
45 import TyVar ( cloneTyVar,
46 isNullTyVarEnv, addOneToTyVarEnv, SYN_IE(TyVarEnv)
48 import Type ( mkFunTy, mkForAllTy, mkForAllUsageTy, mkTyVarTy,
49 getFunTyExpandingDicts_maybe, applyTy, isPrimType,
50 splitSigmaTy, splitFunTy, eqTy, applyTypeEnvToTy
52 import TysWiredIn ( trueDataCon, falseDataCon )
53 import UniqSupply ( initUs, returnUs, thenUs,
54 mapUs, mapAndUnzipUs, getUnique,
55 SYN_IE(UniqSM), UniqSupply
57 import Usage ( SYN_IE(UVar) )
58 import Util ( zipEqual, panic, pprPanic, assertPanic )
60 type TypeEnv = TyVarEnv Type
61 applyUsage = panic "CoreUtils.applyUsage:ToDo"
64 %************************************************************************
66 \subsection{Find the type of a Core atom/expression}
68 %************************************************************************
71 coreExprType :: CoreExpr -> Type
73 coreExprType (Var var) = idType var
74 coreExprType (Lit lit) = literalType lit
76 coreExprType (Let _ body) = coreExprType body
77 coreExprType (SCC _ expr) = coreExprType expr
78 coreExprType (Case _ alts) = coreAltsType alts
80 coreExprType (Coerce _ ty _) = ty -- that's the whole point!
82 -- a Con is a fully-saturated application of a data constructor
83 -- a Prim is <ditto> of a PrimOp
85 coreExprType (Con con args) = applyTypeToArgs (dataConRepType con) args
86 coreExprType (Prim op args) = applyTypeToArgs (primOpType op) args
88 coreExprType (Lam (ValBinder binder) expr)
89 = idType binder `mkFunTy` coreExprType expr
91 coreExprType (Lam (TyBinder tyvar) expr)
92 = mkForAllTy tyvar (coreExprType expr)
94 coreExprType (Lam (UsageBinder uvar) expr)
95 = mkForAllUsageTy uvar (panic "coreExprType:Lam UsageBinder") (coreExprType expr)
97 coreExprType (App expr (TyArg ty))
98 = applyTy (coreExprType expr) ty
100 coreExprType (App expr (UsageArg use))
101 = applyUsage (coreExprType expr) use
103 coreExprType (App expr val_arg)
104 = ASSERT(isValArg val_arg)
106 fun_ty = coreExprType expr
108 case (getFunTyExpandingDicts_maybe False{-no peeking-} fun_ty) of
109 Just (_, result_ty) -> result_ty
111 Nothing -> pprPanic "coreExprType:\n"
112 (ppAboves [ppr PprDebug fun_ty,
113 ppr PprShowAll (App expr val_arg)])
118 coreAltsType :: CoreCaseAlts -> Type
120 coreAltsType (AlgAlts [] deflt) = default_ty deflt
121 coreAltsType (AlgAlts ((_,_,rhs1):_) _) = coreExprType rhs1
123 coreAltsType (PrimAlts [] deflt) = default_ty deflt
124 coreAltsType (PrimAlts ((_,rhs1):_) _) = coreExprType rhs1
126 default_ty NoDefault = panic "coreExprType:Case:default_ty"
127 default_ty (BindDefault _ rhs) = coreExprType rhs
131 applyTypeToArgs op_ty args = foldl applyTypeToArg op_ty args
133 applyTypeToArg op_ty (TyArg ty) = applyTy op_ty ty
134 applyTypeToArg op_ty (UsageArg _) = panic "applyTypeToArg: UsageArg"
135 applyTypeToArg op_ty val_or_lit_arg = case (getFunTyExpandingDicts_maybe False{-no peeking-} op_ty) of
136 Just (_, res_ty) -> res_ty
139 coreExprCc gets the cost centre enclosing an expression, if any.
140 It looks inside lambdas because (scc "foo" \x.e) = \x.scc "foo" e
143 coreExprCc :: GenCoreExpr val_bdr val_occ tyvar uvar -> CostCentre
144 coreExprCc (SCC cc e) = cc
145 coreExprCc (Lam _ e) = coreExprCc e
146 coreExprCc other = noCostCentre
149 %************************************************************************
151 \subsection{Routines to manufacture bits of @CoreExpr@}
153 %************************************************************************
156 mkCoreIfThenElse (Var bool) then_expr else_expr
157 | bool == trueDataCon = then_expr
158 | bool == falseDataCon = else_expr
160 mkCoreIfThenElse guard then_expr else_expr
162 (AlgAlts [ (trueDataCon, [], then_expr),
163 (falseDataCon, [], else_expr) ]
167 For making @Apps@ and @Lets@, we must take appropriate evasive
168 action if the thing being bound has unboxed type. @mkCoApp@ requires
169 a name supply to do its work.
171 @mkCoApps@, @mkCoCon@ and @mkCoPrim@ also handle the
172 arguments-must-be-atoms constraint.
179 mkCoApps :: CoreExpr -> [CoreArgOrExpr] -> UniqSM CoreExpr
180 mkCoCon :: Id -> [CoreArgOrExpr] -> UniqSM CoreExpr
181 mkCoPrim :: PrimOp -> [CoreArgOrExpr] -> UniqSM CoreExpr
183 mkCoApps fun args = co_thing (mkGenApp fun) args
184 mkCoCon con args = co_thing (Con con) args
185 mkCoPrim op args = co_thing (Prim op) args
187 co_thing :: ([CoreArg] -> CoreExpr)
191 co_thing thing arg_exprs
192 = mapAndUnzipUs expr_to_arg arg_exprs `thenUs` \ (args, maybe_binds) ->
193 returnUs (mkCoLetsUnboxedToCase (catMaybes maybe_binds) (thing args))
195 expr_to_arg :: CoreArgOrExpr
196 -> UniqSM (CoreArg, Maybe CoreBinding)
198 expr_to_arg (AnArg arg) = returnUs (arg, Nothing)
199 expr_to_arg (AnExpr (Var v)) = returnUs (VarArg v, Nothing)
200 expr_to_arg (AnExpr (Lit l)) = returnUs (LitArg l, Nothing)
201 expr_to_arg (AnExpr other_expr)
203 e_ty = coreExprType other_expr
205 getUnique `thenUs` \ uniq ->
207 new_var = mkSysLocal SLIT("a") uniq e_ty noSrcLoc
209 returnUs (VarArg new_var, Just (NonRec new_var other_expr))
214 GenCoreArg val_occ tyvar uvar -> GenCoreExpr val_bdr val_occ tyvar uvar
216 argToExpr (VarArg v) = Var v
217 argToExpr (LitArg lit) = Lit lit
220 All the following functions operate on binders, perform a uniform
221 transformation on them; ie. the function @(\ x -> (x,False))@
222 annotates all binders with False.
225 unTagBinders :: GenCoreExpr (Id,tag) bdee tv uv -> GenCoreExpr Id bdee tv uv
226 unTagBinders expr = bop_expr fst expr
228 unTagBindersAlts :: GenCoreCaseAlts (Id,tag) bdee tv uv -> GenCoreCaseAlts Id bdee tv uv
229 unTagBindersAlts alts = bop_alts fst alts
233 bop_expr :: (a -> b) -> GenCoreExpr a bdee tv uv -> GenCoreExpr b bdee tv uv
235 bop_expr f (Var b) = Var b
236 bop_expr f (Lit lit) = Lit lit
237 bop_expr f (Con con args) = Con con args
238 bop_expr f (Prim op args) = Prim op args
239 bop_expr f (Lam binder expr) = Lam (bop_binder f binder) (bop_expr f expr)
240 bop_expr f (App expr arg) = App (bop_expr f expr) arg
241 bop_expr f (SCC label expr) = SCC label (bop_expr f expr)
242 bop_expr f (Coerce c ty e) = Coerce c ty (bop_expr f e)
243 bop_expr f (Let bind expr) = Let (bop_bind f bind) (bop_expr f expr)
244 bop_expr f (Case expr alts) = Case (bop_expr f expr) (bop_alts f alts)
246 bop_binder f (ValBinder v) = ValBinder (f v)
247 bop_binder f (TyBinder t) = TyBinder t
248 bop_binder f (UsageBinder u) = UsageBinder u
250 bop_bind f (NonRec b e) = NonRec (f b) (bop_expr f e)
251 bop_bind f (Rec pairs) = Rec [(f b, bop_expr f e) | (b, e) <- pairs]
253 bop_alts f (AlgAlts alts deflt)
254 = AlgAlts [ (con, [f b | b <- binders], bop_expr f e)
255 | (con, binders, e) <- alts ]
258 bop_alts f (PrimAlts alts deflt)
259 = PrimAlts [ (lit, bop_expr f e) | (lit, e) <- alts ]
262 bop_deflt f (NoDefault) = NoDefault
263 bop_deflt f (BindDefault b expr) = BindDefault (f b) (bop_expr f expr)
266 OLD (but left here because of the nice example): @singleAlt@ checks
267 whether a bunch of case alternatives is actually just one alternative.
268 It specifically {\em ignores} alternatives which consist of just a
269 call to @error@, because they won't result in any code duplication.
273 case (case <something> of
275 False -> error "Foo") of
281 True -> case <rhs> of
283 False -> case error "Foo" of
289 True -> case <rhs> of
293 Notice that the \tr{<alts>} don't get duplicated.
296 nonErrorRHSs :: GenCoreCaseAlts a Id TyVar UVar -> [GenCoreExpr a Id TyVar UVar]
299 = filter not_error_app (find_rhss alts)
301 find_rhss (AlgAlts as deflt) = [rhs | (_,_,rhs) <- as] ++ deflt_rhs deflt
302 find_rhss (PrimAlts as deflt) = [rhs | (_,rhs) <- as] ++ deflt_rhs deflt
304 deflt_rhs NoDefault = []
305 deflt_rhs (BindDefault _ rhs) = [rhs]
308 = case (maybeErrorApp rhs Nothing) of
313 maybeErrorApp checks whether an expression is of the form
319 Just (error ty' args)
321 where ty' is supplied as an argument to maybeErrorApp.
323 Here's where it is useful:
325 case (error ty "Foo" e1 e2) of <alts>
329 where ty' is the type of any of the alternatives. You might think
330 this never occurs, but see the comments on the definition of
333 Note: we *avoid* the case where ty' might end up as a primitive type:
334 this is very uncool (totally wrong).
336 NOTICE: in the example above we threw away e1 and e2, but not the
337 string "Foo". How did we know to do that?
339 Answer: for now anyway, we only handle the case of a function whose
342 bottomingFn :: forall a. t1 -> ... -> tn -> a
343 ^---------------------^ NB!
345 Furthermore, we only count a bottomingApp if the function is applied
346 to more than n args. If so, we transform:
348 bottomingFn ty e1 ... en en+1 ... em
350 bottomingFn ty' e1 ... en
352 That is, we discard en+1 .. em
356 :: GenCoreExpr a Id TyVar UVar -- Expr to look at
357 -> Maybe Type -- Just ty => a result type *already cloned*;
358 -- Nothing => don't know result ty; we
359 -- *pretend* that the result ty won't be
360 -- primitive -- somebody later must
362 -> Maybe (GenCoreExpr a Id TyVar UVar)
364 maybeErrorApp expr result_ty_maybe
365 = case (collectArgs expr) of
366 (Var fun, [{-no usage???-}], [ty], other_args)
368 && maybeToBool result_ty_maybe -- we *know* the result type
369 -- (otherwise: live a fairy-tale existence...)
370 && not (isPrimType result_ty) ->
372 case (splitSigmaTy (idType fun)) of
373 ([tyvar], [], tau_ty) ->
374 case (splitFunTy tau_ty) of { (arg_tys, res_ty) ->
376 n_args_to_keep = length arg_tys
377 args_to_keep = take n_args_to_keep other_args
379 if (res_ty `eqTy` mkTyVarTy tyvar)
380 && n_args_to_keep <= length other_args
382 -- Phew! We're in business
383 Just (mkGenApp (Var fun) (TyArg result_ty : args_to_keep))
388 other -> Nothing -- Function type wrong shape
391 Just result_ty = result_ty_maybe
395 squashableDictishCcExpr :: CostCentre -> GenCoreExpr a b c d -> Bool
397 squashableDictishCcExpr cc expr
398 = if not (isDictCC cc) then
399 False -- that was easy...
401 squashable expr -- note: quite like the "atomic_rhs" stuff in simplifier
403 squashable (Var _) = True
404 squashable (Con _ _) = True -- I think so... WDP 94/09
405 squashable (Prim _ _) = True -- ditto
407 | notValArg a = squashable f
408 squashable other = False
411 %************************************************************************
413 \subsection{Core-renaming utils}
415 %************************************************************************
418 substCoreBindings :: ValEnv
419 -> TypeEnv -- TyVar=>Type
421 -> UniqSM [CoreBinding]
423 substCoreExpr :: ValEnv
424 -> TypeEnv -- TyVar=>Type
428 substCoreBindings venv tenv binds
429 -- if the envs are empty, then avoid doing anything
430 = if (isNullIdEnv venv && isNullTyVarEnv tenv) then
433 do_CoreBindings venv tenv binds
435 substCoreExpr venv tenv expr
436 = if (isNullIdEnv venv && isNullTyVarEnv tenv) then
439 do_CoreExpr venv tenv expr
442 The equiv code for @Types@ is in @TyUtils@.
444 Because binders aren't necessarily unique: we don't do @plusEnvs@
445 (which check for duplicates); rather, we use the shadowing version,
446 @growIdEnv@ (and shorthand @addOneToIdEnv@).
448 @do_CoreBindings@ takes into account the semantics of a list of
449 @CoreBindings@---things defined early in the list are visible later in
450 the list, but not vice versa.
453 type ValEnv = IdEnv CoreExpr
455 do_CoreBindings :: ValEnv
458 -> UniqSM [CoreBinding]
460 do_CoreBinding :: ValEnv
463 -> UniqSM (CoreBinding, ValEnv)
465 do_CoreBindings venv tenv [] = returnUs []
466 do_CoreBindings venv tenv (b:bs)
467 = do_CoreBinding venv tenv b `thenUs` \ (new_b, new_venv) ->
468 do_CoreBindings new_venv tenv bs `thenUs` \ new_bs ->
469 returnUs (new_b : new_bs)
471 do_CoreBinding venv tenv (NonRec binder rhs)
472 = do_CoreExpr venv tenv rhs `thenUs` \ new_rhs ->
474 dup_binder tenv binder `thenUs` \ (new_binder, (old, new)) ->
475 -- now plug new bindings into envs
476 let new_venv = addOneToIdEnv venv old new in
478 returnUs (NonRec new_binder new_rhs, new_venv)
480 do_CoreBinding venv tenv (Rec binds)
481 = -- for letrec, we plug in new bindings BEFORE cloning rhss
482 mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (new_binders, new_maps) ->
483 let new_venv = growIdEnvList venv new_maps in
485 mapUs (do_CoreExpr new_venv tenv) rhss `thenUs` \ new_rhss ->
486 returnUs (Rec (zipEqual "do_CoreBinding" new_binders new_rhss), new_venv)
488 (binders, rhss) = unzip binds
495 -> UniqSM CoreArgOrExpr
497 do_CoreArg venv tenv a@(VarArg v)
499 case (lookupIdEnv venv v) of
501 Just expr -> AnExpr expr
504 do_CoreArg venv tenv (TyArg ty)
505 = returnUs (AnArg (TyArg (applyTypeEnvToTy tenv ty)))
507 do_CoreArg venv tenv other_arg = returnUs (AnArg other_arg)
511 do_CoreExpr :: ValEnv
516 do_CoreExpr venv tenv orig_expr@(Var var)
518 case (lookupIdEnv venv var) of
519 Nothing -> --false:ASSERT(toplevelishId var) (SIGH)
524 do_CoreExpr venv tenv e@(Lit _) = returnUs e
526 do_CoreExpr venv tenv (Con con as)
527 = mapUs (do_CoreArg venv tenv) as `thenUs` \ new_as ->
530 do_CoreExpr venv tenv (Prim op as)
531 = mapUs (do_CoreArg venv tenv) as `thenUs` \ new_as ->
532 do_PrimOp op `thenUs` \ new_op ->
533 mkCoPrim new_op new_as
535 do_PrimOp (CCallOp label is_asm may_gc arg_tys result_ty)
537 new_arg_tys = map (applyTypeEnvToTy tenv) arg_tys
538 new_result_ty = applyTypeEnvToTy tenv result_ty
540 returnUs (CCallOp label is_asm may_gc new_arg_tys new_result_ty)
542 do_PrimOp other_op = returnUs other_op
544 do_CoreExpr venv tenv (Lam (ValBinder binder) expr)
545 = dup_binder tenv binder `thenUs` \(new_binder, (old,new)) ->
546 let new_venv = addOneToIdEnv venv old new in
547 do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
548 returnUs (Lam (ValBinder new_binder) new_expr)
550 do_CoreExpr venv tenv (Lam (TyBinder tyvar) expr)
551 = dup_tyvar tyvar `thenUs` \ (new_tyvar, (old, new)) ->
553 new_tenv = addOneToTyVarEnv tenv old new
555 do_CoreExpr venv new_tenv expr `thenUs` \ new_expr ->
556 returnUs (Lam (TyBinder new_tyvar) new_expr)
558 do_CoreExpr venv tenv (Lam _ expr) = panic "CoreUtils.do_CoreExpr:Lam UsageBinder"
560 do_CoreExpr venv tenv (App expr arg)
561 = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
562 do_CoreArg venv tenv arg `thenUs` \ new_arg ->
563 mkCoApps new_expr [new_arg] -- ToDo: more efficiently?
565 do_CoreExpr venv tenv (Case expr alts)
566 = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
567 do_alts venv tenv alts `thenUs` \ new_alts ->
568 returnUs (Case new_expr new_alts)
570 do_alts venv tenv (AlgAlts alts deflt)
571 = mapUs (do_boxed_alt venv tenv) alts `thenUs` \ new_alts ->
572 do_default venv tenv deflt `thenUs` \ new_deflt ->
573 returnUs (AlgAlts new_alts new_deflt)
575 do_boxed_alt venv tenv (con, binders, expr)
576 = mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (new_binders, new_vmaps) ->
577 let new_venv = growIdEnvList venv new_vmaps in
578 do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
579 returnUs (con, new_binders, new_expr)
582 do_alts venv tenv (PrimAlts alts deflt)
583 = mapUs (do_unboxed_alt venv tenv) alts `thenUs` \ new_alts ->
584 do_default venv tenv deflt `thenUs` \ new_deflt ->
585 returnUs (PrimAlts new_alts new_deflt)
587 do_unboxed_alt venv tenv (lit, expr)
588 = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
589 returnUs (lit, new_expr)
591 do_default venv tenv NoDefault = returnUs NoDefault
593 do_default venv tenv (BindDefault binder expr)
594 = dup_binder tenv binder `thenUs` \ (new_binder, (old, new)) ->
595 let new_venv = addOneToIdEnv venv old new in
596 do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
597 returnUs (BindDefault new_binder new_expr)
599 do_CoreExpr venv tenv (Let core_bind expr)
600 = do_CoreBinding venv tenv core_bind `thenUs` \ (new_bind, new_venv) ->
601 -- and do the body of the let
602 do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
603 returnUs (Let new_bind new_expr)
605 do_CoreExpr venv tenv (SCC label expr)
606 = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
607 returnUs (SCC label new_expr)
609 do_CoreExpr venv tenv (Coerce c ty expr)
610 = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
611 returnUs (Coerce c (applyTypeEnvToTy tenv ty) new_expr)
615 dup_tyvar :: TyVar -> UniqSM (TyVar, (TyVar, Type))
617 = getUnique `thenUs` \ uniq ->
618 let new_tyvar = cloneTyVar tyvar uniq in
619 returnUs (new_tyvar, (tyvar, mkTyVarTy new_tyvar))
621 -- same thing all over again --------------------
623 dup_binder :: TypeEnv -> Id -> UniqSM (Id, (Id, CoreExpr))
625 = if (toplevelishId b) then
626 -- binder is "top-level-ish"; -- it should *NOT* be renamed
627 -- ToDo: it's unsavoury that we return something to heave in env
628 returnUs (b, (b, Var b))
630 else -- otherwise, the full business
631 getUnique `thenUs` \ uniq ->
633 new_b1 = mkIdWithNewUniq b uniq
634 new_b2 = applyTypeEnvToId tenv new_b1
636 returnUs (new_b2, (b, Var new_b2))