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
28 IMPORT_DELOOPER(IdLoop) -- for pananoia-checking purposes
32 import CostCentre ( isDictCC, CostCentre, noCostCentre )
33 import Id ( idType, mkSysLocal, getIdArity, isBottomingId,
34 toplevelishId, mkIdWithNewUniq, applyTypeEnvToId,
36 addOneToIdEnv, growIdEnvList, lookupIdEnv,
37 isNullIdEnv, SYN_IE(IdEnv),
40 import IdInfo ( arityMaybe )
41 import Literal ( literalType, isNoRepLit, Literal(..) )
42 import Maybes ( catMaybes, maybeToBool )
44 import PprStyle ( PprStyle(..) )
45 import PprType ( GenType{-instances-} )
46 import Pretty ( ppAboves, ppStr )
47 import PrelVals ( augmentId, buildId )
48 import PrimOp ( primOpType, PrimOp(..) )
49 import SrcLoc ( mkUnknownSrcLoc )
50 import TyVar ( cloneTyVar,
51 isNullTyVarEnv, addOneToTyVarEnv, SYN_IE(TyVarEnv)
53 import Type ( mkFunTy, mkForAllTy, mkForAllUsageTy, mkTyVarTy,
54 getFunTyExpandingDicts_maybe, applyTy, isPrimType,
55 splitSigmaTy, splitFunTy, eqTy, applyTypeEnvToTy
57 import TysWiredIn ( trueDataCon, falseDataCon )
58 import UniqSupply ( initUs, returnUs, thenUs,
59 mapUs, mapAndUnzipUs, getUnique,
60 SYN_IE(UniqSM), UniqSupply
62 import Usage ( SYN_IE(UVar) )
63 import Util ( zipEqual, panic, pprPanic, assertPanic )
65 type TypeEnv = TyVarEnv Type
66 applyUsage = panic "CoreUtils.applyUsage:ToDo"
69 %************************************************************************
71 \subsection{Find the type of a Core atom/expression}
73 %************************************************************************
76 coreExprType :: CoreExpr -> Type
78 coreExprType (Var var) = idType var
79 coreExprType (Lit lit) = literalType lit
81 coreExprType (Let _ body) = coreExprType body
82 coreExprType (SCC _ expr) = coreExprType expr
83 coreExprType (Case _ alts) = coreAltsType alts
85 coreExprType (Coerce _ ty _) = ty -- that's the whole point!
87 -- a Con is a fully-saturated application of a data constructor
88 -- a Prim is <ditto> of a PrimOp
90 coreExprType (Con con args) = applyTypeToArgs (dataConRepType con) args
91 coreExprType (Prim op args) = applyTypeToArgs (primOpType op) args
93 coreExprType (Lam (ValBinder binder) expr)
94 = idType binder `mkFunTy` coreExprType expr
96 coreExprType (Lam (TyBinder tyvar) expr)
97 = mkForAllTy tyvar (coreExprType expr)
99 coreExprType (Lam (UsageBinder uvar) expr)
100 = mkForAllUsageTy uvar (panic "coreExprType:Lam UsageBinder") (coreExprType expr)
102 coreExprType (App expr (TyArg ty))
103 = applyTy (coreExprType expr) ty
105 coreExprType (App expr (UsageArg use))
106 = applyUsage (coreExprType expr) use
108 coreExprType (App expr val_arg)
109 = ASSERT(isValArg val_arg)
111 fun_ty = coreExprType expr
113 case (getFunTyExpandingDicts_maybe False{-no peeking-} fun_ty) of
114 Just (_, result_ty) -> result_ty
116 Nothing -> pprPanic "coreExprType:\n"
117 (ppAboves [ppr PprDebug fun_ty,
118 ppr PprShowAll (App expr val_arg)])
123 coreAltsType :: CoreCaseAlts -> Type
125 coreAltsType (AlgAlts [] deflt) = default_ty deflt
126 coreAltsType (AlgAlts ((_,_,rhs1):_) _) = coreExprType rhs1
128 coreAltsType (PrimAlts [] deflt) = default_ty deflt
129 coreAltsType (PrimAlts ((_,rhs1):_) _) = coreExprType rhs1
131 default_ty NoDefault = panic "coreExprType:Case:default_ty"
132 default_ty (BindDefault _ rhs) = coreExprType rhs
136 applyTypeToArgs op_ty args = foldl applyTypeToArg op_ty args
138 applyTypeToArg op_ty (TyArg ty) = applyTy op_ty ty
139 applyTypeToArg op_ty (UsageArg _) = panic "applyTypeToArg: UsageArg"
140 applyTypeToArg op_ty val_or_lit_arg = case (getFunTyExpandingDicts_maybe False{-no peeking-} op_ty) of
141 Just (_, res_ty) -> res_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 tyvar uvar -> CostCentre
149 coreExprCc (SCC cc e) = cc
150 coreExprCc (Lam _ e) = coreExprCc e
151 coreExprCc other = noCostCentre
154 %************************************************************************
156 \subsection{Routines to manufacture bits of @CoreExpr@}
158 %************************************************************************
161 mkCoreIfThenElse (Var bool) then_expr else_expr
162 | bool == trueDataCon = then_expr
163 | bool == falseDataCon = else_expr
165 mkCoreIfThenElse guard then_expr else_expr
167 (AlgAlts [ (trueDataCon, [], then_expr),
168 (falseDataCon, [], else_expr) ]
172 For making @Apps@ and @Lets@, we must take appropriate evasive
173 action if the thing being bound has unboxed type. @mkCoApp@ requires
174 a name supply to do its work.
176 @mkCoApps@, @mkCoCon@ and @mkCoPrim@ also handle the
177 arguments-must-be-atoms constraint.
184 mkCoApps :: CoreExpr -> [CoreArgOrExpr] -> UniqSM CoreExpr
185 mkCoCon :: Id -> [CoreArgOrExpr] -> UniqSM CoreExpr
186 mkCoPrim :: PrimOp -> [CoreArgOrExpr] -> UniqSM CoreExpr
188 mkCoApps fun args = co_thing (mkGenApp fun) args
189 mkCoCon con args = co_thing (Con con) args
190 mkCoPrim op args = co_thing (Prim op) args
192 co_thing :: ([CoreArg] -> CoreExpr)
196 co_thing thing arg_exprs
197 = mapAndUnzipUs expr_to_arg arg_exprs `thenUs` \ (args, maybe_binds) ->
198 returnUs (mkCoLetsUnboxedToCase (catMaybes maybe_binds) (thing args))
200 expr_to_arg :: CoreArgOrExpr
201 -> UniqSM (CoreArg, Maybe CoreBinding)
203 expr_to_arg (AnArg arg) = returnUs (arg, Nothing)
204 expr_to_arg (AnExpr (Var v)) = returnUs (VarArg v, Nothing)
205 expr_to_arg (AnExpr (Lit l)) = returnUs (LitArg l, Nothing)
206 expr_to_arg (AnExpr other_expr)
208 e_ty = coreExprType other_expr
210 getUnique `thenUs` \ uniq ->
212 new_var = mkSysLocal SLIT("a") uniq e_ty mkUnknownSrcLoc
214 returnUs (VarArg new_var, Just (NonRec new_var other_expr))
219 GenCoreArg val_occ tyvar uvar -> GenCoreExpr val_bdr val_occ tyvar uvar
221 argToExpr (VarArg v) = Var v
222 argToExpr (LitArg lit) = Lit lit
228 :: (Id -> Maybe (GenCoreExpr bndr Id))
229 -> GenCoreExpr bndr Id
231 coreExprArity f (Lam _ expr) = coreExprArity f expr + 1
232 coreExprArity f (CoTyLam _ expr) = coreExprArity f expr
233 coreExprArity f (App expr arg) = max (coreExprArity f expr - 1) 0
234 coreExprArity f (CoTyApp expr _) = coreExprArity f expr
235 coreExprArity f (Var v) = max further info
240 Just expr -> coreExprArity f expr
241 info = case (arityMaybe (getIdArity v)) of
244 coreExprArity f _ = 0
247 @isWrapperFor@: we want to see exactly:
249 /\ ... \ args -> case <arg> of ... -> case <arg> of ... -> wrkr <stuff>
252 Probably a little too HACKY [WDP].
255 isWrapperFor :: CoreExpr -> Id -> Bool
257 expr `isWrapperFor` var
258 = case (collectBinders expr) of { (_, _, args, body) -> -- lambdas off the front
259 unravel_casing args body
260 --NO, THANKS: && not (null args)
263 var's_worker = getWorkerId (getIdStrictness var)
265 is_elem = isIn "isWrapperFor"
268 unravel_casing case_ables (Case scrut alts)
269 = case (collectArgs scrut) of { (fun, _, _, vargs) ->
273 scrut_var /= var && all (doesn't_mention var) vargs
274 && scrut_var `is_elem` case_ables
275 && unravel_alts case_ables alts
282 unravel_casing case_ables other_expr
283 = case (collectArgs other_expr) of { (fun, _, _, vargs) ->
287 -- DOESN'T WORK: wrkr == var's_worker
290 && all (doesn't_mention var) vargs
291 && all (only_from case_ables) vargs
299 unravel_alts case_ables (AlgAlts [(_,params,rhs)] NoDefault)
300 = unravel_casing (params ++ case_ables) rhs
301 unravel_alts case_ables other = False
303 -------------------------
304 doesn't_mention var (ValArg (VarArg v)) = v /= var
305 doesn't_mention var other = True
307 -------------------------
308 only_from case_ables (ValArg (VarArg v)) = v `is_elem` case_ables
309 only_from case_ables other = True
313 All the following functions operate on binders, perform a uniform
314 transformation on them; ie. the function @(\ x -> (x,False))@
315 annotates all binders with False.
318 unTagBinders :: GenCoreExpr (Id,tag) bdee tv uv -> GenCoreExpr Id bdee tv uv
319 unTagBinders expr = bop_expr fst expr
321 unTagBindersAlts :: GenCoreCaseAlts (Id,tag) bdee tv uv -> GenCoreCaseAlts Id bdee tv uv
322 unTagBindersAlts alts = bop_alts fst alts
326 bop_expr :: (a -> b) -> GenCoreExpr a bdee tv uv -> GenCoreExpr b bdee tv uv
328 bop_expr f (Var b) = Var b
329 bop_expr f (Lit lit) = Lit lit
330 bop_expr f (Con con args) = Con con args
331 bop_expr f (Prim op args) = Prim op args
332 bop_expr f (Lam binder expr) = Lam (bop_binder f binder) (bop_expr f expr)
333 bop_expr f (App expr arg) = App (bop_expr f expr) arg
334 bop_expr f (SCC label expr) = SCC label (bop_expr f expr)
335 bop_expr f (Coerce c ty e) = Coerce c ty (bop_expr f e)
336 bop_expr f (Let bind expr) = Let (bop_bind f bind) (bop_expr f expr)
337 bop_expr f (Case expr alts) = Case (bop_expr f expr) (bop_alts f alts)
339 bop_binder f (ValBinder v) = ValBinder (f v)
340 bop_binder f (TyBinder t) = TyBinder t
341 bop_binder f (UsageBinder u) = UsageBinder u
343 bop_bind f (NonRec b e) = NonRec (f b) (bop_expr f e)
344 bop_bind f (Rec pairs) = Rec [(f b, bop_expr f e) | (b, e) <- pairs]
346 bop_alts f (AlgAlts alts deflt)
347 = AlgAlts [ (con, [f b | b <- binders], bop_expr f e)
348 | (con, binders, e) <- alts ]
351 bop_alts f (PrimAlts alts deflt)
352 = PrimAlts [ (lit, bop_expr f e) | (lit, e) <- alts ]
355 bop_deflt f (NoDefault) = NoDefault
356 bop_deflt f (BindDefault b expr) = BindDefault (f b) (bop_expr f expr)
359 OLD (but left here because of the nice example): @singleAlt@ checks
360 whether a bunch of case alternatives is actually just one alternative.
361 It specifically {\em ignores} alternatives which consist of just a
362 call to @error@, because they won't result in any code duplication.
366 case (case <something> of
368 False -> error "Foo") of
374 True -> case <rhs> of
376 False -> case error "Foo" of
382 True -> case <rhs> of
386 Notice that the \tr{<alts>} don't get duplicated.
389 nonErrorRHSs :: GenCoreCaseAlts a Id TyVar UVar -> [GenCoreExpr a Id TyVar UVar]
392 = filter not_error_app (find_rhss alts)
394 find_rhss (AlgAlts as deflt) = [rhs | (_,_,rhs) <- as] ++ deflt_rhs deflt
395 find_rhss (PrimAlts as deflt) = [rhs | (_,rhs) <- as] ++ deflt_rhs deflt
397 deflt_rhs NoDefault = []
398 deflt_rhs (BindDefault _ rhs) = [rhs]
401 = case (maybeErrorApp rhs Nothing) of
406 maybeErrorApp checks whether an expression is of the form
412 Just (error ty' args)
414 where ty' is supplied as an argument to maybeErrorApp.
416 Here's where it is useful:
418 case (error ty "Foo" e1 e2) of <alts>
422 where ty' is the type of any of the alternatives. You might think
423 this never occurs, but see the comments on the definition of
426 Note: we *avoid* the case where ty' might end up as a primitive type:
427 this is very uncool (totally wrong).
429 NOTICE: in the example above we threw away e1 and e2, but not the
430 string "Foo". How did we know to do that?
432 Answer: for now anyway, we only handle the case of a function whose
435 bottomingFn :: forall a. t1 -> ... -> tn -> a
436 ^---------------------^ NB!
438 Furthermore, we only count a bottomingApp if the function is applied
439 to more than n args. If so, we transform:
441 bottomingFn ty e1 ... en en+1 ... em
443 bottomingFn ty' e1 ... en
445 That is, we discard en+1 .. em
449 :: GenCoreExpr a Id TyVar UVar -- Expr to look at
450 -> Maybe Type -- Just ty => a result type *already cloned*;
451 -- Nothing => don't know result ty; we
452 -- *pretend* that the result ty won't be
453 -- primitive -- somebody later must
455 -> Maybe (GenCoreExpr a Id TyVar UVar)
457 maybeErrorApp expr result_ty_maybe
458 = case (collectArgs expr) of
459 (Var fun, [{-no usage???-}], [ty], other_args)
461 && maybeToBool result_ty_maybe -- we *know* the result type
462 -- (otherwise: live a fairy-tale existence...)
463 && not (isPrimType result_ty) ->
465 case (splitSigmaTy (idType fun)) of
466 ([tyvar], [], tau_ty) ->
467 case (splitFunTy tau_ty) of { (arg_tys, res_ty) ->
469 n_args_to_keep = length arg_tys
470 args_to_keep = take n_args_to_keep other_args
472 if (res_ty `eqTy` mkTyVarTy tyvar)
473 && n_args_to_keep <= length other_args
475 -- Phew! We're in business
476 Just (mkGenApp (Var fun) (TyArg result_ty : args_to_keep))
481 other -> Nothing -- Function type wrong shape
484 Just result_ty = result_ty_maybe
488 squashableDictishCcExpr :: CostCentre -> GenCoreExpr a b c d -> Bool
490 squashableDictishCcExpr cc expr
491 = if not (isDictCC cc) then
492 False -- that was easy...
494 squashable expr -- note: quite like the "atomic_rhs" stuff in simplifier
496 squashable (Var _) = True
497 squashable (Con _ _) = True -- I think so... WDP 94/09
498 squashable (Prim _ _) = True -- ditto
500 | notValArg a = squashable f
501 squashable other = False
504 %************************************************************************
506 \subsection{Core-renaming utils}
508 %************************************************************************
511 substCoreBindings :: ValEnv
512 -> TypeEnv -- TyVar=>Type
514 -> UniqSM [CoreBinding]
516 substCoreExpr :: ValEnv
517 -> TypeEnv -- TyVar=>Type
521 substCoreBindings venv tenv binds
522 -- if the envs are empty, then avoid doing anything
523 = if (isNullIdEnv venv && isNullTyVarEnv tenv) then
526 do_CoreBindings venv tenv binds
528 substCoreExpr venv tenv expr
529 = if (isNullIdEnv venv && isNullTyVarEnv tenv) then
532 do_CoreExpr venv tenv expr
535 The equiv code for @Types@ is in @TyUtils@.
537 Because binders aren't necessarily unique: we don't do @plusEnvs@
538 (which check for duplicates); rather, we use the shadowing version,
539 @growIdEnv@ (and shorthand @addOneToIdEnv@).
541 @do_CoreBindings@ takes into account the semantics of a list of
542 @CoreBindings@---things defined early in the list are visible later in
543 the list, but not vice versa.
546 type ValEnv = IdEnv CoreExpr
548 do_CoreBindings :: ValEnv
551 -> UniqSM [CoreBinding]
553 do_CoreBinding :: ValEnv
556 -> UniqSM (CoreBinding, ValEnv)
558 do_CoreBindings venv tenv [] = returnUs []
559 do_CoreBindings venv tenv (b:bs)
560 = do_CoreBinding venv tenv b `thenUs` \ (new_b, new_venv) ->
561 do_CoreBindings new_venv tenv bs `thenUs` \ new_bs ->
562 returnUs (new_b : new_bs)
564 do_CoreBinding venv tenv (NonRec binder rhs)
565 = do_CoreExpr venv tenv rhs `thenUs` \ new_rhs ->
567 dup_binder tenv binder `thenUs` \ (new_binder, (old, new)) ->
568 -- now plug new bindings into envs
569 let new_venv = addOneToIdEnv venv old new in
571 returnUs (NonRec new_binder new_rhs, new_venv)
573 do_CoreBinding venv tenv (Rec binds)
574 = -- for letrec, we plug in new bindings BEFORE cloning rhss
575 mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (new_binders, new_maps) ->
576 let new_venv = growIdEnvList venv new_maps in
578 mapUs (do_CoreExpr new_venv tenv) rhss `thenUs` \ new_rhss ->
579 returnUs (Rec (zipEqual "do_CoreBinding" new_binders new_rhss), new_venv)
581 (binders, rhss) = unzip binds
588 -> UniqSM CoreArgOrExpr
590 do_CoreArg venv tenv a@(VarArg v)
592 case (lookupIdEnv venv v) of
594 Just expr -> AnExpr expr
597 do_CoreArg venv tenv (TyArg ty)
598 = returnUs (AnArg (TyArg (applyTypeEnvToTy tenv ty)))
600 do_CoreArg venv tenv other_arg = returnUs (AnArg other_arg)
604 do_CoreExpr :: ValEnv
609 do_CoreExpr venv tenv orig_expr@(Var var)
611 case (lookupIdEnv venv var) of
612 Nothing -> --false:ASSERT(toplevelishId var) (SIGH)
617 do_CoreExpr venv tenv e@(Lit _) = returnUs e
619 do_CoreExpr venv tenv (Con con as)
620 = mapUs (do_CoreArg venv tenv) as `thenUs` \ new_as ->
623 do_CoreExpr venv tenv (Prim op as)
624 = mapUs (do_CoreArg venv tenv) as `thenUs` \ new_as ->
625 do_PrimOp op `thenUs` \ new_op ->
626 mkCoPrim new_op new_as
628 do_PrimOp (CCallOp label is_asm may_gc arg_tys result_ty)
630 new_arg_tys = map (applyTypeEnvToTy tenv) arg_tys
631 new_result_ty = applyTypeEnvToTy tenv result_ty
633 returnUs (CCallOp label is_asm may_gc new_arg_tys new_result_ty)
635 do_PrimOp other_op = returnUs other_op
637 do_CoreExpr venv tenv (Lam (ValBinder binder) expr)
638 = dup_binder tenv binder `thenUs` \(new_binder, (old,new)) ->
639 let new_venv = addOneToIdEnv venv old new in
640 do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
641 returnUs (Lam (ValBinder new_binder) new_expr)
643 do_CoreExpr venv tenv (Lam (TyBinder tyvar) expr)
644 = dup_tyvar tyvar `thenUs` \ (new_tyvar, (old, new)) ->
646 new_tenv = addOneToTyVarEnv tenv old new
648 do_CoreExpr venv new_tenv expr `thenUs` \ new_expr ->
649 returnUs (Lam (TyBinder new_tyvar) new_expr)
651 do_CoreExpr venv tenv (Lam _ expr) = panic "CoreUtils.do_CoreExpr:Lam UsageBinder"
653 do_CoreExpr venv tenv (App expr arg)
654 = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
655 do_CoreArg venv tenv arg `thenUs` \ new_arg ->
656 mkCoApps new_expr [new_arg] -- ToDo: more efficiently?
658 do_CoreExpr venv tenv (Case expr alts)
659 = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
660 do_alts venv tenv alts `thenUs` \ new_alts ->
661 returnUs (Case new_expr new_alts)
663 do_alts venv tenv (AlgAlts alts deflt)
664 = mapUs (do_boxed_alt venv tenv) alts `thenUs` \ new_alts ->
665 do_default venv tenv deflt `thenUs` \ new_deflt ->
666 returnUs (AlgAlts new_alts new_deflt)
668 do_boxed_alt venv tenv (con, binders, expr)
669 = mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (new_binders, new_vmaps) ->
670 let new_venv = growIdEnvList venv new_vmaps in
671 do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
672 returnUs (con, new_binders, new_expr)
675 do_alts venv tenv (PrimAlts alts deflt)
676 = mapUs (do_unboxed_alt venv tenv) alts `thenUs` \ new_alts ->
677 do_default venv tenv deflt `thenUs` \ new_deflt ->
678 returnUs (PrimAlts new_alts new_deflt)
680 do_unboxed_alt venv tenv (lit, expr)
681 = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
682 returnUs (lit, new_expr)
684 do_default venv tenv NoDefault = returnUs NoDefault
686 do_default venv tenv (BindDefault binder expr)
687 = dup_binder tenv binder `thenUs` \ (new_binder, (old, new)) ->
688 let new_venv = addOneToIdEnv venv old new in
689 do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
690 returnUs (BindDefault new_binder new_expr)
692 do_CoreExpr venv tenv (Let core_bind expr)
693 = do_CoreBinding venv tenv core_bind `thenUs` \ (new_bind, new_venv) ->
694 -- and do the body of the let
695 do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
696 returnUs (Let new_bind new_expr)
698 do_CoreExpr venv tenv (SCC label expr)
699 = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
700 returnUs (SCC label new_expr)
702 do_CoreExpr venv tenv (Coerce c ty expr)
703 = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
704 returnUs (Coerce c (applyTypeEnvToTy tenv ty) new_expr)
708 dup_tyvar :: TyVar -> UniqSM (TyVar, (TyVar, Type))
710 = getUnique `thenUs` \ uniq ->
711 let new_tyvar = cloneTyVar tyvar uniq in
712 returnUs (new_tyvar, (tyvar, mkTyVarTy new_tyvar))
714 -- same thing all over again --------------------
716 dup_binder :: TypeEnv -> Id -> UniqSM (Id, (Id, CoreExpr))
718 = if (toplevelishId b) then
719 -- binder is "top-level-ish"; -- it should *NOT* be renamed
720 -- ToDo: it's unsavoury that we return something to heave in env
721 returnUs (b, (b, Var b))
723 else -- otherwise, the full business
724 getUnique `thenUs` \ uniq ->
726 new_b1 = mkIdWithNewUniq b uniq
727 new_b2 = applyTypeEnvToId tenv new_b1
729 returnUs (new_b2, (b, Var new_b2))