X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplCore.lhs;h=9e43be6081cad0ca51d8c6aed23f16c6af2f1fea;hb=967cc47f37cb93a5e2b6df7822c9a646f0428247;hp=1b42cc0a648ac444d7ae776ec5e873b05935d6ae;hpb=e5eeb527319f4082053bc0423b5a92f6bd84dbbb;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index 1b42cc0..9e43be6 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -4,12 +4,9 @@ \section[SimplCore]{Driver for simplifying @Core@ programs} \begin{code} -#include "HsVersions.h" - module SimplCore ( core2core ) where -IMP_Ubiq(){-uitous-} -IMPORT_1_3(IO(hPutStr,stderr)) +#include "HsVersions.h" import AnalFBWW ( analFBWW ) import Bag ( isEmptyBag, foldBag ) @@ -17,6 +14,7 @@ import BinderInfo ( BinderInfo{-instance Outputable-} ) import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..), switchIsOn, opt_D_show_passes, opt_D_simplifier_stats, + opt_D_dump_simpl, opt_D_verbose_core2core, opt_DoCoreLinting, opt_FoldrBuildOn, @@ -29,24 +27,24 @@ import CoreSyn import CoreUtils ( coreExprType ) import SimplUtils ( etaCoreExpr, typeOkForCase ) import CoreUnfold -import Literal ( Literal(..), literalType, mkMachInt ) -import ErrUtils ( ghcExit ) -import FiniteMap ( FiniteMap ) +import Literal ( Literal(..), literalType, mkMachInt, mkMachInt_safe ) +import ErrUtils ( ghcExit, dumpIfSet, doIfSet ) +import FiniteMap ( FiniteMap, emptyFM ) import FloatIn ( floatInwards ) import FloatOut ( floatOutwards ) import FoldrBuildWW ( mkFoldrBuildWW ) -import Id ( mkSysLocal, setIdVisibility, replaceIdInfo, - replacePragmaInfo, getIdDemandInfo, idType, - getIdInfo, getPragmaInfo, mkIdWithNewUniq, +import MkId ( mkSysLocal, mkUserId ) +import Id ( setIdVisibility, getIdSpecialisation, setIdSpecialisation, + getIdDemandInfo, idType, nullIdEnv, addOneToIdEnv, delOneFromIdEnv, - lookupIdEnv, SYN_IE(IdEnv), omitIfaceSigForId, - apply_to_Id, - GenId{-instance Outputable-}, SYN_IE(Id) + lookupIdEnv, IdEnv, + Id ) import IdInfo ( willBeDemanded, DemandInfo ) import Name ( isExported, isLocallyDefined, isLocalName, uniqToOccName, - SYN_IE(Module), NamedThing(..), OccName(..) + setNameVisibility, + Module, NamedThing(..), OccName(..) ) import TyCon ( TyCon ) import PrimOp ( PrimOp(..) ) @@ -54,25 +52,19 @@ import PrelVals ( unpackCStringId, unpackCString2Id, integerZeroId, integerPlusOneId, integerPlusTwoId, integerMinusOneId ) -import Type ( maybeAppDataTyCon, isPrimType, SYN_IE(Type) ) +import Type ( splitAlgTyConApp_maybe, isUnpointedType, Type ) import TysWiredIn ( stringTy, isIntegerTy ) import LiberateCase ( liberateCase ) import MagicUFs ( MagicUnfoldingFun ) -import Outputable ( PprStyle(..), Outputable(..){-instance * (,) -} ) import PprCore -import PprType ( GenType{-instance Outputable-}, GenTyVar{-ditto-}, - nmbrType - ) -import Pretty ( Doc, vcat, ($$), hsep ) +import PprType ( nmbrType ) import SAT ( doStaticArgs ) import SimplMonad ( zeroSimplCount, showSimplCount, SimplCount ) import SimplPgm ( simplifyPgm ) import Specialise -import SpecUtils ( pprSpecErrs ) +import SpecEnv ( substSpecEnv, isEmptySpecEnv ) import StrictAnal ( saWwTopBinds ) -import TyVar ( SYN_IE(TyVar), nullTyVarEnv, GenTyVar{-instance Eq-}, - nameTyVar - ) +import TyVar ( TyVar, nameTyVar, emptyTyVarEnv ) import Unique ( Unique{-instance Eq-}, Uniquable(..), integerTyConKey, ratioTyConKey, mkUnique, incrUnique, @@ -81,76 +73,54 @@ import Unique ( Unique{-instance Eq-}, Uniquable(..), import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply, getUnique ) -import UniqFM ( UniqFM, lookupUFM, addToUFM ) -import Usage ( SYN_IE(UVar), cloneUVar ) -import Util ( mapAccumL, assertPanic, panic{-ToDo:rm-}, pprTrace, pprPanic ) +import UniqFM ( UniqFM, lookupUFM, addToUFM, delFromUFM ) +import Util ( mapAccumL ) import SrcLoc ( noSrcLoc ) import Constants ( tARGET_MIN_INT, tARGET_MAX_INT ) import Bag import Maybes - - -#ifndef OMIT_DEFORESTER -import Deforest ( deforestProgram ) -import DefUtils ( deforestable ) -#endif - +import IO ( hPutStr, stderr ) +import Outputable \end{code} \begin{code} core2core :: [CoreToDo] -- spec of what core-to-core passes to do -> FAST_STRING -- module name (profiling only) - -> PprStyle -- printing style (for debugging only) -> UniqSupply -- a name supply -> [TyCon] -- local data tycons and tycon specialisations - -> FiniteMap TyCon [(Bool, [Maybe Type])] -> [CoreBinding] -- input... - -> IO - ([CoreBinding], -- results: program, plus... - SpecialiseData) -- specialisation data + -> IO [CoreBinding] -- results: program -core2core core_todos module_name ppr_style us local_tycons tycon_specs binds - = -- Print heading - (if opt_D_verbose_core2core then - hPutStr stderr "VERBOSE CORE-TO-CORE:\n" - else return ()) >> - - -- Do the main business +core2core core_todos module_name us local_tycons binds + = -- Do the main business foldl_mn do_core_pass - (binds, us, init_specdata, zeroSimplCount) + (binds, us, zeroSimplCount) core_todos - >>= \ (processed_binds, us', spec_data, simpl_stats) -> + >>= \ (processed_binds, us', simpl_stats) -> -- Do the final tidy-up let - final_binds = core_linter "TidyCorePgm" True $ - tidyCorePgm module_name processed_binds + final_binds = tidyCorePgm module_name processed_binds in + lintCoreBindings "TidyCorePgm" True final_binds >> + + + -- Dump output + dumpIfSet (opt_D_dump_simpl || opt_D_verbose_core2core) + "Core transformations" + (pprCoreBindings final_binds) >> -- Report statistics - (if opt_D_simplifier_stats then - hPutStr stderr ("\nSimplifier Stats:\n") >> - hPutStr stderr (showSimplCount simpl_stats) >> - hPutStr stderr "\n" - else return ()) >> - - -- - return (final_binds, spec_data) - where - init_specdata = initSpecData local_tycons tycon_specs - - ------------- - core_linter what spec_done - = if opt_DoCoreLinting - then (if opt_D_show_passes then - trace ("\n*** Core Lint result of " ++ what) - else id - ) - lintCoreBindings ppr_style what spec_done - else id + doIfSet opt_D_simplifier_stats + (hPutStr stderr ("\nSimplifier Stats:\n") >> + hPutStr stderr (showSimplCount simpl_stats) >> + hPutStr stderr "\n") >> + -- Return results + return final_binds + where -------------- - do_core_pass info@(binds, us, spec_data, simpl_stats) to_do = + do_core_pass info@(binds, us, simpl_stats) to_do = case (splitUniqSupply us) of (us1,us2) -> case to_do of @@ -160,7 +130,7 @@ core2core core_todos module_name ppr_style us local_tycons tycon_specs binds then " (foldr/build)" else "") >> case (simplifyPgm binds simpl_sw_chkr simpl_stats us1) of (p, it_cnt, simpl_stats2) - -> end_pass False us2 p spec_data simpl_stats2 + -> end_pass us2 p simpl_stats2 ("Simplify (" ++ show it_cnt ++ ")" ++ if switchIsOn simpl_sw_chkr SimplDoFoldrBuild then " foldr/build" else "") @@ -169,37 +139,37 @@ core2core core_todos module_name ppr_style us local_tycons tycon_specs binds -> _scc_ "CoreDoFoldrBuildWorkerWrapper" begin_pass "FBWW" >> case (mkFoldrBuildWW us1 binds) of { binds2 -> - end_pass False us2 binds2 spec_data simpl_stats "FBWW" } + end_pass us2 binds2 simpl_stats "FBWW" } CoreDoFoldrBuildWWAnal -> _scc_ "CoreDoFoldrBuildWWAnal" begin_pass "AnalFBWW" >> case (analFBWW binds) of { binds2 -> - end_pass False us2 binds2 spec_data simpl_stats "AnalFBWW" } + end_pass us2 binds2 simpl_stats "AnalFBWW" } CoreLiberateCase -> _scc_ "LiberateCase" begin_pass "LiberateCase" >> case (liberateCase opt_LiberateCaseThreshold binds) of { binds2 -> - end_pass False us2 binds2 spec_data simpl_stats "LiberateCase" } + end_pass us2 binds2 simpl_stats "LiberateCase" } CoreDoFloatInwards -> _scc_ "FloatInwards" begin_pass "FloatIn" >> case (floatInwards binds) of { binds2 -> - end_pass False us2 binds2 spec_data simpl_stats "FloatIn" } + end_pass us2 binds2 simpl_stats "FloatIn" } CoreDoFullLaziness -> _scc_ "CoreFloating" begin_pass "FloatOut" >> case (floatOutwards us1 binds) of { binds2 -> - end_pass False us2 binds2 spec_data simpl_stats "FloatOut" } + end_pass us2 binds2 simpl_stats "FloatOut" } CoreDoStaticArgs -> _scc_ "CoreStaticArgs" begin_pass "StaticArgs" >> case (doStaticArgs binds us1) of { binds2 -> - end_pass False us2 binds2 spec_data simpl_stats "StaticArgs" } + end_pass us2 binds2 simpl_stats "StaticArgs" } -- Binds really should be dependency-analysed for static- -- arg transformation... Not to worry, they probably are. -- (I don't think it *dies* if they aren't [WDP 94/04/15]) @@ -208,76 +178,45 @@ core2core core_todos module_name ppr_style us local_tycons tycon_specs binds -> _scc_ "CoreStranal" begin_pass "StrAnal" >> case (saWwTopBinds us1 binds) of { binds2 -> - end_pass False us2 binds2 spec_data simpl_stats "StrAnal" } + end_pass us2 binds2 simpl_stats "StrAnal" } CoreDoSpecialising -> _scc_ "Specialise" begin_pass "Specialise" >> - case (specProgram us1 binds spec_data) of { - (p, spec_data2@(SpecData _ spec_noerrs _ _ _ - spec_errs spec_warn spec_tyerrs)) -> - - -- if we got errors, we die straight away - (if not spec_noerrs || - (opt_ShowImportSpecs && not (isEmptyBag spec_warn)) then - hPutStr stderr (show - (pprSpecErrs module_name spec_errs spec_warn spec_tyerrs)) - >> hPutStr stderr "\n" - else - return ()) >> - - (if not spec_noerrs then -- Stop here if specialisation errors occured - ghcExit 1 - else - return ()) >> - - end_pass False us2 p spec_data2 simpl_stats "Specialise" + case (specProgram us1 binds) of { p -> + end_pass us2 p simpl_stats "Specialise" } - CoreDoDeforest -#if OMIT_DEFORESTER - -> error "ERROR: CoreDoDeforest: not built into compiler\n" -#else - -> _scc_ "Deforestation" - begin_pass "Deforestation" >> - case (deforestProgram binds us1) of { binds2 -> - end_pass False us2 binds2 spec_data simpl_stats "Deforestation" } -#endif - CoreDoPrintCore -- print result of last pass - -> end_pass True us2 binds spec_data simpl_stats "Print" + -> dumpIfSet (not opt_D_verbose_core2core) "Print Core" + (pprCoreBindings binds) >> + return (binds, us1, simpl_stats) ------------------------------------------------- - begin_pass + begin_pass what = if opt_D_show_passes - then \ what -> hPutStr stderr ("*** Core2Core: "++what++"\n") - else \ what -> return () + then hPutStr stderr ("*** Core2Core: "++what++"\n") + else return () - end_pass print us2 binds2 - spec_data2@(SpecData spec_done _ _ _ _ _ _ _) + end_pass us2 binds2 simpl_stats2 what - = -- report verbosely, if required - (if (opt_D_verbose_core2core && not print) || - (print && not opt_D_verbose_core2core) - then - hPutStr stderr ("\n*** "++what++":\n") - >> - hPutStr stderr (show - (vcat (map (pprCoreBinding ppr_style) binds2))) - >> - hPutStr stderr "\n" - else - return ()) >> - let - linted_binds = core_linter what spec_done binds2 - in + = -- Report verbosely, if required + dumpIfSet opt_D_verbose_core2core what + (pprCoreBindings binds2) >> + + lintCoreBindings what True {- spec_done -} binds2 >> + -- The spec_done flag tells the linter to + -- complain about unboxed let-bindings + -- But we're not specialising unboxed types any more, + -- so its irrelevant. + return - (linted_binds, -- processed binds, possibly run thru CoreLint - us2, -- UniqSupply for the next guy - spec_data2, -- possibly-updated specialisation info - simpl_stats2 -- accumulated simplifier stats - ) + (binds2, -- processed binds, possibly run thru CoreLint + us2, -- UniqSupply for the next guy + simpl_stats2 -- accumulated simplifier stats + ) + -- here so it can be inlined... foldl_mn f z [] = return z @@ -295,11 +234,13 @@ foldl_mn f z (x:xs) = f z x >>= \ zz -> Several tasks are done by @tidyCorePgm@ -1. Eliminate indirections. The point here is to transform - x_local = E - x_exported = x_local - ==> - x_exported = E +---------------- + [March 98] Indirections are now elimianted by the occurrence analyser + -- 1. Eliminate indirections. The point here is to transform + -- x_local = E + -- x_exported = x_local + -- ==> + -- x_exported = E 2. Make certain top-level bindings into Globals. The point is that Global things get externally-visible labels at code generation @@ -346,110 +287,15 @@ Several tasks are done by @tidyCorePgm@ generator makes global labels from the uniques for local thunks etc.] -Eliminate indirections -~~~~~~~~~~~~~~~~~~~~~~ -In @elimIndirections@, we look for things at the top-level of the form... -\begin{verbatim} - x_local = .... - x_exported = x_local -\end{verbatim} -In cases we find like this, we go {\em backwards} and replace -\tr{x_local} with \tr{x_exported}. This save a gratuitous jump -(from \tr{x_exported} to \tr{x_local}), and makes strictness -information propagate better. - -We rely on prior eta reduction to simplify things like -\begin{verbatim} - x_exported = /\ tyvars -> x_local tyvars -==> - x_exported = x_local -\end{verbatim} - -If more than one exported thing is equal to a local thing (i.e., the -local thing really is shared), then we do one only: -\begin{verbatim} - x_local = .... - x_exported1 = x_local - x_exported2 = x_local -==> - x_exported1 = .... - - x_exported2 = x_exported1 -\end{verbatim} - -There's a possibility of leaving unchanged something like this: -\begin{verbatim} - x_local = .... - x_exported1 = x_local Int -\end{verbatim} -By the time we've thrown away the types in STG land this -could be eliminated. But I don't think it's very common -and it's dangerous to do this fiddling in STG land -because we might elminate a binding that's mentioned in the -unfolding for something. - -General Strategy: first collect the info; then make a \tr{Id -> Id} mapping. -Then blast the whole program (LHSs as well as RHSs) with it. - \begin{code} tidyCorePgm :: Module -> [CoreBinding] -> [CoreBinding] tidyCorePgm mod binds_in - = initTM mod indirection_env $ - tidyTopBindings (catMaybes reduced_binds) `thenTM` \ binds -> + = initTM mod nullIdEnv $ + tidyTopBindings binds_in `thenTM` \ binds -> returnTM (bagToList binds) - where - (indirection_env, reduced_binds) = mapAccumL try_bind nullIdEnv binds_in - - try_bind :: IdEnv CoreBinder -> CoreBinding -> (IdEnv CoreBinder, Maybe CoreBinding) - try_bind env_so_far (NonRec exported_binder rhs) - | isExported exported_binder && -- Only if this is exported - maybeToBool maybe_rhs_id && -- and the RHS is a simple Id - - isLocallyDefined rhs_id && -- Only if this one is defined in this - -- module, so that we *can* change its - -- binding to be the exported thing! - - not (isExported rhs_id) && -- Only if this one is not itself exported, - -- since the transformation will nuke it - - not (omitIfaceSigForId rhs_id) && -- Don't do the transformation if rhs_id is - -- something like a constructor, whose - -- definition is implicitly exported and - -- which must not vanish. - -- To illustrate the preceding check consider - -- data T = MkT Int - -- mkT = MkT - -- f x = MkT (x+1) - -- Here, we'll make a local, non-exported, defn for MkT, and without the - -- above condition we'll transform it to: - -- mkT = \x. MkT [x] - -- f = \y. mkT (y+1) - -- This is bad because mkT will get the IdDetails of MkT, and won't - -- be exported. Also the code generator won't make a definition for - -- the MkT constructor. - -- Slightly gruesome, this. - - not (maybeToBool (lookupIdEnv env_so_far rhs_id)) - -- Only if not already substituted for - - = (addOneToIdEnv env_so_far rhs_id (ValBinder new_rhs_id), Nothing) - where - maybe_rhs_id = case etaCoreExpr rhs of - Var rhs_id -> Just rhs_id - other -> Nothing - Just rhs_id = maybe_rhs_id - new_rhs_id = exported_binder `replaceIdInfo` getIdInfo rhs_id - `replacePragmaInfo` getPragmaInfo rhs_id - -- NB: we keep the Pragmas and IdInfo for the old rhs_id! - -- This is important; it might be marked "no-inline" by - -- the occurrence analyser (because it's recursive), and - -- we must not lose that information. - - try_bind env_so_far bind - = (env_so_far, Just bind) \end{code} Top level bindings @@ -501,8 +347,9 @@ tidyCoreExpr (Con con args) returnTM (Con con args') tidyCoreExpr (Prim prim args) - = mapTM tidyCoreArg args `thenTM` \ args' -> - returnTM (Prim prim args') + = tidyPrimOp prim `thenTM` \ prim' -> + mapTM tidyCoreArg args `thenTM` \ args' -> + returnTM (Prim prim' args') tidyCoreExpr (Lam (ValBinder v) body) = newId v $ \ v' -> @@ -514,18 +361,19 @@ tidyCoreExpr (Lam (TyBinder tv) body) tidyCoreExpr body `thenTM` \ body' -> returnTM (Lam (TyBinder tv') body') -tidyCoreExpr (Lam (UsageBinder uv) body) - = newUVar uv $ \ uv' -> - tidyCoreExpr body `thenTM` \ body' -> - returnTM (Lam (UsageBinder uv') body') - -- Try for let-to-case (see notes in Simplify.lhs for why -- some let-to-case stuff is deferred to now). tidyCoreExpr (Let (NonRec bndr rhs) body) | willBeDemanded (getIdDemandInfo bndr) && + not rhs_is_whnf && -- Don't do it if RHS is already in WHNF typeOkForCase (idType bndr) - = ASSERT( not (isPrimType (idType bndr)) ) + = ASSERT( not (isUnpointedType (idType bndr)) ) tidyCoreExpr (Case rhs (AlgAlts [] (BindDefault bndr body))) + where + rhs_is_whnf = case mkFormSummary rhs of + VarForm -> True + ValueForm -> True + other -> False tidyCoreExpr (Let (NonRec bndr rhs) body) = tidyCoreExpr rhs `thenTM` \ rhs' -> @@ -541,14 +389,15 @@ tidyCoreExpr (Let (Rec pairs) body) where (bndrs, rhss) = unzip pairs -tidyCoreExpr (SCC cc body) +tidyCoreExpr (Note (Coerce to_ty from_ty) body) = tidyCoreExprEta body `thenTM` \ body' -> - returnTM (SCC cc body') + tidyTy to_ty `thenTM` \ to_ty' -> + tidyTy from_ty `thenTM` \ from_ty' -> + returnTM (Note (Coerce to_ty' from_ty') body') -tidyCoreExpr (Coerce coercion ty body) +tidyCoreExpr (Note note body) = tidyCoreExprEta body `thenTM` \ body' -> - tidyTy ty `thenTM` \ ty' -> - returnTM (Coerce coercion ty' body') + returnTM (Note note body') -- Wierd case for par, seq, fork etc. See notes above. tidyCoreExpr (Case scrut@(Prim op args) (PrimAlts _ (BindDefault binder rhs))) @@ -561,9 +410,10 @@ tidyCoreExpr (Case scrut@(Prim op args) (PrimAlts _ (BindDefault binder rhs))) -- Eliminate polymorphic case, for which we can't generate code just yet tidyCoreExpr (Case scrut (AlgAlts [] (BindDefault deflt_bndr rhs))) | not (typeOkForCase (idType deflt_bndr)) - = pprTrace "Warning: discarding polymorphic case:" (ppr PprDebug scrut) $ + = pprTrace "Warning: discarding polymorphic case:" (ppr scrut) $ case scrut of - Var v -> extendEnvTM deflt_bndr v (tidyCoreExpr rhs) + Var v -> lookupId v `thenTM` \ v' -> + extendEnvTM deflt_bndr v' (tidyCoreExpr rhs) other -> tidyCoreExpr (Let (NonRec deflt_bndr scrut) rhs) tidyCoreExpr (Case scrut alts) @@ -629,9 +479,17 @@ tidyCoreArg (LitArg lit) tidyCoreArg (TyArg ty) = tidyTy ty `thenTM` \ ty' -> returnTM (TyArg ty') -tidyCoreArg (UsageArg u) = returnTM (UsageArg u) \end{code} +\begin{code} +tidyPrimOp (CCallOp fn casm gc cconv tys ty) + = mapTM tidyTy tys `thenTM` \ tys' -> + tidyTy ty `thenTM` \ ty' -> + returnTM (CCallOp fn casm gc cconv tys' ty') + +tidyPrimOp other_prim_op = returnTM other_prim_op +\end{code} + %************************************************************************ %* * @@ -655,7 +513,7 @@ litToRep (NoRepStr s) then -- Must cater for NULs in literal string mkGenApp (Var unpackCString2Id) [LitArg (MachStr s), - LitArg (mkMachInt (toInteger (_LENGTH_ s)))] + LitArg (mkMachInt_safe (toInteger (_LENGTH_ s)))] else -- No NULs in the string App (Var unpackCStringId) (LitArg (MachStr s)) @@ -678,7 +536,7 @@ litToRep (NoRepInteger i integer_ty) | i > tARGET_MIN_INT && -- Small enough, so start from an Int i < tARGET_MAX_INT - = Prim Int2IntegerOp [LitArg (mkMachInt i)] + = Prim Int2IntegerOp [LitArg (mkMachInt (fromInteger i))] | otherwise -- Big, so start from a string = Prim Addr2IntegerOp [LitArg (MachStr (_PK_ (show i)))] @@ -690,7 +548,7 @@ litToRep (NoRepRational r rational_ty) returnTM (rational_ty, Con ratio_data_con [TyArg integer_ty, num_arg, denom_arg]) where (ratio_data_con, integer_ty) - = case (maybeAppDataTyCon rational_ty) of + = case (splitAlgTyConApp_maybe rational_ty) of Just (tycon, [i_ty], [con]) -> ASSERT(isIntegerTy i_ty && uniqueOf tycon == ratioTyConKey) (con, i_ty) @@ -751,23 +609,49 @@ mapTM f (x:xs) = f x `thenTM` \ r -> \begin{code} -- Need to extend the environment when we munge a binder, so that occurrences --- of the binder will print the correct way (i.e. as a global not a local) +-- of the binder will print the correct way (e.g. as a global not a local) mungeTopBinder :: Id -> (Id -> TopTidyM a) -> TopTidyM a mungeTopBinder id thing_inside mod env us - = case lookupIdEnv env id of - Just (ValBinder global) -> thing_inside global mod env us -- Already bound - - other -> -- Give it a new print-name unless it's an exported thing - -- setNameVisibility also does the local/global thing - let - (id', us') | isExported id = (id, us) - | otherwise - = (setIdVisibility (Just mod) us id, - incrUnique us) + = -- Give it a new print-name unless it's an exported thing + -- setNameVisibility also does the local/global thing + let + (id1, us') | isExported id = (id, us) + | otherwise + = (setIdVisibility (Just mod) us id, + incrUnique us) + + -- Tidy the Id's SpecEnv + spec_env = getIdSpecialisation id + id2 | isEmptySpecEnv spec_env = id1 + | otherwise = setIdSpecialisation id1 (tidySpecEnv env spec_env) + + new_env = addToUFM env id (ValBinder id2) + in + thing_inside id2 mod new_env us' - new_env = addToUFM env id (ValBinder id') - in - thing_inside id' mod new_env us' +tidySpecEnv env spec_env + = substSpecEnv + emptyTyVarEnv -- Top level only + (tidy_spec_rhs env) + spec_env + where + -- tidy_spec_rhs is another horrid little hacked-up function for + -- the RHS of specialisation templates. + -- It assumes there is no type substitution. + -- + -- See also SimplVar.substSpecEnvRhs Urgh + tidy_spec_rhs env (Var v) = case lookupUFM env v of + Just (ValBinder v') -> Var v' + Nothing -> Var v + tidy_spec_rhs env (App f (VarArg v)) = App (tidy_spec_rhs env f) (case lookupUFM env v of + Just (ValBinder v') -> VarArg v' + Nothing -> VarArg v) + tidy_spec_rhs env (App f arg) = App (tidy_spec_rhs env f) arg + tidy_spec_rhs env (Lam b e) = Lam b (tidy_spec_rhs env' e) + where + env' = case b of + ValBinder id -> delFromUFM env id + TyBinder _ -> env mungeTopBinders [] k = k [] mungeTopBinders (b:bs) k = mungeTopBinder b $ \ b' -> @@ -802,8 +686,16 @@ newId id thing_inside mod env (gus, local_uniq, floats) = let -- Give the Id a fresh print-name, *and* rename its type local_uniq' = incrUnique local_uniq - rn_id = setIdVisibility Nothing local_uniq id - id' = apply_to_Id (nmbr_ty env local_uniq') rn_id + name' = setNameVisibility Nothing local_uniq (getName id) + ty' = nmbr_ty env local_uniq' (idType id) + id' = mkUserId name' ty' + -- NB: This throws away the IdInfo of the Id, which we + -- no longer need. That means we don't need to + -- run over it with env, nor renumber it + -- + -- NB: the Id's unique remains unchanged; it's only + -- its print name that is affected by local_uniq + env' = addToUFM env id (ValBinder id') in thing_inside id' mod env' (gus, local_uniq', floats) @@ -823,14 +715,6 @@ newTyVar tyvar thing_inside mod env (gus, local_uniq, floats) env' = addToUFM env tyvar (TyBinder tyvar') in thing_inside tyvar' mod env' (gus, local_uniq', floats) - -newUVar uvar thing_inside mod env (gus, local_uniq, floats) - = let - local_uniq' = incrUnique local_uniq - uvar' = cloneUVar uvar local_uniq - env' = addToUFM env uvar (UsageBinder uvar') - in - thing_inside uvar' mod env' (gus, local_uniq', floats) \end{code} Re-numbering types @@ -843,17 +727,12 @@ tidyTy ty mod env usf@(_, local_uniq, _) -- This little impedance-matcher calls nmbrType with the right arguments nmbr_ty env uniq ty - = nmbrType tv_env u_env uniq ty + = nmbrType tv_env uniq ty where tv_env :: TyVar -> TyVar tv_env tyvar = case lookupUFM env tyvar of Just (TyBinder tyvar') -> tyvar' other -> tyvar - - u_env :: UVar -> UVar - u_env uvar = case lookupUFM env uvar of - Just (UsageBinder uvar') -> uvar' - other -> uvar \end{code}