#include "HsVersions.h"
module CoreUtils (
- coreExprType, coreAltsType,
+ coreExprType, coreAltsType, coreExprCc,
- substCoreExpr
+ substCoreExpr, substCoreBindings
, mkCoreIfThenElse
- , mkErrorApp, escErrorMsg
, argToExpr
, unTagBinders, unTagBindersAlts
-{- exprSmallEnoughToDup,
- manifestlyWHNF, manifestlyBottom,
- coreExprArity,
- isWrapperFor,
- maybeErrorApp,
- nonErrorRHSs,
- squashableDictishCcExpr,
--} ) where
+ , maybeErrorApp
+ , nonErrorRHSs
+ , squashableDictishCcExpr
+ ) where
-import Ubiq
-import IdLoop -- for pananoia-checking purposes
+IMP_Ubiq()
import CoreSyn
-import CostCentre ( isDictCC )
-import Id ( idType, mkSysLocal,
+import CostCentre ( isDictCC, CostCentre, noCostCentre )
+import Id ( idType, mkSysLocal, isBottomingId,
+ toplevelishId, mkIdWithNewUniq, applyTypeEnvToId,
+ dataConRepType,
addOneToIdEnv, growIdEnvList, lookupIdEnv,
- isNullIdEnv, IdEnv(..),
- GenId{-instances-}
+ isNullIdEnv, SYN_IE(IdEnv),
+ GenId{-instances-}, SYN_IE(Id)
)
import Literal ( literalType, isNoRepLit, Literal(..) )
-import Maybes ( catMaybes )
-import PprCore ( GenCoreExpr{-instances-}, GenCoreArg{-instances-} )
-import PprStyle ( PprStyle(..) )
-import PprType ( GenType{-instances-}, GenTyVar{-instance-} )
-import Pretty ( ppAboves )
-import PrelInfo ( trueDataCon, falseDataCon,
- augmentId, buildId,
- pAT_ERROR_ID
- )
+import Maybes ( catMaybes, maybeToBool )
+import PprCore
+import Outputable ( PprStyle(..), Outputable(..) )
+import PprType ( GenType{-instances-}, GenTyVar )
+import Pretty ( vcat, text )
import PrimOp ( primOpType, PrimOp(..) )
-import SrcLoc ( mkUnknownSrcLoc )
-import TyVar ( isNullTyVarEnv, TyVarEnv(..), GenTyVar{-instances-} )
-import Type ( mkFunTys, mkForAllTy, mkForAllUsageTy,
- getFunTy_maybe, applyTy, splitSigmaTy
+import SrcLoc ( noSrcLoc )
+import TyVar ( cloneTyVar,
+ isNullTyVarEnv, addOneToTyVarEnv, SYN_IE(TyVarEnv),
+ SYN_IE(TyVar), GenTyVar
+ )
+import Type ( mkFunTy, mkForAllTy, mkForAllUsageTy, mkTyVarTy,
+ getFunTyExpandingDicts_maybe, applyTy, isPrimType,
+ splitSigmaTy, splitFunTy, eqTy, applyTypeEnvToTy,
+ SYN_IE(Type)
)
-import Unique ( Unique{-instances-} )
+import TysWiredIn ( trueDataCon, falseDataCon )
+import Unique ( Unique )
import UniqSupply ( initUs, returnUs, thenUs,
- mapUs, mapAndUnzipUs,
- UniqSM(..), UniqSupply
+ mapUs, mapAndUnzipUs, getUnique,
+ SYN_IE(UniqSM), UniqSupply
)
-import Util ( zipEqual, panic, pprPanic, assertPanic )
+import Usage ( SYN_IE(UVar) )
+import Util ( zipEqual, panic, pprTrace, pprPanic, assertPanic )
+import Pretty
type TypeEnv = TyVarEnv Type
applyUsage = panic "CoreUtils.applyUsage:ToDo"
-dup_binder = panic "CoreUtils.dup_binder"
-applyTypeEnvToTy = panic "CoreUtils.applyTypeEnvToTy"
\end{code}
%************************************************************************
coreExprType (SCC _ expr) = coreExprType expr
coreExprType (Case _ alts) = coreAltsType alts
+coreExprType (Coerce _ ty _) = ty -- that's the whole point!
+
-- a Con is a fully-saturated application of a data constructor
-- a Prim is <ditto> of a PrimOp
-coreExprType (Con con args) = applyTypeToArgs (idType con) args
+coreExprType (Con con args) =
+-- pprTrace "appTyArgs" (hsep [ppr PprDebug con, semi,
+-- ppr PprDebug con_ty, semi,
+-- ppr PprDebug args]) $
+ applyTypeToArgs con_ty args
+ where
+ con_ty = dataConRepType con
+
coreExprType (Prim op args) = applyTypeToArgs (primOpType op) args
coreExprType (Lam (ValBinder binder) expr)
- = mkFunTys [idType binder] (coreExprType expr)
+ = idType binder `mkFunTy` coreExprType expr
coreExprType (Lam (TyBinder tyvar) expr)
= mkForAllTy tyvar (coreExprType expr)
= mkForAllUsageTy uvar (panic "coreExprType:Lam UsageBinder") (coreExprType expr)
coreExprType (App expr (TyArg ty))
- = applyTy (coreExprType expr) ty
+ =
+-- pprTrace "appTy1" (hsep [ppr PprDebug fun_ty, space, ppr PprDebug ty]) $
+ applyTy fun_ty ty
+ where
+ fun_ty = coreExprType expr
coreExprType (App expr (UsageArg use))
= applyUsage (coreExprType expr) use
let
fun_ty = coreExprType expr
in
- case (getFunTy_maybe fun_ty) of
+ case (getFunTyExpandingDicts_maybe False{-no peeking-} fun_ty) of
Just (_, result_ty) -> result_ty
#ifdef DEBUG
Nothing -> pprPanic "coreExprType:\n"
- (ppAboves [ppr PprDebug fun_ty,
+ (vcat [ppr PprDebug fun_ty,
ppr PprShowAll (App expr val_arg)])
#endif
\end{code}
\end{code}
\begin{code}
-applyTypeToArgs = panic "applyTypeToArgs"
+applyTypeToArgs op_ty args = foldl applyTypeToArg op_ty args
+
+applyTypeToArg op_ty (TyArg ty) = applyTy op_ty ty
+applyTypeToArg op_ty (UsageArg _) = panic "applyTypeToArg: UsageArg"
+applyTypeToArg op_ty val_or_lit_arg = case (getFunTyExpandingDicts_maybe False{-no peeking-} op_ty) of
+ Just (_, res_ty) -> res_ty
+\end{code}
+
+coreExprCc gets the cost centre enclosing an expression, if any.
+It looks inside lambdas because (scc "foo" \x.e) = \x.scc "foo" e
+
+\begin{code}
+coreExprCc :: GenCoreExpr val_bdr val_occ tyvar uvar -> CostCentre
+coreExprCc (SCC cc e) = cc
+coreExprCc (Lam _ e) = coreExprCc e
+coreExprCc other = noCostCentre
\end{code}
%************************************************************************
NoDefault )
\end{code}
-\begin{code}
-mkErrorApp :: Type -> Id -> String -> CoreExpr
-
-mkErrorApp ty str_var error_msg
- = Let (NonRec str_var (Lit (NoRepStr (_PK_ error_msg)))) (
- mkApp (Var pAT_ERROR_ID) [] [ty] [VarArg str_var])
-
-escErrorMsg [] = []
-escErrorMsg ('%':xs) = '%' : '%' : escErrorMsg xs
-escErrorMsg (x:xs) = x : escErrorMsg xs
-\end{code}
-
For making @Apps@ and @Lets@, we must take appropriate evasive
action if the thing being bound has unboxed type. @mkCoApp@ requires
-a name supply to do its work. Other-monad code will call @mkCoApp@
-through its own interface function (e.g., the desugarer uses
-@mkCoAppDs@).
+a name supply to do its work.
-@mkCoApp@, @mkCoCon@ and @mkCoPrim@ also handle the
+@mkCoApps@, @mkCoCon@ and @mkCoPrim@ also handle the
arguments-must-be-atoms constraint.
\begin{code}
-{- LATER:
---mkCoApp :: CoreExpr -> CoreExpr -> UniqSM CoreExpr
-
-mkCoApp e1 (Var v) = returnUs (App e1 (VarArg v))
-mkCoApp e1 (Lit l) = returnUs (App e1 (LitArg l))
-mkCoApp e1 e2
- = let
- e2_ty = coreExprType e2
- in
- panic "getUnique" `thenUs` \ uniq ->
- let
- new_var = mkSysLocal SLIT("a") uniq e2_ty mkUnknownSrcLoc
- in
- returnUs (
- mkCoLetUnboxedToCase (NonRec new_var e2)
- (App e1 (VarArg new_var))
- )
--}
-\end{code}
+data CoreArgOrExpr
+ = AnArg CoreArg
+ | AnExpr CoreExpr
-\begin{code}
-{-LATER
-mkCoCon :: Id -> [CoreExpr] -> UniqSM CoreExpr
-mkCoPrim :: PrimOp -> [CoreExpr] -> UniqSM CoreExpr
+mkCoApps :: CoreExpr -> [CoreArgOrExpr] -> UniqSM CoreExpr
+mkCoCon :: Id -> [CoreArgOrExpr] -> UniqSM CoreExpr
+mkCoPrim :: PrimOp -> [CoreArgOrExpr] -> UniqSM CoreExpr
+
+mkCoApps fun args = co_thing (mkGenApp fun) args
+mkCoCon con args = co_thing (Con con) args
+mkCoPrim op args = co_thing (Prim op) args
-mkCoCon con args = mkCoThing (Con con) args
-mkCoPrim op args = mkCoThing (Prim op) args
+co_thing :: ([CoreArg] -> CoreExpr)
+ -> [CoreArgOrExpr]
+ -> UniqSM CoreExpr
-mkCoThing thing arg_exprs
+co_thing thing arg_exprs
= mapAndUnzipUs expr_to_arg arg_exprs `thenUs` \ (args, maybe_binds) ->
returnUs (mkCoLetsUnboxedToCase (catMaybes maybe_binds) (thing args))
where
- expr_to_arg :: CoreExpr
- -> UniqSM (CoreArg, Maybe CoreBinding)
+ expr_to_arg :: CoreArgOrExpr
+ -> UniqSM (CoreArg, Maybe CoreBinding)
- expr_to_arg (Var v) = returnUs (VarArg v, Nothing)
- expr_to_arg (Lit l) = returnUs (LitArg l, Nothing)
- expr_to_arg other_expr
+ expr_to_arg (AnArg arg) = returnUs (arg, Nothing)
+ expr_to_arg (AnExpr (Var v)) = returnUs (VarArg v, Nothing)
+ expr_to_arg (AnExpr (Lit l)) = returnUs (LitArg l, Nothing)
+ expr_to_arg (AnExpr other_expr)
= let
e_ty = coreExprType other_expr
in
- panic "getUnique" `thenUs` \ uniq ->
+ getUnique `thenUs` \ uniq ->
let
- new_var = mkSysLocal SLIT("a") uniq e_ty mkUnknownSrcLoc
- new_atom = VarArg new_var
+ new_var = mkSysLocal SLIT("a") uniq e_ty noSrcLoc
in
- returnUs (new_atom, Just (NonRec new_var other_expr))
--}
+ returnUs (VarArg new_var, Just (NonRec new_var other_expr))
\end{code}
\begin{code}
argToExpr (LitArg lit) = Lit lit
\end{code}
-\begin{code}
-{- LATER:
---mkCoApps ::
--- GenCoreExpr val_bdr val_occ tyvar uvar ->
--- [GenCoreExpr val_bdr val_occ tyvar uvar] ->
--- UniqSM(GenCoreExpr val_bdr val_occ tyvar uvar)
-
-mkCoApps fun [] = returnUs fun
-mkCoApps fun (arg:args)
- = mkCoApp fun arg `thenUs` \ new_fun ->
- mkCoApps new_fun args
-\end{code}
-
-\begin{code}
-exprSmallEnoughToDup :: GenCoreExpr binder Id -> Bool
-
-exprSmallEnoughToDup (Con _ _ _) = True -- Could check # of args
-exprSmallEnoughToDup (Prim op _ _) = not (fragilePrimOp op) -- Could check # of args
-exprSmallEnoughToDup (Lit lit) = not (isNoRepLit lit)
-
-exprSmallEnoughToDup expr -- for now, just: <var> applied to <args>
- = case (collectArgs expr) of { (fun, args) ->
- case fun of
- Var v -> v /= buildId
- && v /= augmentId
- && length args <= 6 -- or 10 or 1 or 4 or anything smallish.
- _ -> False
- }
-\end{code}
-Question (ADR): What is the above used for? Is a _ccall_ really small
-enough?
-
-@manifestlyWHNF@ looks at a Core expression and returns \tr{True} if
-it is obviously in weak head normal form. It isn't a disaster if it
-errs on the conservative side (returning \tr{False})---I've probably
-left something out... [WDP]
-
-\begin{code}
-manifestlyWHNF :: GenCoreExpr bndr Id -> Bool
-
-manifestlyWHNF (Var _) = True
-manifestlyWHNF (Lit _) = True
-manifestlyWHNF (Con _ _ _) = True -- ToDo: anything for Prim?
-manifestlyWHNF (Lam _ _) = True
-manifestlyWHNF (CoTyLam _ e) = manifestlyWHNF e
-manifestlyWHNF (SCC _ e) = manifestlyWHNF e
-manifestlyWHNF (Let _ e) = False
-manifestlyWHNF (Case _ _) = False
-
-manifestlyWHNF other_expr -- look for manifest partial application
- = case (collectArgs other_expr) of { (fun, args) ->
- case fun of
- Var f -> let
- num_val_args = length [ a | (ValArg a) <- args ]
- in
- num_val_args == 0 || -- Just a type application of
- -- a variable (f t1 t2 t3)
- -- counts as WHNF
- case (arityMaybe (getIdArity f)) of
- Nothing -> False
- Just arity -> num_val_args < arity
-
- _ -> False
- }
-\end{code}
-
-@manifestlyBottom@ looks at a Core expression and returns \tr{True} if
-it is obviously bottom, that is, it will certainly return bottom at
-some point. It isn't a disaster if it errs on the conservative side
-(returning \tr{False}).
-
-\begin{code}
-manifestlyBottom :: GenCoreExpr bndr Id -> Bool
-
-manifestlyBottom (Var v) = isBottomingId v
-manifestlyBottom (Lit _) = False
-manifestlyBottom (Con _ _ _) = False
-manifestlyBottom (Prim _ _ _)= False
-manifestlyBottom (Lam _ _) = False -- we do not assume \x.bottom == bottom. should we? ToDo
-manifestlyBottom (CoTyLam _ e) = manifestlyBottom e
-manifestlyBottom (SCC _ e) = manifestlyBottom e
-manifestlyBottom (Let _ e) = manifestlyBottom e
-
-manifestlyBottom (Case e a)
- = manifestlyBottom e
- || (case a of
- AlgAlts alts def -> all mbalg alts && mbdef def
- PrimAlts alts def -> all mbprim alts && mbdef def
- )
- where
- mbalg (_,_,e') = manifestlyBottom e'
-
- mbprim (_,e') = manifestlyBottom e'
-
- mbdef NoDefault = True
- mbdef (BindDefault _ e') = manifestlyBottom e'
-
-manifestlyBottom other_expr -- look for manifest partial application
- = case (collectArgs other_expr) of { (fun, args) ->
- case fun of
- Var f | isBottomingId f -> True -- Application of a function which
- -- always gives bottom; we treat this as
- -- a WHNF, because it certainly doesn't
- -- need to be shared!
- _ -> False
- }
-\end{code}
-
-\begin{code}
-coreExprArity
- :: (Id -> Maybe (GenCoreExpr bndr Id))
- -> GenCoreExpr bndr Id
- -> Int
-coreExprArity f (Lam _ expr) = coreExprArity f expr + 1
-coreExprArity f (CoTyLam _ expr) = coreExprArity f expr
-coreExprArity f (App expr arg) = max (coreExprArity f expr - 1) 0
-coreExprArity f (CoTyApp expr _) = coreExprArity f expr
-coreExprArity f (Var v) = max further info
- where
- further
- = case f v of
- Nothing -> 0
- Just expr -> coreExprArity f expr
- info = case (arityMaybe (getIdArity v)) of
- Nothing -> 0
- Just arity -> arity
-coreExprArity f _ = 0
-\end{code}
-
-@isWrapperFor@: we want to see exactly:
-\begin{verbatim}
-/\ ... \ args -> case <arg> of ... -> case <arg> of ... -> wrkr <stuff>
-\end{verbatim}
-
-Probably a little too HACKY [WDP].
-
-\begin{code}
-isWrapperFor :: CoreExpr -> Id -> Bool
-
-expr `isWrapperFor` var
- = case (digForLambdas expr) of { (_, _, args, body) -> -- lambdas off the front
- unravel_casing args body
- --NO, THANKS: && not (null args)
- }
- where
- var's_worker = getWorkerId (getIdStrictness var)
-
- is_elem = isIn "isWrapperFor"
-
- --------------
- unravel_casing case_ables (Case scrut alts)
- = case (collectArgs scrut) of { (fun, args) ->
- case fun of
- Var scrut_var -> let
- answer =
- scrut_var /= var && all (doesn't_mention var) args
- && scrut_var `is_elem` case_ables
- && unravel_alts case_ables alts
- in
- answer
-
- _ -> False
- }
-
- unravel_casing case_ables other_expr
- = case (collectArgs other_expr) of { (fun, args) ->
- case fun of
- Var wrkr -> let
- answer =
- -- DOESN'T WORK: wrkr == var's_worker
- wrkr /= var
- && isWorkerId wrkr
- && all (doesn't_mention var) args
- && all (only_from case_ables) args
- in
- answer
-
- _ -> False
- }
-
- --------------
- unravel_alts case_ables (AlgAlts [(_,params,rhs)] NoDefault)
- = unravel_casing (params ++ case_ables) rhs
- unravel_alts case_ables other = False
-
- -------------------------
- doesn't_mention var (ValArg (VarArg v)) = v /= var
- doesn't_mention var other = True
-
- -------------------------
- only_from case_ables (ValArg (VarArg v)) = v `is_elem` case_ables
- only_from case_ables other = True
--}
-\end{code}
-
All the following functions operate on binders, perform a uniform
transformation on them; ie. the function @(\ x -> (x,False))@
annotates all binders with False.
bop_expr f (Lam binder expr) = Lam (bop_binder f binder) (bop_expr f expr)
bop_expr f (App expr arg) = App (bop_expr f expr) arg
bop_expr f (SCC label expr) = SCC label (bop_expr f expr)
+bop_expr f (Coerce c ty e) = Coerce c ty (bop_expr f e)
bop_expr f (Let bind expr) = Let (bop_bind f bind) (bop_expr f expr)
bop_expr f (Case expr alts) = Case (bop_expr f expr) (bop_alts f alts)
Notice that the \tr{<alts>} don't get duplicated.
\begin{code}
-{- LATER:
-nonErrorRHSs :: GenCoreCaseAlts binder Id -> [GenCoreExpr binder Id]
+nonErrorRHSs :: GenCoreCaseAlts a Id TyVar UVar -> [GenCoreExpr a Id TyVar UVar]
-nonErrorRHSs alts = filter not_error_app (find_rhss alts)
+nonErrorRHSs alts
+ = filter not_error_app (find_rhss alts)
where
- find_rhss (AlgAlts alts deflt) = [rhs | (_,_,rhs) <- alts] ++ deflt_rhs deflt
- find_rhss (PrimAlts alts deflt) = [rhs | (_,rhs) <- alts] ++ deflt_rhs deflt
+ find_rhss (AlgAlts as deflt) = [rhs | (_,_,rhs) <- as] ++ deflt_rhs deflt
+ find_rhss (PrimAlts as deflt) = [rhs | (_,rhs) <- as] ++ deflt_rhs deflt
deflt_rhs NoDefault = []
deflt_rhs (BindDefault _ rhs) = [rhs]
- not_error_app rhs = case maybeErrorApp rhs Nothing of
- Just _ -> False
- Nothing -> True
+ not_error_app rhs
+ = case (maybeErrorApp rhs Nothing) of
+ Just _ -> False
+ Nothing -> True
\end{code}
-maybeErrorApp checkes whether an expression is of the form
+maybeErrorApp checks whether an expression is of the form
error ty args
===>
error ty' "Foo"
-where ty' is the type of any of the alternatives.
-You might think this never occurs, but see the comments on
-the definition of @singleAlt@.
+where ty' is the type of any of the alternatives. You might think
+this never occurs, but see the comments on the definition of
+@singleAlt@.
-Note: we *avoid* the case where ty' might end up as a
-primitive type: this is very uncool (totally wrong).
+Note: we *avoid* the case where ty' might end up as a primitive type:
+this is very uncool (totally wrong).
-NOTICE: in the example above we threw away e1 and e2, but
-not the string "Foo". How did we know to do that?
+NOTICE: in the example above we threw away e1 and e2, but not the
+string "Foo". How did we know to do that?
-Answer: for now anyway, we only handle the case of a function
-whose type is of form
+Answer: for now anyway, we only handle the case of a function whose
+type is of form
bottomingFn :: forall a. t1 -> ... -> tn -> a
^---------------------^ NB!
-Furthermore, we only count a bottomingApp if the function is
-applied to more than n args. If so, we transform:
+Furthermore, we only count a bottomingApp if the function is applied
+to more than n args. If so, we transform:
bottomingFn ty e1 ... en en+1 ... em
to
That is, we discard en+1 .. em
\begin{code}
-maybeErrorApp :: GenCoreExpr bndr Id -- Expr to look at
- -> Maybe Type -- Just ty => a result type *already cloned*;
- -- Nothing => don't know result ty; we
- -- *pretend* that the result ty won't be
- -- primitive -- somebody later must
- -- ensure this.
- -> Maybe (GenCoreExpr bndr Id)
+maybeErrorApp
+ :: GenCoreExpr a Id TyVar UVar -- Expr to look at
+ -> Maybe Type -- Just ty => a result type *already cloned*;
+ -- Nothing => don't know result ty; we
+ -- *pretend* that the result ty won't be
+ -- primitive -- somebody later must
+ -- ensure this.
+ -> Maybe (GenCoreExpr b Id TyVar UVar)
maybeErrorApp expr result_ty_maybe
- = case collectArgs expr of
- (Var fun, (TypeArg ty : other_args))
+ = case (collectArgs expr) of
+ (Var fun, [{-no usage???-}], [ty], other_args)
| isBottomingId fun
&& maybeToBool result_ty_maybe -- we *know* the result type
-- (otherwise: live a fairy-tale existence...)
&& not (isPrimType result_ty) ->
- case splitSigmaTy (idType fun) of
- ([tyvar_tmpl], [], tau_ty) ->
- case (splitTyArgs tau_ty) of { (arg_tys, res_ty) ->
+
+ case (splitSigmaTy (idType fun)) of
+ ([tyvar], [], tau_ty) ->
+ case (splitFunTy tau_ty) of { (arg_tys, res_ty) ->
let
n_args_to_keep = length arg_tys
args_to_keep = take n_args_to_keep other_args
in
- if res_ty == mkTyVarTemplateTy tyvar_tmpl &&
- n_args_to_keep <= length other_args
+ if (res_ty `eqTy` mkTyVarTy tyvar)
+ && n_args_to_keep <= length other_args
then
-- Phew! We're in business
- Just (mkGenApp (Var fun)
- (TypeArg result_ty : args_to_keep))
+ Just (mkGenApp (Var fun) (TyArg result_ty : args_to_keep))
else
Nothing
}
- other -> -- Function type wrong shape
- Nothing
+ other -> Nothing -- Function type wrong shape
other -> Nothing
where
Just result_ty = result_ty_maybe
\end{code}
\begin{code}
-squashableDictishCcExpr :: CostCentre -> GenCoreExpr a b -> Bool
+squashableDictishCcExpr :: CostCentre -> GenCoreExpr a b c d -> Bool
squashableDictishCcExpr cc expr
= if not (isDictCC cc) then
squashable expr -- note: quite like the "atomic_rhs" stuff in simplifier
where
squashable (Var _) = True
- squashable (CoTyApp f _) = squashable f
- squashable (Con _ _ _) = True -- I think so... WDP 94/09
- squashable (Prim _ _ _) = True -- ditto
- squashable other = False
--}
+ squashable (Con _ _) = True -- I think so... WDP 94/09
+ squashable (Prim _ _) = True -- ditto
+ squashable (App f a)
+ | notValArg a = squashable f
+ squashable other = False
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
+substCoreBindings :: ValEnv
+ -> TypeEnv -- TyVar=>Type
+ -> [CoreBinding]
+ -> UniqSM [CoreBinding]
+
substCoreExpr :: ValEnv
-> TypeEnv -- TyVar=>Type
-> CoreExpr
-> UniqSM CoreExpr
-substCoreExpr venv tenv expr
+substCoreBindings venv tenv binds
-- if the envs are empty, then avoid doing anything
= if (isNullIdEnv venv && isNullTyVarEnv tenv) then
+ returnUs binds
+ else
+ do_CoreBindings venv tenv binds
+
+substCoreExpr venv tenv expr
+ = if (isNullIdEnv venv && isNullTyVarEnv tenv) then
returnUs expr
else
do_CoreExpr venv tenv expr
let new_venv = growIdEnvList venv new_maps in
mapUs (do_CoreExpr new_venv tenv) rhss `thenUs` \ new_rhss ->
- returnUs (Rec (new_binders `zipEqual` new_rhss), new_venv)
+ returnUs (Rec (zipEqual "do_CoreBinding" new_binders new_rhss), new_venv)
where
(binders, rhss) = unzip binds
\end{code}
do_CoreArg :: ValEnv
-> TypeEnv
-> CoreArg
- -> UniqSM CoreExpr
+ -> UniqSM CoreArgOrExpr
-do_CoreArg venv tenv (LitArg lit) = returnUs (Lit lit)
-do_CoreArg venv tenv (TyArg ty) = panic "do_CoreArg: TyArg"
-do_CoreArg venv tenv (UsageArg usage) = panic "do_CoreArg: UsageArg"
-do_CoreArg venv tenv (VarArg v)
+do_CoreArg venv tenv a@(VarArg v)
= returnUs (
case (lookupIdEnv venv v) of
- Nothing -> --false:ASSERT(toplevelishId v)
- Var v
- Just expr -> expr
+ Nothing -> AnArg a
+ Just expr -> AnExpr expr
)
+
+do_CoreArg venv tenv (TyArg ty)
+ = returnUs (AnArg (TyArg (applyTypeEnvToTy tenv ty)))
+
+do_CoreArg venv tenv other_arg = returnUs (AnArg other_arg)
\end{code}
\begin{code}
do_CoreExpr venv tenv e@(Lit _) = returnUs e
do_CoreExpr venv tenv (Con con as)
- = panic "CoreUtils.do_CoreExpr:Con"
-{- LATER:
= mapUs (do_CoreArg venv tenv) as `thenUs` \ new_as ->
mkCoCon con new_as
--}
do_CoreExpr venv tenv (Prim op as)
- = panic "CoreUtils.do_CoreExpr:Prim"
-{- LATER:
= mapUs (do_CoreArg venv tenv) as `thenUs` \ new_as ->
do_PrimOp op `thenUs` \ new_op ->
mkCoPrim new_op new_as
returnUs (CCallOp label is_asm may_gc new_arg_tys new_result_ty)
do_PrimOp other_op = returnUs other_op
--}
-do_CoreExpr venv tenv (Lam binder expr)
+do_CoreExpr venv tenv (Lam (ValBinder binder) expr)
= dup_binder tenv binder `thenUs` \(new_binder, (old,new)) ->
let new_venv = addOneToIdEnv venv old new in
do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
- returnUs (Lam new_binder new_expr)
+ returnUs (Lam (ValBinder new_binder) new_expr)
+
+do_CoreExpr venv tenv (Lam (TyBinder tyvar) expr)
+ = dup_tyvar tyvar `thenUs` \ (new_tyvar, (old, new)) ->
+ let
+ new_tenv = addOneToTyVarEnv tenv old new
+ in
+ do_CoreExpr venv new_tenv expr `thenUs` \ new_expr ->
+ returnUs (Lam (TyBinder new_tyvar) new_expr)
+
+do_CoreExpr venv tenv (Lam _ expr) = panic "CoreUtils.do_CoreExpr:Lam UsageBinder"
do_CoreExpr venv tenv (App expr arg)
- = panic "CoreUtils.do_CoreExpr:App"
-{-
= do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
do_CoreArg venv tenv arg `thenUs` \ new_arg ->
- mkCoApp new_expr new_arg
--}
+ mkCoApps new_expr [new_arg] -- ToDo: more efficiently?
do_CoreExpr venv tenv (Case expr alts)
= do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
do_CoreExpr venv tenv (SCC label expr)
= do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
returnUs (SCC label new_expr)
+
+do_CoreExpr venv tenv (Coerce c ty expr)
+ = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
+ returnUs (Coerce c (applyTypeEnvToTy tenv ty) new_expr)
+\end{code}
+
+\begin{code}
+dup_tyvar :: TyVar -> UniqSM (TyVar, (TyVar, Type))
+dup_tyvar tyvar
+ = getUnique `thenUs` \ uniq ->
+ let new_tyvar = cloneTyVar tyvar uniq in
+ returnUs (new_tyvar, (tyvar, mkTyVarTy new_tyvar))
+
+-- same thing all over again --------------------
+
+dup_binder :: TypeEnv -> Id -> UniqSM (Id, (Id, CoreExpr))
+dup_binder tenv b
+ = if (toplevelishId b) then
+ -- binder is "top-level-ish"; -- it should *NOT* be renamed
+ -- ToDo: it's unsavoury that we return something to heave in env
+ returnUs (b, (b, Var b))
+
+ else -- otherwise, the full business
+ getUnique `thenUs` \ uniq ->
+ let
+ new_b1 = mkIdWithNewUniq b uniq
+ new_b2 = applyTypeEnvToId tenv new_b1
+ in
+ returnUs (new_b2, (b, Var new_b2))
\end{code}
projects / ghc-hetmet.git / blobdiff