X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreUtils.lhs;h=62d57cf4a5896cada0b396d6f614118a3a8e4cc6;hb=9dfbc2dadf268996963feeb8667eb2d0b0f30634;hp=174f5053a8ee3188111b6884e64c4db210c91d34;hpb=c49d51f812da9b1c2ceca7e0dad8f2a3626041a9;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index 174f505..62d57cf 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -4,65 +4,57 @@ \section[CoreUtils]{Utility functions on @Core@ syntax} \begin{code} -#include "HsVersions.h" - module CoreUtils ( - coreExprType, coreAltsType, - - substCoreExpr, substCoreBindings + coreExprType, coreAltsType, coreExprCc, + + mkCoreIfThenElse, + argToExpr, + unTagBinders, unTagBindersAlts, + + maybeErrorApp, + nonErrorRHSs, + squashableDictishCcExpr, + idSpecVars + ) where - , mkCoreIfThenElse - , escErrorMsg -- ToDo: kill - , argToExpr - , unTagBinders, unTagBindersAlts - , manifestlyWHNF, manifestlyBottom - , maybeErrorApp - , nonErrorRHSs - , squashableDictishCcExpr -{- exprSmallEnoughToDup, - coreExprArity, - isWrapperFor, - --} ) where - -import Ubiq -import IdLoop -- for pananoia-checking purposes +#include "HsVersions.h" import CoreSyn -import CostCentre ( isDictCC ) -import Id ( idType, mkSysLocal, getIdArity, isBottomingId, +import CostCentre ( isDictCC, CostCentre, noCostCentre ) +import MkId ( mkSysLocal ) +import Id ( idType, isBottomingId, getIdSpecialisation, + mkIdWithNewUniq, + dataConRepType, addOneToIdEnv, growIdEnvList, lookupIdEnv, - isNullIdEnv, IdEnv(..), - GenId{-instances-} + isNullIdEnv, IdEnv, Id ) -import IdInfo ( arityMaybe ) -import Literal ( literalType, isNoRepLit, Literal(..) ) +import Literal ( literalType, Literal(..) ) import Maybes ( catMaybes, maybeToBool ) -import PprCore ( GenCoreExpr{-instances-}, GenCoreArg{-instances-} ) -import PprStyle ( PprStyle(..) ) -import PprType ( GenType{-instances-} ) -import Pretty ( ppAboves ) -import PrelInfo ( trueDataCon, falseDataCon, - augmentId, buildId - ) +import PprCore import PrimOp ( primOpType, PrimOp(..) ) -import SrcLoc ( mkUnknownSrcLoc ) -import TyVar ( isNullTyVarEnv, TyVarEnv(..) ) -import Type ( mkFunTys, mkForAllTy, mkForAllUsageTy, mkTyVarTy, - getFunTy_maybe, applyTy, isPrimType, - splitSigmaTy, splitFunTy, eqTy, applyTypeEnvToTy +import SpecEnv ( specEnvValues ) +import SrcLoc ( noSrcLoc ) +import TyVar ( cloneTyVar, + isEmptyTyVarEnv, addToTyVarEnv, TyVarEnv, + TyVar, GenTyVar + ) +import Type ( mkFunTy, mkForAllTy, mkTyVarTy, + splitFunTy_maybe, applyTys, isUnpointedType, + splitSigmaTy, splitFunTys, instantiateTy, + Type ) -import UniqSupply ( initUs, returnUs, thenUs, +import TysWiredIn ( trueDataCon, falseDataCon ) +import Unique ( Unique ) +import BasicTypes ( Unused ) +import UniqSupply ( returnUs, thenUs, mapUs, mapAndUnzipUs, getUnique, - UniqSM(..), UniqSupply + UniqSM, UniqSupply ) -import Usage ( UVar(..) ) -import Util ( zipEqual, panic, pprPanic, assertPanic ) +import Util ( zipEqual ) +import Outputable type TypeEnv = TyVarEnv Type -applyUsage = panic "CoreUtils.applyUsage:ToDo" -dup_binder = panic "CoreUtils.dup_binder" \end{code} %************************************************************************ @@ -78,41 +70,47 @@ coreExprType (Var var) = idType var coreExprType (Lit lit) = literalType lit coreExprType (Let _ body) = coreExprType body -coreExprType (SCC _ expr) = coreExprType expr coreExprType (Case _ alts) = coreAltsType alts +coreExprType (Note (Coerce ty _) e) = ty +coreExprType (Note other_note e) = coreExprType e + -- a Con is a fully-saturated application of a data constructor -- a Prim is of a PrimOp -coreExprType (Con con args) = applyTypeToArgs (idType con) args +coreExprType (Con con args) = +-- pprTrace "appTyArgs" (hsep [ppr con, semi, +-- ppr con_ty, semi, +-- ppr 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) -coreExprType (Lam (UsageBinder uvar) expr) - = mkForAllUsageTy uvar (panic "coreExprType:Lam UsageBinder") (coreExprType expr) - coreExprType (App expr (TyArg ty)) - = applyTy (coreExprType expr) ty - -coreExprType (App expr (UsageArg use)) - = applyUsage (coreExprType expr) use + = -- Gather type args; more efficient to instantiate the type all at once + go expr [ty] + where + go (App expr (TyArg ty)) tys = go expr (ty:tys) + go expr tys = applyTys (coreExprType expr) tys coreExprType (App expr val_arg) = ASSERT(isValArg val_arg) let fun_ty = coreExprType expr in - case (getFunTy_maybe fun_ty) of + case (splitFunTy_maybe fun_ty) of Just (_, result_ty) -> result_ty #ifdef DEBUG Nothing -> pprPanic "coreExprType:\n" - (ppAboves [ppr PprDebug fun_ty, - ppr PprShowAll (App expr val_arg)]) + (vcat [ppr fun_ty, ppr (App expr val_arg)]) #endif \end{code} @@ -130,7 +128,30 @@ default_ty (BindDefault _ rhs) = coreExprType rhs \end{code} \begin{code} -applyTypeToArgs = panic "applyTypeToArgs" +applyTypeToArgs op_ty (TyArg ty : args) + = -- Accumulate type arguments so we can instantiate all at once + applyTypeToArgs (applyTys op_ty tys) rest_args + where + (tys, rest_args) = go [ty] args + go tys (TyArg ty : args) = go (ty:tys) args + go tys rest_args = (reverse tys, rest_args) + +applyTypeToArgs op_ty (val_or_lit_arg:args) + = case (splitFunTy_maybe op_ty) of + Just (_, res_ty) -> applyTypeToArgs res_ty args + +applyTypeToArgs op_ty [] = op_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 flexi -> CostCentre +coreExprCc (Note (SCC cc) e) = cc +coreExprCc (Note other_note e) = coreExprCc e +coreExprCc (Lam _ e) = coreExprCc e +coreExprCc other = noCostCentre \end{code} %************************************************************************ @@ -151,23 +172,6 @@ mkCoreIfThenElse guard then_expr else_expr NoDefault ) \end{code} -\begin{code} -{- OLD: -mkErrorApp :: Id -> Type -> Id -> String -> CoreExpr - -mkErrorApp err_fun ty str_var error_msg - = Let (NonRec str_var (Lit (NoRepStr (_PK_ error_msg)))) ( - mkApp (Var err_fun) [] [ty] [VarArg str_var]) --} - -escErrorMsg = panic "CoreUtils.escErrorMsg: To Die" -{- OLD: -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. @@ -208,220 +212,33 @@ co_thing thing arg_exprs in getUnique `thenUs` \ uniq -> let - new_var = mkSysLocal SLIT("a") uniq e_ty mkUnknownSrcLoc + new_var = mkSysLocal SLIT("a") uniq e_ty noSrcLoc in returnUs (VarArg new_var, Just (NonRec new_var other_expr)) \end{code} \begin{code} argToExpr :: - GenCoreArg val_occ tyvar uvar -> GenCoreExpr val_bdr val_occ tyvar uvar + GenCoreArg val_occ flexi -> GenCoreExpr val_bdr val_occ flexi argToExpr (VarArg v) = Var v argToExpr (LitArg lit) = Lit lit \end{code} -\begin{code} -{- LATER: -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: applied to - = case (collectArgs expr) of { (fun, _, _, vargs) -> - case fun of - Var v -> v /= buildId - && v /= augmentId - && length vargs <= 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 tyvar uvar -> Bool - -manifestlyWHNF (Var _) = True -manifestlyWHNF (Lit _) = True -manifestlyWHNF (Con _ _) = True -manifestlyWHNF (SCC _ e) = manifestlyWHNF e -manifestlyWHNF (Let _ e) = False -manifestlyWHNF (Case _ _) = False - -manifestlyWHNF (Lam x e) = if isValBinder x then True else manifestlyWHNF e - -manifestlyWHNF other_expr -- look for manifest partial application - = case (collectArgs other_expr) of { (fun, _, _, vargs) -> - case fun of - Var f -> let - num_val_args = length vargs - 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 tyvar uvar -> Bool - -manifestlyBottom (Var v) = isBottomingId v -manifestlyBottom (Lit _) = False -manifestlyBottom (Con _ _) = False -manifestlyBottom (Prim _ _) = False -manifestlyBottom (SCC _ e) = manifestlyBottom e -manifestlyBottom (Let _ e) = manifestlyBottom e - - -- We do not assume \x.bottom == bottom: -manifestlyBottom (Lam x e) = if isValBinder x then False else 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, _, _, _) -> - 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} -{-LATER: -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 of ... -> case of ... -> wrkr -\end{verbatim} - -Probably a little too HACKY [WDP]. - -\begin{code} -isWrapperFor :: CoreExpr -> Id -> Bool - -expr `isWrapperFor` var - = case (collectBinders 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, _, _, vargs) -> - case fun of - Var scrut_var -> let - answer = - scrut_var /= var && all (doesn't_mention var) vargs - && 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, _, _, vargs) -> - case fun of - Var wrkr -> let - answer = - -- DOESN'T WORK: wrkr == var's_worker - wrkr /= var - && isWorkerId wrkr - && all (doesn't_mention var) vargs - && all (only_from case_ables) vargs - 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. \begin{code} -unTagBinders :: GenCoreExpr (Id,tag) bdee tv uv -> GenCoreExpr Id bdee tv uv +unTagBinders :: GenCoreExpr (Id,tag) bdee flexi -> GenCoreExpr Id bdee flexi unTagBinders expr = bop_expr fst expr -unTagBindersAlts :: GenCoreCaseAlts (Id,tag) bdee tv uv -> GenCoreCaseAlts Id bdee tv uv +unTagBindersAlts :: GenCoreCaseAlts (Id,tag) bdee flexi -> GenCoreCaseAlts Id bdee flexi unTagBindersAlts alts = bop_alts fst alts \end{code} \begin{code} -bop_expr :: (a -> b) -> GenCoreExpr a bdee tv uv -> GenCoreExpr b bdee tv uv +bop_expr :: (a -> b) -> GenCoreExpr a bdee flexi -> GenCoreExpr b bdee flexi bop_expr f (Var b) = Var b bop_expr f (Lit lit) = Lit lit @@ -429,13 +246,12 @@ bop_expr f (Con con args) = Con con args bop_expr f (Prim op args) = Prim op args 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 (Note note expr) = Note note (bop_expr f expr) 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) bop_binder f (ValBinder v) = ValBinder (f v) bop_binder f (TyBinder t) = TyBinder t -bop_binder f (UsageBinder u) = UsageBinder u bop_bind f (NonRec b e) = NonRec (f b) (bop_expr f e) bop_bind f (Rec pairs) = Rec [(f b, bop_expr f e) | (b, e) <- pairs] @@ -483,7 +299,7 @@ Example: Notice that the \tr{} don't get duplicated. \begin{code} -nonErrorRHSs :: GenCoreCaseAlts a Id TyVar UVar -> [GenCoreExpr a Id TyVar UVar] +nonErrorRHSs :: GenCoreCaseAlts a Id Unused -> [GenCoreExpr a Id Unused] nonErrorRHSs alts = filter not_error_app (find_rhss alts) @@ -543,30 +359,30 @@ That is, we discard en+1 .. em \begin{code} maybeErrorApp - :: GenCoreExpr a Id TyVar UVar -- Expr to look at + :: GenCoreExpr a Id Unused -- 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 a Id TyVar UVar) + -> Maybe (GenCoreExpr b Id Unused) maybeErrorApp expr result_ty_maybe = case (collectArgs expr) of - (Var fun, [{-no usage???-}], [ty], other_args) + (Var fun, [ty], other_args) | isBottomingId fun && maybeToBool result_ty_maybe -- we *know* the result type -- (otherwise: live a fairy-tale existence...) - && not (isPrimType result_ty) -> + && not (isUnpointedType result_ty) -> case (splitSigmaTy (idType fun)) of ([tyvar], [], tau_ty) -> - case (splitFunTy tau_ty) of { (arg_tys, res_ty) -> + case (splitFunTys 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 `eqTy` mkTyVarTy tyvar) + if (res_ty == mkTyVarTy tyvar) && n_args_to_keep <= length other_args then -- Phew! We're in business @@ -582,7 +398,7 @@ maybeErrorApp expr result_ty_maybe \end{code} \begin{code} -squashableDictishCcExpr :: CostCentre -> GenCoreExpr a b c d -> Bool +squashableDictishCcExpr :: CostCentre -> GenCoreExpr a b c -> Bool squashableDictishCcExpr cc expr = if not (isDictCC cc) then @@ -598,191 +414,21 @@ squashableDictishCcExpr cc expr squashable other = False \end{code} -%************************************************************************ -%* * -\subsection{Core-renaming utils} -%* * -%************************************************************************ - -\begin{code} -substCoreBindings :: ValEnv - -> TypeEnv -- TyVar=>Type - -> [CoreBinding] - -> UniqSM [CoreBinding] - -substCoreExpr :: ValEnv - -> TypeEnv -- TyVar=>Type - -> CoreExpr - -> UniqSM CoreExpr - -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 -\end{code} - -The equiv code for @Types@ is in @TyUtils@. - -Because binders aren't necessarily unique: we don't do @plusEnvs@ -(which check for duplicates); rather, we use the shadowing version, -@growIdEnv@ (and shorthand @addOneToIdEnv@). - -@do_CoreBindings@ takes into account the semantics of a list of -@CoreBindings@---things defined early in the list are visible later in -the list, but not vice versa. - -\begin{code} -type ValEnv = IdEnv CoreExpr - -do_CoreBindings :: ValEnv - -> TypeEnv - -> [CoreBinding] - -> UniqSM [CoreBinding] - -do_CoreBinding :: ValEnv - -> TypeEnv - -> CoreBinding - -> UniqSM (CoreBinding, ValEnv) - -do_CoreBindings venv tenv [] = returnUs [] -do_CoreBindings venv tenv (b:bs) - = do_CoreBinding venv tenv b `thenUs` \ (new_b, new_venv) -> - do_CoreBindings new_venv tenv bs `thenUs` \ new_bs -> - returnUs (new_b : new_bs) - -do_CoreBinding venv tenv (NonRec binder rhs) - = do_CoreExpr venv tenv rhs `thenUs` \ new_rhs -> - - dup_binder tenv binder `thenUs` \ (new_binder, (old, new)) -> - -- now plug new bindings into envs - let new_venv = addOneToIdEnv venv old new in - - returnUs (NonRec new_binder new_rhs, new_venv) - -do_CoreBinding venv tenv (Rec binds) - = -- for letrec, we plug in new bindings BEFORE cloning rhss - mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (new_binders, new_maps) -> - 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) - where - (binders, rhss) = unzip binds -\end{code} -\begin{code} -do_CoreArg :: ValEnv - -> TypeEnv - -> CoreArg - -> UniqSM CoreArgOrExpr - -do_CoreArg venv tenv a@(VarArg v) - = returnUs ( - case (lookupIdEnv venv v) of - 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} +Given an Id, idSpecVars returns all its specialisations. +We extract these from its SpecEnv. +This is used by the occurrence analyser and free-var finder; +we regard an Id's specialisations as free in the Id's definition. \begin{code} -do_CoreExpr :: ValEnv - -> TypeEnv - -> CoreExpr - -> UniqSM CoreExpr - -do_CoreExpr venv tenv orig_expr@(Var var) - = returnUs ( - case (lookupIdEnv venv var) of - Nothing -> --false:ASSERT(toplevelishId var) (SIGH) - orig_expr - Just expr -> expr - ) - -do_CoreExpr venv tenv e@(Lit _) = returnUs e - -do_CoreExpr venv tenv (Con con as) - = mapUs (do_CoreArg venv tenv) as `thenUs` \ new_as -> - mkCoCon con new_as - -do_CoreExpr venv tenv (Prim op as) - = mapUs (do_CoreArg venv tenv) as `thenUs` \ new_as -> - do_PrimOp op `thenUs` \ new_op -> - mkCoPrim new_op new_as - where - do_PrimOp (CCallOp label is_asm may_gc arg_tys result_ty) - = let - new_arg_tys = map (applyTypeEnvToTy tenv) arg_tys - new_result_ty = applyTypeEnvToTy tenv result_ty - in - 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) - = 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) - -do_CoreExpr venv tenv (App expr arg) - = do_CoreExpr venv tenv expr `thenUs` \ new_expr -> - do_CoreArg venv tenv arg `thenUs` \ 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_alts venv tenv alts `thenUs` \ new_alts -> - returnUs (Case new_expr new_alts) +idSpecVars :: Id -> [Id] +idSpecVars id + = map get_spec (specEnvValues (getIdSpecialisation id)) where - do_alts venv tenv (AlgAlts alts deflt) - = mapUs (do_boxed_alt venv tenv) alts `thenUs` \ new_alts -> - do_default venv tenv deflt `thenUs` \ new_deflt -> - returnUs (AlgAlts new_alts new_deflt) - where - do_boxed_alt venv tenv (con, binders, expr) - = mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (new_binders, new_vmaps) -> - let new_venv = growIdEnvList venv new_vmaps in - do_CoreExpr new_venv tenv expr `thenUs` \ new_expr -> - returnUs (con, new_binders, new_expr) - - - do_alts venv tenv (PrimAlts alts deflt) - = mapUs (do_unboxed_alt venv tenv) alts `thenUs` \ new_alts -> - do_default venv tenv deflt `thenUs` \ new_deflt -> - returnUs (PrimAlts new_alts new_deflt) - where - do_unboxed_alt venv tenv (lit, expr) - = do_CoreExpr venv tenv expr `thenUs` \ new_expr -> - returnUs (lit, new_expr) - - do_default venv tenv NoDefault = returnUs NoDefault - - do_default venv tenv (BindDefault 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 (BindDefault new_binder new_expr) - -do_CoreExpr venv tenv (Let core_bind expr) - = do_CoreBinding venv tenv core_bind `thenUs` \ (new_bind, new_venv) -> - -- and do the body of the let - do_CoreExpr new_venv tenv expr `thenUs` \ new_expr -> - returnUs (Let new_bind new_expr) - -do_CoreExpr venv tenv (SCC label expr) - = do_CoreExpr venv tenv expr `thenUs` \ new_expr -> - returnUs (SCC label new_expr) + -- get_spec is another cheapo function like dictRhsFVs + -- It knows what these specialisation temlates look like, + -- and just goes for the jugular + get_spec (App f _) = get_spec f + get_spec (Lam _ b) = get_spec b + get_spec (Var v) = v \end{code}