2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[CoreUtils]{Utility functions on @Core@ syntax}
8 coreExprType, coreAltsType, coreExprCc,
10 substCoreExpr, substCoreBindings
14 , unTagBinders, unTagBindersAlts
18 , squashableDictishCcExpr
21 #include "HsVersions.h"
25 import CostCentre ( isDictCC, CostCentre, noCostCentre )
26 import Id ( idType, mkSysLocal, isBottomingId,
27 toplevelishId, mkIdWithNewUniq, applyTypeEnvToId,
29 addOneToIdEnv, growIdEnvList, lookupIdEnv,
30 isNullIdEnv, IdEnv, Id
32 import Literal ( literalType, Literal(..) )
33 import Maybes ( catMaybes, maybeToBool )
35 import PrimOp ( primOpType, PrimOp(..) )
36 import SrcLoc ( noSrcLoc )
37 import TyVar ( cloneTyVar,
38 isEmptyTyVarEnv, addToTyVarEnv, TyVarEnv,
41 import Type ( mkFunTy, mkForAllTy, mkTyVarTy,
42 splitFunTy_maybe, applyTy, isUnpointedType,
43 splitSigmaTy, splitFunTys, instantiateTy,
46 import TysWiredIn ( trueDataCon, falseDataCon )
47 import Unique ( Unique )
48 import BasicTypes ( Unused )
49 import UniqSupply ( returnUs, thenUs,
50 mapUs, mapAndUnzipUs, getUnique,
53 import Util ( zipEqual )
56 type TypeEnv = TyVarEnv Type
59 %************************************************************************
61 \subsection{Find the type of a Core atom/expression}
63 %************************************************************************
66 coreExprType :: CoreExpr -> Type
68 coreExprType (Var var) = idType var
69 coreExprType (Lit lit) = literalType lit
71 coreExprType (Let _ body) = coreExprType body
72 coreExprType (SCC _ expr) = coreExprType expr
73 coreExprType (Case _ alts) = coreAltsType alts
75 coreExprType (Coerce _ ty _) = ty -- that's the whole point!
77 -- a Con is a fully-saturated application of a data constructor
78 -- a Prim is <ditto> of a PrimOp
80 coreExprType (Con con args) =
81 -- pprTrace "appTyArgs" (hsep [ppr con, semi,
84 applyTypeToArgs con_ty args
86 con_ty = dataConRepType con
88 coreExprType (Prim op args) = applyTypeToArgs (primOpType op) args
90 coreExprType (Lam (ValBinder binder) expr)
91 = idType binder `mkFunTy` coreExprType expr
93 coreExprType (Lam (TyBinder tyvar) expr)
94 = mkForAllTy tyvar (coreExprType expr)
96 coreExprType (App expr (TyArg ty))
98 -- pprTrace "appTy1" (hsep [ppr fun_ty, space, ppr ty]) $
101 fun_ty = coreExprType expr
103 coreExprType (App expr val_arg)
104 = ASSERT(isValArg val_arg)
106 fun_ty = coreExprType expr
108 case (splitFunTy_maybe fun_ty) of
109 Just (_, result_ty) -> result_ty
111 Nothing -> pprPanic "coreExprType:\n"
112 (vcat [ppr fun_ty, ppr (App expr val_arg)])
117 coreAltsType :: CoreCaseAlts -> Type
119 coreAltsType (AlgAlts [] deflt) = default_ty deflt
120 coreAltsType (AlgAlts ((_,_,rhs1):_) _) = coreExprType rhs1
122 coreAltsType (PrimAlts [] deflt) = default_ty deflt
123 coreAltsType (PrimAlts ((_,rhs1):_) _) = coreExprType rhs1
125 default_ty NoDefault = panic "coreExprType:Case:default_ty"
126 default_ty (BindDefault _ rhs) = coreExprType rhs
130 applyTypeToArgs op_ty args = foldl applyTypeToArg op_ty args
132 applyTypeToArg op_ty (TyArg ty) = applyTy op_ty ty
133 applyTypeToArg op_ty val_or_lit_arg = case (splitFunTy_maybe op_ty) of
134 Just (_, res_ty) -> res_ty
137 coreExprCc gets the cost centre enclosing an expression, if any.
138 It looks inside lambdas because (scc "foo" \x.e) = \x.scc "foo" e
141 coreExprCc :: GenCoreExpr val_bdr val_occ flexi -> CostCentre
142 coreExprCc (SCC cc e) = cc
143 coreExprCc (Lam _ e) = coreExprCc e
144 coreExprCc other = noCostCentre
147 %************************************************************************
149 \subsection{Routines to manufacture bits of @CoreExpr@}
151 %************************************************************************
154 mkCoreIfThenElse (Var bool) then_expr else_expr
155 | bool == trueDataCon = then_expr
156 | bool == falseDataCon = else_expr
158 mkCoreIfThenElse guard then_expr else_expr
160 (AlgAlts [ (trueDataCon, [], then_expr),
161 (falseDataCon, [], else_expr) ]
165 For making @Apps@ and @Lets@, we must take appropriate evasive
166 action if the thing being bound has unboxed type. @mkCoApp@ requires
167 a name supply to do its work.
169 @mkCoApps@, @mkCoCon@ and @mkCoPrim@ also handle the
170 arguments-must-be-atoms constraint.
177 mkCoApps :: CoreExpr -> [CoreArgOrExpr] -> UniqSM CoreExpr
178 mkCoCon :: Id -> [CoreArgOrExpr] -> UniqSM CoreExpr
179 mkCoPrim :: PrimOp -> [CoreArgOrExpr] -> UniqSM CoreExpr
181 mkCoApps fun args = co_thing (mkGenApp fun) args
182 mkCoCon con args = co_thing (Con con) args
183 mkCoPrim op args = co_thing (Prim op) args
185 co_thing :: ([CoreArg] -> CoreExpr)
189 co_thing thing arg_exprs
190 = mapAndUnzipUs expr_to_arg arg_exprs `thenUs` \ (args, maybe_binds) ->
191 returnUs (mkCoLetsUnboxedToCase (catMaybes maybe_binds) (thing args))
193 expr_to_arg :: CoreArgOrExpr
194 -> UniqSM (CoreArg, Maybe CoreBinding)
196 expr_to_arg (AnArg arg) = returnUs (arg, Nothing)
197 expr_to_arg (AnExpr (Var v)) = returnUs (VarArg v, Nothing)
198 expr_to_arg (AnExpr (Lit l)) = returnUs (LitArg l, Nothing)
199 expr_to_arg (AnExpr other_expr)
201 e_ty = coreExprType other_expr
203 getUnique `thenUs` \ uniq ->
205 new_var = mkSysLocal SLIT("a") uniq e_ty noSrcLoc
207 returnUs (VarArg new_var, Just (NonRec new_var other_expr))
212 GenCoreArg val_occ flexi -> GenCoreExpr val_bdr val_occ flexi
214 argToExpr (VarArg v) = Var v
215 argToExpr (LitArg lit) = Lit lit
218 All the following functions operate on binders, perform a uniform
219 transformation on them; ie. the function @(\ x -> (x,False))@
220 annotates all binders with False.
223 unTagBinders :: GenCoreExpr (Id,tag) bdee flexi -> GenCoreExpr Id bdee flexi
224 unTagBinders expr = bop_expr fst expr
226 unTagBindersAlts :: GenCoreCaseAlts (Id,tag) bdee flexi -> GenCoreCaseAlts Id bdee flexi
227 unTagBindersAlts alts = bop_alts fst alts
231 bop_expr :: (a -> b) -> GenCoreExpr a bdee flexi -> GenCoreExpr b bdee flexi
233 bop_expr f (Var b) = Var b
234 bop_expr f (Lit lit) = Lit lit
235 bop_expr f (Con con args) = Con con args
236 bop_expr f (Prim op args) = Prim op args
237 bop_expr f (Lam binder expr) = Lam (bop_binder f binder) (bop_expr f expr)
238 bop_expr f (App expr arg) = App (bop_expr f expr) arg
239 bop_expr f (SCC label expr) = SCC label (bop_expr f expr)
240 bop_expr f (Coerce c ty e) = Coerce c ty (bop_expr f e)
241 bop_expr f (Let bind expr) = Let (bop_bind f bind) (bop_expr f expr)
242 bop_expr f (Case expr alts) = Case (bop_expr f expr) (bop_alts f alts)
244 bop_binder f (ValBinder v) = ValBinder (f v)
245 bop_binder f (TyBinder t) = TyBinder t
247 bop_bind f (NonRec b e) = NonRec (f b) (bop_expr f e)
248 bop_bind f (Rec pairs) = Rec [(f b, bop_expr f e) | (b, e) <- pairs]
250 bop_alts f (AlgAlts alts deflt)
251 = AlgAlts [ (con, [f b | b <- binders], bop_expr f e)
252 | (con, binders, e) <- alts ]
255 bop_alts f (PrimAlts alts deflt)
256 = PrimAlts [ (lit, bop_expr f e) | (lit, e) <- alts ]
259 bop_deflt f (NoDefault) = NoDefault
260 bop_deflt f (BindDefault b expr) = BindDefault (f b) (bop_expr f expr)
263 OLD (but left here because of the nice example): @singleAlt@ checks
264 whether a bunch of case alternatives is actually just one alternative.
265 It specifically {\em ignores} alternatives which consist of just a
266 call to @error@, because they won't result in any code duplication.
270 case (case <something> of
272 False -> error "Foo") of
278 True -> case <rhs> of
280 False -> case error "Foo" of
286 True -> case <rhs> of
290 Notice that the \tr{<alts>} don't get duplicated.
293 nonErrorRHSs :: GenCoreCaseAlts a Id Unused -> [GenCoreExpr a Id Unused]
296 = filter not_error_app (find_rhss alts)
298 find_rhss (AlgAlts as deflt) = [rhs | (_,_,rhs) <- as] ++ deflt_rhs deflt
299 find_rhss (PrimAlts as deflt) = [rhs | (_,rhs) <- as] ++ deflt_rhs deflt
301 deflt_rhs NoDefault = []
302 deflt_rhs (BindDefault _ rhs) = [rhs]
305 = case (maybeErrorApp rhs Nothing) of
310 maybeErrorApp checks whether an expression is of the form
316 Just (error ty' args)
318 where ty' is supplied as an argument to maybeErrorApp.
320 Here's where it is useful:
322 case (error ty "Foo" e1 e2) of <alts>
326 where ty' is the type of any of the alternatives. You might think
327 this never occurs, but see the comments on the definition of
330 Note: we *avoid* the case where ty' might end up as a primitive type:
331 this is very uncool (totally wrong).
333 NOTICE: in the example above we threw away e1 and e2, but not the
334 string "Foo". How did we know to do that?
336 Answer: for now anyway, we only handle the case of a function whose
339 bottomingFn :: forall a. t1 -> ... -> tn -> a
340 ^---------------------^ NB!
342 Furthermore, we only count a bottomingApp if the function is applied
343 to more than n args. If so, we transform:
345 bottomingFn ty e1 ... en en+1 ... em
347 bottomingFn ty' e1 ... en
349 That is, we discard en+1 .. em
353 :: GenCoreExpr a Id Unused -- Expr to look at
354 -> Maybe Type -- Just ty => a result type *already cloned*;
355 -- Nothing => don't know result ty; we
356 -- *pretend* that the result ty won't be
357 -- primitive -- somebody later must
359 -> Maybe (GenCoreExpr b Id Unused)
361 maybeErrorApp expr result_ty_maybe
362 = case (collectArgs expr) of
363 (Var fun, [ty], other_args)
365 && maybeToBool result_ty_maybe -- we *know* the result type
366 -- (otherwise: live a fairy-tale existence...)
367 && not (isUnpointedType result_ty) ->
369 case (splitSigmaTy (idType fun)) of
370 ([tyvar], [], tau_ty) ->
371 case (splitFunTys tau_ty) of { (arg_tys, res_ty) ->
373 n_args_to_keep = length arg_tys
374 args_to_keep = take n_args_to_keep other_args
376 if (res_ty == mkTyVarTy tyvar)
377 && n_args_to_keep <= length other_args
379 -- Phew! We're in business
380 Just (mkGenApp (Var fun) (TyArg result_ty : args_to_keep))
385 other -> Nothing -- Function type wrong shape
388 Just result_ty = result_ty_maybe
392 squashableDictishCcExpr :: CostCentre -> GenCoreExpr a b c -> Bool
394 squashableDictishCcExpr cc expr
395 = if not (isDictCC cc) then
396 False -- that was easy...
398 squashable expr -- note: quite like the "atomic_rhs" stuff in simplifier
400 squashable (Var _) = True
401 squashable (Con _ _) = True -- I think so... WDP 94/09
402 squashable (Prim _ _) = True -- ditto
404 | notValArg a = squashable f
405 squashable other = False
408 %************************************************************************
410 \subsection{Core-renaming utils}
412 %************************************************************************
415 substCoreBindings :: ValEnv
416 -> TypeEnv -- TyVar=>Type
418 -> UniqSM [CoreBinding]
420 substCoreExpr :: ValEnv
421 -> TypeEnv -- TyVar=>Type
425 substCoreBindings venv tenv binds
426 -- if the envs are empty, then avoid doing anything
427 = if (isNullIdEnv venv && isEmptyTyVarEnv tenv) then
430 do_CoreBindings venv tenv binds
432 substCoreExpr venv tenv expr
433 = if (isNullIdEnv venv && isEmptyTyVarEnv tenv) then
436 do_CoreExpr venv tenv expr
439 The equiv code for @Types@ is in @TyUtils@.
441 Because binders aren't necessarily unique: we don't do @plusEnvs@
442 (which check for duplicates); rather, we use the shadowing version,
443 @growIdEnv@ (and shorthand @addOneToIdEnv@).
445 @do_CoreBindings@ takes into account the semantics of a list of
446 @CoreBindings@---things defined early in the list are visible later in
447 the list, but not vice versa.
450 type ValEnv = IdEnv CoreExpr
452 do_CoreBindings :: ValEnv
455 -> UniqSM [CoreBinding]
457 do_CoreBinding :: ValEnv
460 -> UniqSM (CoreBinding, ValEnv)
462 do_CoreBindings venv tenv [] = returnUs []
463 do_CoreBindings venv tenv (b:bs)
464 = do_CoreBinding venv tenv b `thenUs` \ (new_b, new_venv) ->
465 do_CoreBindings new_venv tenv bs `thenUs` \ new_bs ->
466 returnUs (new_b : new_bs)
468 do_CoreBinding venv tenv (NonRec binder rhs)
469 = do_CoreExpr venv tenv rhs `thenUs` \ new_rhs ->
471 dup_binder tenv binder `thenUs` \ (new_binder, (old, new)) ->
472 -- now plug new bindings into envs
473 let new_venv = addOneToIdEnv venv old new in
475 returnUs (NonRec new_binder new_rhs, new_venv)
477 do_CoreBinding venv tenv (Rec binds)
478 = -- for letrec, we plug in new bindings BEFORE cloning rhss
479 mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (new_binders, new_maps) ->
480 let new_venv = growIdEnvList venv new_maps in
482 mapUs (do_CoreExpr new_venv tenv) rhss `thenUs` \ new_rhss ->
483 returnUs (Rec (zipEqual "do_CoreBinding" new_binders new_rhss), new_venv)
485 (binders, rhss) = unzip binds
492 -> UniqSM CoreArgOrExpr
494 do_CoreArg venv tenv a@(VarArg v)
496 case (lookupIdEnv venv v) of
498 Just expr -> AnExpr expr
501 do_CoreArg venv tenv (TyArg ty)
502 = returnUs (AnArg (TyArg (instantiateTy tenv ty)))
504 do_CoreArg venv tenv other_arg = returnUs (AnArg other_arg)
508 do_CoreExpr :: ValEnv
513 do_CoreExpr venv tenv orig_expr@(Var var)
515 case (lookupIdEnv venv var) of
516 Nothing -> --false:ASSERT(toplevelishId var) (SIGH)
521 do_CoreExpr venv tenv e@(Lit _) = returnUs e
523 do_CoreExpr venv tenv (Con con as)
524 = mapUs (do_CoreArg venv tenv) as `thenUs` \ new_as ->
527 do_CoreExpr venv tenv (Prim op as)
528 = mapUs (do_CoreArg venv tenv) as `thenUs` \ new_as ->
529 do_PrimOp op `thenUs` \ new_op ->
530 mkCoPrim new_op new_as
532 do_PrimOp (CCallOp label is_asm may_gc arg_tys result_ty)
534 new_arg_tys = map (instantiateTy tenv) arg_tys
535 new_result_ty = instantiateTy tenv result_ty
537 returnUs (CCallOp label is_asm may_gc new_arg_tys new_result_ty)
539 do_PrimOp other_op = returnUs other_op
541 do_CoreExpr venv tenv (Lam (ValBinder binder) expr)
542 = dup_binder tenv binder `thenUs` \(new_binder, (old,new)) ->
543 let new_venv = addOneToIdEnv venv old new in
544 do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
545 returnUs (Lam (ValBinder new_binder) new_expr)
547 do_CoreExpr venv tenv (Lam (TyBinder tyvar) expr)
548 = dup_tyvar tyvar `thenUs` \ (new_tyvar, (old, new)) ->
550 new_tenv = addToTyVarEnv tenv old new
552 do_CoreExpr venv new_tenv expr `thenUs` \ new_expr ->
553 returnUs (Lam (TyBinder new_tyvar) new_expr)
555 do_CoreExpr venv tenv (App expr arg)
556 = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
557 do_CoreArg venv tenv arg `thenUs` \ new_arg ->
558 mkCoApps new_expr [new_arg] -- ToDo: more efficiently?
560 do_CoreExpr venv tenv (Case expr alts)
561 = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
562 do_alts venv tenv alts `thenUs` \ new_alts ->
563 returnUs (Case new_expr new_alts)
565 do_alts venv tenv (AlgAlts alts deflt)
566 = mapUs (do_boxed_alt venv tenv) alts `thenUs` \ new_alts ->
567 do_default venv tenv deflt `thenUs` \ new_deflt ->
568 returnUs (AlgAlts new_alts new_deflt)
570 do_boxed_alt venv tenv (con, binders, expr)
571 = mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (new_binders, new_vmaps) ->
572 let new_venv = growIdEnvList venv new_vmaps in
573 do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
574 returnUs (con, new_binders, new_expr)
577 do_alts venv tenv (PrimAlts alts deflt)
578 = mapUs (do_unboxed_alt venv tenv) alts `thenUs` \ new_alts ->
579 do_default venv tenv deflt `thenUs` \ new_deflt ->
580 returnUs (PrimAlts new_alts new_deflt)
582 do_unboxed_alt venv tenv (lit, expr)
583 = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
584 returnUs (lit, new_expr)
586 do_default venv tenv NoDefault = returnUs NoDefault
588 do_default venv tenv (BindDefault binder expr)
589 = dup_binder tenv binder `thenUs` \ (new_binder, (old, new)) ->
590 let new_venv = addOneToIdEnv venv old new in
591 do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
592 returnUs (BindDefault new_binder new_expr)
594 do_CoreExpr venv tenv (Let core_bind expr)
595 = do_CoreBinding venv tenv core_bind `thenUs` \ (new_bind, new_venv) ->
596 -- and do the body of the let
597 do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
598 returnUs (Let new_bind new_expr)
600 do_CoreExpr venv tenv (SCC label expr)
601 = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
602 returnUs (SCC label new_expr)
604 do_CoreExpr venv tenv (Coerce c ty expr)
605 = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
606 returnUs (Coerce c (instantiateTy tenv ty) new_expr)
610 dup_tyvar :: TyVar -> UniqSM (TyVar, (TyVar, Type))
612 = getUnique `thenUs` \ uniq ->
613 let new_tyvar = cloneTyVar tyvar uniq in
614 returnUs (new_tyvar, (tyvar, mkTyVarTy new_tyvar))
616 -- same thing all over again --------------------
618 dup_binder :: TypeEnv -> Id -> UniqSM (Id, (Id, CoreExpr))
620 = if (toplevelishId b) then
621 -- binder is "top-level-ish"; -- it should *NOT* be renamed
622 -- ToDo: it's unsavoury that we return something to heave in env
623 returnUs (b, (b, Var b))
625 else -- otherwise, the full business
626 getUnique `thenUs` \ uniq ->
628 new_b1 = mkIdWithNewUniq b uniq
629 new_b2 = applyTypeEnvToId tenv new_b1
631 returnUs (new_b2, (b, Var new_b2))