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,
35 addOneToIdEnv, growIdEnvList, lookupIdEnv,
36 isNullIdEnv, SYN_IE(IdEnv),
39 import IdInfo ( arityMaybe )
40 import Literal ( literalType, isNoRepLit, Literal(..) )
41 import Maybes ( catMaybes, maybeToBool )
43 import PprStyle ( PprStyle(..) )
44 import PprType ( GenType{-instances-} )
45 import Pretty ( ppAboves, ppStr )
46 import PrelVals ( augmentId, buildId )
47 import PrimOp ( primOpType, PrimOp(..) )
48 import SrcLoc ( mkUnknownSrcLoc )
49 import TyVar ( cloneTyVar,
50 isNullTyVarEnv, addOneToTyVarEnv, SYN_IE(TyVarEnv)
52 import Type ( mkFunTy, mkForAllTy, mkForAllUsageTy, mkTyVarTy,
53 getFunTy_maybe, applyTy, isPrimType,
54 splitSigmaTy, splitFunTy, eqTy, applyTypeEnvToTy
56 import TysWiredIn ( trueDataCon, falseDataCon )
57 import UniqSupply ( initUs, returnUs, thenUs,
58 mapUs, mapAndUnzipUs, getUnique,
59 SYN_IE(UniqSM), UniqSupply
61 import Usage ( SYN_IE(UVar) )
62 import Util ( zipEqual, panic, pprPanic, assertPanic )
64 type TypeEnv = TyVarEnv Type
65 applyUsage = panic "CoreUtils.applyUsage:ToDo"
68 %************************************************************************
70 \subsection{Find the type of a Core atom/expression}
72 %************************************************************************
75 coreExprType :: CoreExpr -> Type
77 coreExprType (Var var) = idType var
78 coreExprType (Lit lit) = literalType lit
80 coreExprType (Let _ body) = coreExprType body
81 coreExprType (SCC _ expr) = coreExprType expr
82 coreExprType (Case _ alts) = coreAltsType alts
84 coreExprType (Coerce _ ty _) = ty -- that's the whole point!
86 -- a Con is a fully-saturated application of a data constructor
87 -- a Prim is <ditto> of a PrimOp
89 coreExprType (Con con args) = applyTypeToArgs (idType con) args
90 coreExprType (Prim op args) = applyTypeToArgs (primOpType op) args
92 coreExprType (Lam (ValBinder binder) expr)
93 = idType binder `mkFunTy` coreExprType expr
95 coreExprType (Lam (TyBinder tyvar) expr)
96 = mkForAllTy tyvar (coreExprType expr)
98 coreExprType (Lam (UsageBinder uvar) expr)
99 = mkForAllUsageTy uvar (panic "coreExprType:Lam UsageBinder") (coreExprType expr)
101 coreExprType (App expr (TyArg ty))
102 = applyTy (coreExprType expr) ty
104 coreExprType (App expr (UsageArg use))
105 = applyUsage (coreExprType expr) use
107 coreExprType (App expr val_arg)
108 = ASSERT(isValArg val_arg)
110 fun_ty = coreExprType expr
112 case (getFunTy_maybe fun_ty) of
113 Just (_, result_ty) -> result_ty
115 Nothing -> pprPanic "coreExprType:\n"
116 (ppAboves [ppr PprDebug fun_ty,
117 ppr PprShowAll (App expr val_arg)])
122 coreAltsType :: CoreCaseAlts -> Type
124 coreAltsType (AlgAlts [] deflt) = default_ty deflt
125 coreAltsType (AlgAlts ((_,_,rhs1):_) _) = coreExprType rhs1
127 coreAltsType (PrimAlts [] deflt) = default_ty deflt
128 coreAltsType (PrimAlts ((_,rhs1):_) _) = coreExprType rhs1
130 default_ty NoDefault = panic "coreExprType:Case:default_ty"
131 default_ty (BindDefault _ rhs) = coreExprType rhs
135 applyTypeToArgs op_ty args = foldl applyTypeToArg op_ty args
137 applyTypeToArg op_ty (TyArg ty) = applyTy op_ty ty
138 applyTypeToArg op_ty (UsageArg _) = panic "applyTypeToArg: UsageArg"
139 applyTypeToArg op_ty val_or_lit_arg = case (getFunTy_maybe op_ty) of
140 Just (_, res_ty) -> res_ty
143 coreExprCc gets the cost centre enclosing an expression, if any.
144 It looks inside lambdas because (scc "foo" \x.e) = \x.scc "foo" e
147 coreExprCc :: GenCoreExpr val_bdr val_occ tyvar uvar -> CostCentre
148 coreExprCc (SCC cc e) = cc
149 coreExprCc (Lam _ e) = coreExprCc e
150 coreExprCc other = noCostCentre
153 %************************************************************************
155 \subsection{Routines to manufacture bits of @CoreExpr@}
157 %************************************************************************
160 mkCoreIfThenElse (Var bool) then_expr else_expr
161 | bool == trueDataCon = then_expr
162 | bool == falseDataCon = else_expr
164 mkCoreIfThenElse guard then_expr else_expr
166 (AlgAlts [ (trueDataCon, [], then_expr),
167 (falseDataCon, [], else_expr) ]
171 For making @Apps@ and @Lets@, we must take appropriate evasive
172 action if the thing being bound has unboxed type. @mkCoApp@ requires
173 a name supply to do its work.
175 @mkCoApps@, @mkCoCon@ and @mkCoPrim@ also handle the
176 arguments-must-be-atoms constraint.
183 mkCoApps :: CoreExpr -> [CoreArgOrExpr] -> UniqSM CoreExpr
184 mkCoCon :: Id -> [CoreArgOrExpr] -> UniqSM CoreExpr
185 mkCoPrim :: PrimOp -> [CoreArgOrExpr] -> UniqSM CoreExpr
187 mkCoApps fun args = co_thing (mkGenApp fun) args
188 mkCoCon con args = co_thing (Con con) args
189 mkCoPrim op args = co_thing (Prim op) args
191 co_thing :: ([CoreArg] -> CoreExpr)
195 co_thing thing arg_exprs
196 = mapAndUnzipUs expr_to_arg arg_exprs `thenUs` \ (args, maybe_binds) ->
197 returnUs (mkCoLetsUnboxedToCase (catMaybes maybe_binds) (thing args))
199 expr_to_arg :: CoreArgOrExpr
200 -> UniqSM (CoreArg, Maybe CoreBinding)
202 expr_to_arg (AnArg arg) = returnUs (arg, Nothing)
203 expr_to_arg (AnExpr (Var v)) = returnUs (VarArg v, Nothing)
204 expr_to_arg (AnExpr (Lit l)) = returnUs (LitArg l, Nothing)
205 expr_to_arg (AnExpr other_expr)
207 e_ty = coreExprType other_expr
209 getUnique `thenUs` \ uniq ->
211 new_var = mkSysLocal SLIT("a") uniq e_ty mkUnknownSrcLoc
213 returnUs (VarArg new_var, Just (NonRec new_var other_expr))
218 GenCoreArg val_occ tyvar uvar -> GenCoreExpr val_bdr val_occ tyvar uvar
220 argToExpr (VarArg v) = Var v
221 argToExpr (LitArg lit) = Lit lit
227 :: (Id -> Maybe (GenCoreExpr bndr Id))
228 -> GenCoreExpr bndr Id
230 coreExprArity f (Lam _ expr) = coreExprArity f expr + 1
231 coreExprArity f (CoTyLam _ expr) = coreExprArity f expr
232 coreExprArity f (App expr arg) = max (coreExprArity f expr - 1) 0
233 coreExprArity f (CoTyApp expr _) = coreExprArity f expr
234 coreExprArity f (Var v) = max further info
239 Just expr -> coreExprArity f expr
240 info = case (arityMaybe (getIdArity v)) of
243 coreExprArity f _ = 0
246 @isWrapperFor@: we want to see exactly:
248 /\ ... \ args -> case <arg> of ... -> case <arg> of ... -> wrkr <stuff>
251 Probably a little too HACKY [WDP].
254 isWrapperFor :: CoreExpr -> Id -> Bool
256 expr `isWrapperFor` var
257 = case (collectBinders expr) of { (_, _, args, body) -> -- lambdas off the front
258 unravel_casing args body
259 --NO, THANKS: && not (null args)
262 var's_worker = getWorkerId (getIdStrictness var)
264 is_elem = isIn "isWrapperFor"
267 unravel_casing case_ables (Case scrut alts)
268 = case (collectArgs scrut) of { (fun, _, _, vargs) ->
272 scrut_var /= var && all (doesn't_mention var) vargs
273 && scrut_var `is_elem` case_ables
274 && unravel_alts case_ables alts
281 unravel_casing case_ables other_expr
282 = case (collectArgs other_expr) of { (fun, _, _, vargs) ->
286 -- DOESN'T WORK: wrkr == var's_worker
289 && all (doesn't_mention var) vargs
290 && all (only_from case_ables) vargs
298 unravel_alts case_ables (AlgAlts [(_,params,rhs)] NoDefault)
299 = unravel_casing (params ++ case_ables) rhs
300 unravel_alts case_ables other = False
302 -------------------------
303 doesn't_mention var (ValArg (VarArg v)) = v /= var
304 doesn't_mention var other = True
306 -------------------------
307 only_from case_ables (ValArg (VarArg v)) = v `is_elem` case_ables
308 only_from case_ables other = True
312 All the following functions operate on binders, perform a uniform
313 transformation on them; ie. the function @(\ x -> (x,False))@
314 annotates all binders with False.
317 unTagBinders :: GenCoreExpr (Id,tag) bdee tv uv -> GenCoreExpr Id bdee tv uv
318 unTagBinders expr = bop_expr fst expr
320 unTagBindersAlts :: GenCoreCaseAlts (Id,tag) bdee tv uv -> GenCoreCaseAlts Id bdee tv uv
321 unTagBindersAlts alts = bop_alts fst alts
325 bop_expr :: (a -> b) -> GenCoreExpr a bdee tv uv -> GenCoreExpr b bdee tv uv
327 bop_expr f (Var b) = Var b
328 bop_expr f (Lit lit) = Lit lit
329 bop_expr f (Con con args) = Con con args
330 bop_expr f (Prim op args) = Prim op args
331 bop_expr f (Lam binder expr) = Lam (bop_binder f binder) (bop_expr f expr)
332 bop_expr f (App expr arg) = App (bop_expr f expr) arg
333 bop_expr f (SCC label expr) = SCC label (bop_expr f expr)
334 bop_expr f (Coerce c ty e) = Coerce c ty (bop_expr f e)
335 bop_expr f (Let bind expr) = Let (bop_bind f bind) (bop_expr f expr)
336 bop_expr f (Case expr alts) = Case (bop_expr f expr) (bop_alts f alts)
338 bop_binder f (ValBinder v) = ValBinder (f v)
339 bop_binder f (TyBinder t) = TyBinder t
340 bop_binder f (UsageBinder u) = UsageBinder u
342 bop_bind f (NonRec b e) = NonRec (f b) (bop_expr f e)
343 bop_bind f (Rec pairs) = Rec [(f b, bop_expr f e) | (b, e) <- pairs]
345 bop_alts f (AlgAlts alts deflt)
346 = AlgAlts [ (con, [f b | b <- binders], bop_expr f e)
347 | (con, binders, e) <- alts ]
350 bop_alts f (PrimAlts alts deflt)
351 = PrimAlts [ (lit, bop_expr f e) | (lit, e) <- alts ]
354 bop_deflt f (NoDefault) = NoDefault
355 bop_deflt f (BindDefault b expr) = BindDefault (f b) (bop_expr f expr)
358 OLD (but left here because of the nice example): @singleAlt@ checks
359 whether a bunch of case alternatives is actually just one alternative.
360 It specifically {\em ignores} alternatives which consist of just a
361 call to @error@, because they won't result in any code duplication.
365 case (case <something> of
367 False -> error "Foo") of
373 True -> case <rhs> of
375 False -> case error "Foo" of
381 True -> case <rhs> of
385 Notice that the \tr{<alts>} don't get duplicated.
388 nonErrorRHSs :: GenCoreCaseAlts a Id TyVar UVar -> [GenCoreExpr a Id TyVar UVar]
391 = filter not_error_app (find_rhss alts)
393 find_rhss (AlgAlts as deflt) = [rhs | (_,_,rhs) <- as] ++ deflt_rhs deflt
394 find_rhss (PrimAlts as deflt) = [rhs | (_,rhs) <- as] ++ deflt_rhs deflt
396 deflt_rhs NoDefault = []
397 deflt_rhs (BindDefault _ rhs) = [rhs]
400 = case (maybeErrorApp rhs Nothing) of
405 maybeErrorApp checks whether an expression is of the form
411 Just (error ty' args)
413 where ty' is supplied as an argument to maybeErrorApp.
415 Here's where it is useful:
417 case (error ty "Foo" e1 e2) of <alts>
421 where ty' is the type of any of the alternatives. You might think
422 this never occurs, but see the comments on the definition of
425 Note: we *avoid* the case where ty' might end up as a primitive type:
426 this is very uncool (totally wrong).
428 NOTICE: in the example above we threw away e1 and e2, but not the
429 string "Foo". How did we know to do that?
431 Answer: for now anyway, we only handle the case of a function whose
434 bottomingFn :: forall a. t1 -> ... -> tn -> a
435 ^---------------------^ NB!
437 Furthermore, we only count a bottomingApp if the function is applied
438 to more than n args. If so, we transform:
440 bottomingFn ty e1 ... en en+1 ... em
442 bottomingFn ty' e1 ... en
444 That is, we discard en+1 .. em
448 :: GenCoreExpr a Id TyVar UVar -- Expr to look at
449 -> Maybe Type -- Just ty => a result type *already cloned*;
450 -- Nothing => don't know result ty; we
451 -- *pretend* that the result ty won't be
452 -- primitive -- somebody later must
454 -> Maybe (GenCoreExpr a Id TyVar UVar)
456 maybeErrorApp expr result_ty_maybe
457 = case (collectArgs expr) of
458 (Var fun, [{-no usage???-}], [ty], other_args)
460 && maybeToBool result_ty_maybe -- we *know* the result type
461 -- (otherwise: live a fairy-tale existence...)
462 && not (isPrimType result_ty) ->
464 case (splitSigmaTy (idType fun)) of
465 ([tyvar], [], tau_ty) ->
466 case (splitFunTy tau_ty) of { (arg_tys, res_ty) ->
468 n_args_to_keep = length arg_tys
469 args_to_keep = take n_args_to_keep other_args
471 if (res_ty `eqTy` mkTyVarTy tyvar)
472 && n_args_to_keep <= length other_args
474 -- Phew! We're in business
475 Just (mkGenApp (Var fun) (TyArg result_ty : args_to_keep))
480 other -> Nothing -- Function type wrong shape
483 Just result_ty = result_ty_maybe
487 squashableDictishCcExpr :: CostCentre -> GenCoreExpr a b c d -> Bool
489 squashableDictishCcExpr cc expr
490 = if not (isDictCC cc) then
491 False -- that was easy...
493 squashable expr -- note: quite like the "atomic_rhs" stuff in simplifier
495 squashable (Var _) = True
496 squashable (Con _ _) = True -- I think so... WDP 94/09
497 squashable (Prim _ _) = True -- ditto
499 | notValArg a = squashable f
500 squashable other = False
503 %************************************************************************
505 \subsection{Core-renaming utils}
507 %************************************************************************
510 substCoreBindings :: ValEnv
511 -> TypeEnv -- TyVar=>Type
513 -> UniqSM [CoreBinding]
515 substCoreExpr :: ValEnv
516 -> TypeEnv -- TyVar=>Type
520 substCoreBindings venv tenv binds
521 -- if the envs are empty, then avoid doing anything
522 = if (isNullIdEnv venv && isNullTyVarEnv tenv) then
525 do_CoreBindings venv tenv binds
527 substCoreExpr venv tenv expr
528 = if (isNullIdEnv venv && isNullTyVarEnv tenv) then
531 do_CoreExpr venv tenv expr
534 The equiv code for @Types@ is in @TyUtils@.
536 Because binders aren't necessarily unique: we don't do @plusEnvs@
537 (which check for duplicates); rather, we use the shadowing version,
538 @growIdEnv@ (and shorthand @addOneToIdEnv@).
540 @do_CoreBindings@ takes into account the semantics of a list of
541 @CoreBindings@---things defined early in the list are visible later in
542 the list, but not vice versa.
545 type ValEnv = IdEnv CoreExpr
547 do_CoreBindings :: ValEnv
550 -> UniqSM [CoreBinding]
552 do_CoreBinding :: ValEnv
555 -> UniqSM (CoreBinding, ValEnv)
557 do_CoreBindings venv tenv [] = returnUs []
558 do_CoreBindings venv tenv (b:bs)
559 = do_CoreBinding venv tenv b `thenUs` \ (new_b, new_venv) ->
560 do_CoreBindings new_venv tenv bs `thenUs` \ new_bs ->
561 returnUs (new_b : new_bs)
563 do_CoreBinding venv tenv (NonRec binder rhs)
564 = do_CoreExpr venv tenv rhs `thenUs` \ new_rhs ->
566 dup_binder tenv binder `thenUs` \ (new_binder, (old, new)) ->
567 -- now plug new bindings into envs
568 let new_venv = addOneToIdEnv venv old new in
570 returnUs (NonRec new_binder new_rhs, new_venv)
572 do_CoreBinding venv tenv (Rec binds)
573 = -- for letrec, we plug in new bindings BEFORE cloning rhss
574 mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (new_binders, new_maps) ->
575 let new_venv = growIdEnvList venv new_maps in
577 mapUs (do_CoreExpr new_venv tenv) rhss `thenUs` \ new_rhss ->
578 returnUs (Rec (zipEqual "do_CoreBinding" new_binders new_rhss), new_venv)
580 (binders, rhss) = unzip binds
587 -> UniqSM CoreArgOrExpr
589 do_CoreArg venv tenv a@(VarArg v)
591 case (lookupIdEnv venv v) of
593 Just expr -> AnExpr expr
596 do_CoreArg venv tenv (TyArg ty)
597 = returnUs (AnArg (TyArg (applyTypeEnvToTy tenv ty)))
599 do_CoreArg venv tenv other_arg = returnUs (AnArg other_arg)
603 do_CoreExpr :: ValEnv
608 do_CoreExpr venv tenv orig_expr@(Var var)
610 case (lookupIdEnv venv var) of
611 Nothing -> --false:ASSERT(toplevelishId var) (SIGH)
616 do_CoreExpr venv tenv e@(Lit _) = returnUs e
618 do_CoreExpr venv tenv (Con con as)
619 = mapUs (do_CoreArg venv tenv) as `thenUs` \ new_as ->
622 do_CoreExpr venv tenv (Prim op as)
623 = mapUs (do_CoreArg venv tenv) as `thenUs` \ new_as ->
624 do_PrimOp op `thenUs` \ new_op ->
625 mkCoPrim new_op new_as
627 do_PrimOp (CCallOp label is_asm may_gc arg_tys result_ty)
629 new_arg_tys = map (applyTypeEnvToTy tenv) arg_tys
630 new_result_ty = applyTypeEnvToTy tenv result_ty
632 returnUs (CCallOp label is_asm may_gc new_arg_tys new_result_ty)
634 do_PrimOp other_op = returnUs other_op
636 do_CoreExpr venv tenv (Lam (ValBinder binder) expr)
637 = dup_binder tenv binder `thenUs` \(new_binder, (old,new)) ->
638 let new_venv = addOneToIdEnv venv old new in
639 do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
640 returnUs (Lam (ValBinder new_binder) new_expr)
642 do_CoreExpr venv tenv (Lam (TyBinder tyvar) expr)
643 = dup_tyvar tyvar `thenUs` \ (new_tyvar, (old, new)) ->
645 new_tenv = addOneToTyVarEnv tenv old new
647 do_CoreExpr venv new_tenv expr `thenUs` \ new_expr ->
648 returnUs (Lam (TyBinder new_tyvar) new_expr)
650 do_CoreExpr venv tenv (Lam _ expr) = panic "CoreUtils.do_CoreExpr:Lam UsageBinder"
652 do_CoreExpr venv tenv (App expr arg)
653 = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
654 do_CoreArg venv tenv arg `thenUs` \ new_arg ->
655 mkCoApps new_expr [new_arg] -- ToDo: more efficiently?
657 do_CoreExpr venv tenv (Case expr alts)
658 = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
659 do_alts venv tenv alts `thenUs` \ new_alts ->
660 returnUs (Case new_expr new_alts)
662 do_alts venv tenv (AlgAlts alts deflt)
663 = mapUs (do_boxed_alt venv tenv) alts `thenUs` \ new_alts ->
664 do_default venv tenv deflt `thenUs` \ new_deflt ->
665 returnUs (AlgAlts new_alts new_deflt)
667 do_boxed_alt venv tenv (con, binders, expr)
668 = mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (new_binders, new_vmaps) ->
669 let new_venv = growIdEnvList venv new_vmaps in
670 do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
671 returnUs (con, new_binders, new_expr)
674 do_alts venv tenv (PrimAlts alts deflt)
675 = mapUs (do_unboxed_alt venv tenv) alts `thenUs` \ new_alts ->
676 do_default venv tenv deflt `thenUs` \ new_deflt ->
677 returnUs (PrimAlts new_alts new_deflt)
679 do_unboxed_alt venv tenv (lit, expr)
680 = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
681 returnUs (lit, new_expr)
683 do_default venv tenv NoDefault = returnUs NoDefault
685 do_default venv tenv (BindDefault binder expr)
686 = dup_binder tenv binder `thenUs` \ (new_binder, (old, new)) ->
687 let new_venv = addOneToIdEnv venv old new in
688 do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
689 returnUs (BindDefault new_binder new_expr)
691 do_CoreExpr venv tenv (Let core_bind expr)
692 = do_CoreBinding venv tenv core_bind `thenUs` \ (new_bind, new_venv) ->
693 -- and do the body of the let
694 do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
695 returnUs (Let new_bind new_expr)
697 do_CoreExpr venv tenv (SCC label expr)
698 = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
699 returnUs (SCC label new_expr)
701 do_CoreExpr venv tenv (Coerce c ty expr)
702 = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
703 returnUs (Coerce c (applyTypeEnvToTy tenv ty) new_expr)
707 dup_tyvar :: TyVar -> UniqSM (TyVar, (TyVar, Type))
709 = getUnique `thenUs` \ uniq ->
710 let new_tyvar = cloneTyVar tyvar uniq in
711 returnUs (new_tyvar, (tyvar, mkTyVarTy new_tyvar))
713 -- same thing all over again --------------------
715 dup_binder :: TypeEnv -> Id -> UniqSM (Id, (Id, CoreExpr))
717 = if (toplevelishId b) then
718 -- binder is "top-level-ish"; -- it should *NOT* be renamed
719 -- ToDo: it's unsavoury that we return something to heave in env
720 returnUs (b, (b, Var b))
722 else -- otherwise, the full business
723 getUnique `thenUs` \ uniq ->
725 new_b1 = mkIdWithNewUniq b uniq
726 new_b2 = applyTypeEnvToId tenv new_b1
728 returnUs (new_b2, (b, Var new_b2))