From b9f37aee698c6ccf1ee183906836f8185aa6c2e2 Mon Sep 17 00:00:00 2001 From: simonpj Date: Fri, 6 Mar 1998 17:40:31 +0000 Subject: [PATCH] [project @ 1998-03-06 17:40:11 by simonpj] New specialiser --- ghc/compiler/main/Main.lhs | 5 +- ghc/compiler/simplCore/SimplCore.lhs | 51 +- ghc/compiler/specialise/Specialise.lhs | 2354 ++++---------------------------- ghc/compiler/stranal/WwLib.lhs | 6 +- ghc/compiler/typecheck/TcExpr.lhs | 22 +- ghc/compiler/utils/Bag.lhs | 12 +- ghc/compiler/utils/FiniteMap.lhs | 3 +- 7 files changed, 348 insertions(+), 2105 deletions(-) diff --git a/ghc/compiler/main/Main.lhs b/ghc/compiler/main/Main.lhs index 01c5a55..4b00f07 100644 --- a/ghc/compiler/main/Main.lhs +++ b/ghc/compiler/main/Main.lhs @@ -39,7 +39,6 @@ import Bag ( emptyBag, isEmptyBag ) import CmdLineOpts import ErrUtils ( pprBagOfErrors, ghcExit, doIfSet, dumpIfSet ) import Maybes ( maybeToBool, MaybeErr(..) ) -import Specialise ( SpecialiseData(..) ) import StgSyn ( GenStgBinding ) import TcInstUtil ( InstInfo ) import TyCon ( isDataTyCon ) @@ -148,9 +147,7 @@ doIt (core_cmds, stg_cmds) core2core core_cmds mod_name sm_uniqs local_data_tycons desugared >>= - \ (simplified, spec_data - {- SpecData _ _ _ gen_data_tycons all_tycon_specs _ _ _ -} - ) -> + \ simplified -> -- ******* STG-TO-STG SIMPLIFICATION diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index 09f3e67..fde905d 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -91,16 +91,14 @@ core2core :: [CoreToDo] -- spec of what core-to-core passes to do -> UniqSupply -- a name supply -> [TyCon] -- local data tycons and tycon specialisations -> [CoreBinding] -- input... - -> IO - ([CoreBinding], -- results: program, plus... - SpecialiseData) -- specialisation data + -> IO [CoreBinding] -- results: program 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 @@ -121,12 +119,10 @@ core2core core_todos module_name us local_tycons binds hPutStr stderr "\n") >> -- Return results - return (final_binds, spec_data) + return final_binds where - init_specdata = initSpecData local_tycons emptyFM {- tycon_specs -} - -------------- - 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 @@ -136,7 +132,7 @@ core2core core_todos module_name us local_tycons binds then " (foldr/build)" else "") >> case (simplifyPgm binds simpl_sw_chkr simpl_stats us1) of (p, it_cnt, simpl_stats2) - -> end_pass 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 "") @@ -145,37 +141,37 @@ core2core core_todos module_name us local_tycons binds -> _scc_ "CoreDoFoldrBuildWorkerWrapper" begin_pass "FBWW" >> case (mkFoldrBuildWW us1 binds) of { binds2 -> - end_pass 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 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 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 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 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 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]) @@ -184,32 +180,19 @@ core2core core_todos module_name us local_tycons binds -> _scc_ "CoreStranal" begin_pass "StrAnal" >> case (saWwTopBinds us1 binds) of { binds2 -> - end_pass 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 - doIfSet ((not spec_noerrs) || - (opt_ShowImportSpecs && not (isEmptyBag spec_warn))) - (printErrs - (pprSpecErrs module_name spec_errs spec_warn spec_tyerrs)) - >> - - doIfSet (not spec_noerrs) -- Stop here if specialisation errors occured - (ghcExit 1) >> - - end_pass us2 p spec_data2 simpl_stats "Specialise" + case (specProgram us1 binds) of { p -> + end_pass us2 p simpl_stats "Specialise" } CoreDoPrintCore -- print result of last pass -> dumpIfSet (not opt_D_verbose_core2core) "Print Core" (pprCoreBindings binds) >> - return (binds, us1, spec_data, simpl_stats) + return (binds, us1, simpl_stats) ------------------------------------------------- @@ -219,7 +202,6 @@ core2core core_todos module_name us local_tycons binds else return () end_pass us2 binds2 - spec_data2@(SpecData spec_done _ _ _ _ _ _ _) simpl_stats2 what = -- Report verbosely, if required dumpIfSet opt_D_verbose_core2core what @@ -234,7 +216,6 @@ core2core core_todos module_name us local_tycons binds return (binds2, -- processed binds, possibly run thru CoreLint us2, -- UniqSupply for the next guy - spec_data2, -- possibly-updated specialisation info simpl_stats2 -- accumulated simplifier stats ) diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs index 3a63e2e..76e3c3e 100644 --- a/ghc/compiler/specialise/Specialise.lhs +++ b/ghc/compiler/specialise/Specialise.lhs @@ -5,90 +5,48 @@ \begin{code} module Specialise ( - specProgram, - initSpecData, - - SpecialiseData(..) + specProgram ) where #include "HsVersions.h" -import Bag ( emptyBag, unitBag, isEmptyBag, unionBags, - partitionBag, listToBag, bagToList, Bag - ) -import Class ( Class ) -import CmdLineOpts ( opt_SpecialiseImports, opt_D_simplifier_stats, - opt_SpecialiseTrace - ) -import CoreLift ( mkLiftedId, liftExpr, bindUnlift, applyBindUnlifts ) -import CoreSyn -import CoreUtils ( coreExprType, squashableDictishCcExpr ) -import FiniteMap ( addListToFM_C, FiniteMap ) -import Kind ( mkBoxedTypeKind, isBoxedTypeKind ) -import Id ( idType, isDefaultMethodId_maybe, toplevelishId, - isBottomingId, - isDataCon, - isImportedId, mkIdWithNewUniq, - dataConTyCon, applyTypeEnvToId, - nullIdEnv, addOneToIdEnv, growIdEnvList, - lookupIdEnv, IdEnv, - emptyIdSet, mkIdSet, unitIdSet, - elementOfIdSet, minusIdSet, - unionIdSets, unionManyIdSets, IdSet, - GenId{-instance Eq-}, Id - ) -import Literal ( Literal{-instance Outputable-} ) -import Maybes ( catMaybes, firstJust, maybeToBool ) -import Name ( isLocallyDefined ) -import PprType ( pprGenType, pprParendGenType, pprMaybeTy, - GenType{-instance Outputable-}, GenTyVar{-ditto-}, - TyCon{-ditto-} +import Id ( Id, DictVar, idType, mkUserLocal, + + getIdSpecialisation, addIdSpecialisation, isSpecPragmaId, + + IdSet, mkIdSet, addOneToIdSet, intersectIdSets, isEmptyIdSet, + emptyIdSet, unionIdSets, minusIdSet, unitIdSet, elementOfIdSet, + + IdEnv, mkIdEnv, lookupIdEnv, addOneToIdEnv ) -import PrimOp ( PrimOp(..) ) -import SpecUtils -import Type ( mkTyVarTy, mkTyVarTys, isTyVarTy, splitAlgTyConApp, - tyVarsOfTypes, instantiateTy, isUnboxedType, isDictTy, - Type + +import Type ( Type, mkTyVarTy, splitSigmaTy, instantiateTy, isDictTy, + tyVarsOfType, tyVarsOfTypes, applyTys, mkForAllTys ) -import TyCon ( TyCon{-instance Eq-} ) -import TyVar ( cloneTyVar, mkSysTyVar, - elementOfTyVarSet, TyVarSet, - emptyTyVarEnv, growTyVarEnvList, TyVarEnv, - GenTyVar{-instance Eq-} +import TyCon ( TyCon ) +import TyVar ( TyVar, + TyVarSet, mkTyVarSet, isEmptyTyVarSet, intersectTyVarSets, + elementOfTyVarSet, unionTyVarSets, emptyTyVarSet, + TyVarEnv, mkTyVarEnv ) -import TysWiredIn ( liftDataCon ) -import Unique ( Unique{-instance Eq-} ) -import UniqSet ( mkUniqSet, unionUniqSets, uniqSetToList ) -import UniqSupply ( splitUniqSupply, getUniques, getUnique ) -import Util ( equivClasses, mapAccumL, assoc, zipEqual, zipWithEqual, - thenCmp +import CoreSyn +import OccurAnal ( occurAnalyseGlobalExpr ) +import Name ( NamedThing(..), getSrcLoc ) +import SpecEnv ( addToSpecEnv ) + +import UniqSupply ( UniqSupply, + UniqSM, initUs, thenUs, returnUs, getUnique, mapUs ) + +import FiniteMap +import Maybes ( MaybeErr(..) ) +import Bag import List ( partition ) +import Util ( zipEqual ) import Outputable -infixr 9 `thenSM` -specProgram = panic "SpecProgram" - ---ToDo:kill -data SpecInfo = SpecInfo [Maybe Type] Int Id - - -{- -lookupSpecEnv = panic "Specialise.lookupSpecEnv (ToDo)" -addIdSpecialisation = panic "Specialise.addIdSpecialisation (ToDo)" -cmpUniTypeMaybeList = panic "Specialise.cmpUniTypeMaybeList (ToDo)" -getIdSpecialisation = panic "Specialise.getIdSpecialisation (ToDo)" -isClassOpId = panic "Specialise.isClassOpId (ToDo)" -isLocalGenTyCon = panic "Specialise.isLocalGenTyCon (ToDo)" -isLocalSpecTyCon = panic "Specialise.isLocalSpecTyCon (ToDo)" -isSpecId_maybe = panic "Specialise.isSpecId_maybe (ToDo)" -isSpecPragmaId_maybe = panic "Specialise.isSpecPragmaId_maybe (ToDo)" -lookupClassInstAtSimpleType = panic "Specialise.lookupClassInstAtSimpleType (ToDo)" -mkSpecEnv = panic "Specialise.mkSpecEnv (ToDo)" -mkSpecId = panic "Specialise.mkSpecId (ToDo)" -selectIdInfoForSpecId = panic "Specialise.selectIdInfoForSpecId (ToDo)" -specialiseTy = panic "Specialise.specialiseTy (ToDo)" +infixr 9 `thenSM` \end{code} %************************************************************************ @@ -741,6 +699,31 @@ Hence, the invariant is this: *** no specialised version is overloaded *** +%************************************************************************ +%* * +\subsubsection{The exported function} +%* * +%************************************************************************ + +\begin{code} +specProgram :: UniqSupply -> [CoreBinding] -> [CoreBinding] +specProgram us binds + = initSM us (go binds `thenSM` \ (binds', _) -> + returnSM binds' + ) + where + go [] = returnSM ([], emptyUDs) + go (bind:binds) = go binds `thenSM` \ (binds', uds) -> + specBind bind uds `thenSM` \ (bind', uds') -> + returnSM (bind' ++ binds', uds') +\end{code} + +%************************************************************************ +%* * +\subsubsection{@specExpr@: the main function} +%* * +%************************************************************************ + \begin{code} specExpr :: CoreExpr -> SpecM (CoreExpr, UsageDetails) @@ -752,11 +735,11 @@ specExpr e@(Prim _ _) = returnSM (e, emptyUDs) specExpr (Coerce co ty body) = specExpr body `thenSM` \ (body', uds) -> - returnSM (Coerce co ty body') + returnSM (Coerce co ty body', uds) specExpr (SCC cc body) = specExpr body `thenSM` \ (body', uds) -> - returnSM (SCC cc body') + returnSM (SCC cc body', uds) ---------------- Applications might generate a call instance -------------------- @@ -774,7 +757,7 @@ specExpr e@(Lam _ _) let (filtered_uds, body'') = dumpUDs bndrs uds body' in - returnSM (Lam bndr body'', filtered_uds) + returnSM (foldr Lam body'' bndrs, filtered_uds) where (bndrs, body) = go [] e @@ -796,7 +779,7 @@ specExpr (Case scrut alts) spec_alts (PrimAlts alts deflt) = mapAndCombineSM spec_prim_alt alts `thenSM` \ (alts', uds1) -> spec_deflt deflt `thenSM` \ (deflt', uds2) -> - returnSM (AlgAlts alts' deflt', uds1 `plusUDs` uds2) + returnSM (PrimAlts alts' deflt', uds1 `plusUDs` uds2) spec_alg_alt (con, args, rhs) = specExpr rhs `thenSM` \ (rhs', uds) -> @@ -809,81 +792,119 @@ specExpr (Case scrut alts) = specExpr rhs `thenSM` \ (rhs', uds) -> returnSM ((lit, rhs'), uds) - spec_deflt NoDefault = (NoDefault, emptyUDs) + spec_deflt NoDefault = returnSM (NoDefault, emptyUDs) spec_deflt (BindDefault arg rhs) = specExpr rhs `thenSM` \ (rhs', uds) -> let - (uds', rhs'') = dumpManyUDs [ValBinder arg] uds rhs' + (uds', rhs'') = dumpUDs [ValBinder arg] uds rhs' in returnSM (BindDefault arg rhs'', uds') ---------------- Finally, let is the interesting case -------------------- -specExpr (Let (NonRec bndr rhs) body) - = -- Deal with the body +specExpr (Let bind body) + = -- Deal with the body specExpr body `thenSM` \ (body', body_uds) -> - -- Deal with the RHS, specialising it according - -- to the calls found in the body - specDefn (calls body_uds) (bndr,rhs) `thenSM` \ ((bndr',rhs'), spec_defns, spec_uds) -> + -- Deal with the bindings + specBind bind body_uds `thenSM` \ (binds', uds) -> + + -- All done + returnSM (foldr Let body' binds', uds) +\end{code} +%************************************************************************ +%* * +\subsubsection{Dealing with a binding} +%* * +%************************************************************************ + +\begin{code} +specBind :: CoreBinding + -> UsageDetails -- Info on how the scope of the binding + -> SpecM ([CoreBinding], -- New bindings + UsageDetails) -- And info to pass upstream + +specBind (NonRec bndr rhs) body_uds + | isDictTy (idType bndr) + = -- It's a dictionary binding + -- Pick it up and float it outwards. + specExpr rhs `thenSM` \ (rhs', rhs_uds) -> let - all_uds = deleteCalls (rhs_uds `plusUDs` body_uds) bndr' + all_uds = rhs_uds `plusUDs` addDictBind body_uds bndr rhs' in - if bndr `elementOfIdSet` free_dicts body_uds then - -- This is a dictionary binding; we must pick it up - -- and float it outwards. - ASSERT( null spec_defns ) - returnSM (body', addDictBind all_uds bndr' rhs') + returnSM ([], all_uds) - else if isSpecPragmaId bndr then + | isSpecPragmaId bndr -- SpecPragmaIds are there solely to generate specialisations - -- Just drop the whole binding - ASSERT( null spec_defns ) - returnSM (body', all_uds) + -- Just drop the whole binding; keep only its usage details + = specExpr rhs `thenSM` \ (rhs', rhs_uds) -> + returnSM ([], rhs_uds `plusUDs` body_uds) - else - -- An ordinary binding, so glue it all together - returnSM ( - Let (NonRec bndr' rhs') (mkLets spec_defns body'), - all_uds - ) + | otherwise + = -- Deal with the RHS, specialising it according + -- to the calls found in the body + specDefn (calls body_uds) (bndr,rhs) `thenSM` \ ((bndr',rhs'), spec_defns, spec_uds) -> + let + (all_uds, (dict_binds, dump_calls)) + = splitUDs [ValBinder bndr'] (spec_uds `plusUDs` body_uds) + in + returnSM ( [NonRec bndr' rhs'] + ++ dict_binds + ++ spec_defns, + all_uds ) +specBind (Rec pairs) body_uds + = mapSM (specDefn (calls body_uds)) pairs `thenSM` \ stuff -> + let + (pairs', spec_defns_s, spec_uds_s) = unzip3 stuff + spec_defns = concat spec_defns_s + spec_uds = plusUDList spec_uds_s + (all_uds, (dict_binds, dump_calls)) + = splitUDs (map (ValBinder . fst) pairs') (spec_uds `plusUDs` body_uds) + in + returnSM ( [Rec pairs'] + ++ dict_binds + ++ spec_defns, + all_uds ) + specDefn :: CallDetails -- Info on how it is used in its scope -> (Id, CoreExpr) -- The thing being bound and its un-processed RHS -> SpecM ((Id, CoreExpr), -- The thing and its processed RHS -- the Id may now have specialisations attached - [(Id, CoreExpr)], -- Extra, specialised bindings + [CoreBinding], -- Extra, specialised bindings UsageDetails -- Stuff to fling upwards from the RHS and its ) -- specialised versions specDefn calls (fn, rhs) -- The first case is the interesting one | n_tyvars == length rhs_tyvars -- Rhs of fn's defn has right number of big lambdas - && n_dicts <= length rhs_bndrs -- and enough dict args + && n_dicts <= length rhs_bndrs -- and enough dict args && not (null calls_for_me) -- And there are some calls to specialise = -- Specialise the body of the function specExpr body `thenSM` \ (body', body_uds) -> + let + (float_uds, bound_uds@(dict_binds,_)) = splitUDs rhs_bndrs body_uds + in -- Make a specialised version for each call in calls_for_me - mapSM (spec_call body_uds) calls_for_me `thenSM` \ stuff -> + mapSM (spec_call bound_uds) calls_for_me `thenSM` \ stuff -> let (spec_defns, spec_uds, spec_env_stuff) = unzip3 stuff - (rhs_uds, body'') = dumpUDs rhs_bndrs body_uds body' - rhs' = foldr Lam bndrs body'' - - fn' = addIdSpecialisations fn spec_env_stuff + fn' = addIdSpecialisations fn spec_env_stuff + rhs' = foldr Lam (foldr Let body' dict_binds) rhs_bndrs in returnSM ((fn',rhs'), spec_defns, - rhs_uds `plusUDs` plusUDList spec_uds) + float_uds `plusUDs` plusUDList spec_uds) | otherwise -- No calls or RHS doesn't fit our preconceptions = specExpr rhs `thenSM` \ (rhs', rhs_uds) -> returnSM ((fn, rhs'), [], rhs_uds) where - (tyvars, theta, tau) = splitSigmaTy (idType fn) + fn_type = idType fn + (tyvars, theta, tau) = splitSigmaTy fn_type n_tyvars = length tyvars n_dicts = length theta @@ -897,33 +918,33 @@ specDefn calls (fn, rhs) Nothing -> [] Just cs -> fmToList cs - -- Specialise to one particular call pattern - spec_call :: UsageDetails -- From the original body + spec_call :: ProtoUsageDetails -- From the original body, captured by + -- the dictionary lambdas -> ([Maybe Type], [DictVar]) -- Call instance - -> ((Id, CoreExpr), -- Specialised definition - UsageDetails, -- Usage details from specialised body - ([Type], CoreExpr)) -- Info for the Id's SpecEnv - spec_call body_uds (call_ts, call_ds) + -> SpecM (CoreBinding, -- Specialised definition + UsageDetails, -- Usage details from specialised body + ([Type], CoreExpr)) -- Info for the Id's SpecEnv + spec_call bound_uds (call_ts, call_ds) = ASSERT( length call_ts == n_tyvars && length call_ds == n_dicts ) -- Calls are only recorded for properly-saturated applications -- Supppose the call is for f [Just t1, Nothing, Just t3, Nothing] [d1, d2] -- Construct the new binding - -- f1 = /\ b d -> (..body of f..) t1 b t3 d d1 d2 + -- f1 = /\ b d -> (..rhs of f..) t1 b t3 d d1 d2 -- and the type of this binder let - spec_tyvars = [tyvar | (tyvar, Nothing) <- tyvars `zip` call_tys] + spec_tyvars = [tyvar | (tyvar, Nothing) <- tyvars `zip` call_ts] spec_tys = zipWith mk_spec_ty call_ts tyvars spec_rhs = mkTyLam spec_tyvars $ mkGenApp rhs (map TyArg spec_tys ++ map VarArg call_ds) - spec_id_ty = mkForAllTys spec_tyvars (applyTys (idType f) spec_tys) + spec_id_ty = mkForAllTys spec_tyvars (applyTys fn_type spec_tys) mk_spec_ty (Just ty) _ = ty mk_spec_ty Nothing tyvar = mkTyVarTy tyvar in - newIdSM f spec_id_ty `thenSM` \ spec_f -> + newIdSM fn spec_id_ty `thenSM` \ spec_f -> -- Construct the stuff for f's spec env @@ -936,11 +957,15 @@ specDefn calls (fn, rhs) in -- Specialise the UDs from f's RHS - specUDs (zipEqual rhs_tyvars call_ts) - (zipEqual rhs_dicts call_ds) - body_uds `thenSM` \ spec_uds -> + let + tv_env = [ (rhs_tyvar,ty) + | (rhs_tyvar, Just ty) <- zipEqual "specUDs1" rhs_tyvars call_ts + ] + dict_env = zipEqual "specUDs2" rhs_dicts call_ds + in + specUDs tv_env dict_env bound_uds `thenSM` \ spec_uds -> - returnSM ((spec_f, spec_rhs), + returnSM (NonRec spec_f spec_rhs, spec_uds, spec_env_info ) @@ -957,9 +982,7 @@ type FreeDicts = IdSet data UsageDetails = MkUD { - free_dicts :: !FreeDicts, -- Dicts free in any of the calls or dict binds - - dict_binds :: !Bag (DictVar, CoreExpr, FreeDicts), + dict_binds :: !(Bag (DictVar, CoreExpr, TyVarSet, FreeDicts)), -- Floated dictionary bindings -- The order is important; -- in ds1 `union` ds2, bindings in ds2 can depend on those in ds1 @@ -969,108 +992,159 @@ data UsageDetails calls :: !CallDetails } -type CallMap = FiniteMap Id CallInfo -type CallInfo = FiniteMap [Maybe Type] -- Nothing => unconstrained type argument - [DictVar] -- Dict args +emptyUDs = MkUD { dict_binds = emptyBag, calls = emptyFM } + +type ProtoUsageDetails = ([CoreBinding], -- Dict bindings + [(Id, [Maybe Type], [DictVar])] + ) + +------------------------------------------------------------ +type CallDetails = FiniteMap Id CallInfo +type CallInfo = FiniteMap [Maybe Type] -- Nothing => unconstrained type argument + [DictVar] -- Dict args -- The finite maps eliminate duplicates -- The list of types and dictionaries is guaranteed to -- match the type of f - -plusUDs :: UsageDetails -> UsageDetails -> UsageDetails -plusUDs (MkUD {fvs = fvs1, dictBinds = db1, calls = calls1}) - (MkUD {fvs = fvs2, dictBinds = db2, calls = calls2}) - = MkUD {fvs, dictBinds, calls} +callDetailsToList calls = [ (id,tys,dicts) + | (id,fm) <- fmToList calls, + (tys,dicts) <- fmToList fm + ] + +listToCallDetails calls = foldr (unionCalls . singleCall) emptyFM calls + +unionCalls :: CallDetails -> CallDetails -> CallDetails +unionCalls c1 c2 = plusFM_C plusFM c1 c2 + +singleCall (id, tys, dicts) = unitFM id (unitFM tys dicts) + +mkCallUDs f args + | null theta + || length spec_tys /= n_tyvars + || length dicts /= n_dicts + = emptyUDs -- Not overloaded + + | otherwise + = MkUD {dict_binds = emptyBag, + calls = singleCall (f, spec_tys, dicts) + } where - fvs = fvs1 `unionIdSets` fvs2 - dictBinds = db1 `unionBags` db2 - calls = calls1 `unionBags` calls2 + (tyvars, theta, tau) = splitSigmaTy (idType f) + constrained_tyvars = foldr (unionTyVarSets . tyVarsOfTypes . snd) emptyTyVarSet theta + n_tyvars = length tyvars + n_dicts = length theta + + spec_tys = [mk_spec_ty tv ty | (tv, TyArg ty) <- tyvars `zip` args] + dicts = [d | (_, VarArg d) <- theta `zip` (drop n_tyvars args)] + + mk_spec_ty tyvar ty | tyvar `elementOfTyVarSet` constrained_tyvars + = Just ty + | otherwise + = Nothing +------------------------------------------------------------ +plusUDs :: UsageDetails -> UsageDetails -> UsageDetails +plusUDs (MkUD {dict_binds = db1, calls = calls1}) + (MkUD {dict_binds = db2, calls = calls2}) + = MkUD {dict_binds, calls} + where + dict_binds = db1 `unionBags` db2 + calls = calls1 `unionCalls` calls2 -tyVarsOfUDs (MkUD {fvs}) = tyVarsOfTypes (map idType (idSetToList fvs)) +plusUDList = foldr plusUDs emptyUDs -deleteCalls uds bndr = uds { calls = delFromFM (calls uds) bndr } +mkDB dict rhs = (dict, rhs, db_ftvs, db_fvs) + where + db_ftvs = tyVarsOfType (idType dict) -- Superset of RHS fvs + db_fvs = dictRhsFVs rhs -addDictBind uds dict rhs = uds { free_dicts = addToIdSet (free_dicts uds) dict, - dict_binds = (dict, rhs, f +addDictBind uds dict rhs = uds { dict_binds = mkDB dict rhs `consBag` dict_binds uds } dumpUDs :: [CoreBinder] -> UsageDetails -> CoreExpr -> (UsageDetails, CoreExpr) +dumpUDs bndrs uds body + = (free_uds, foldr Let body dict_binds) + where + (free_uds, (dict_binds, _)) = splitUDs bndrs uds -dumpUDs bndrs uds@(MkUDs {fvs = orig_fvs, dictBinds = orig_dbs, calls = orig_calls}) body - = ASSERT( isEmptyTyVarSet (tyvar_set `intersectTyVarSets` ftvs)) - -- The tyvars shouldn't be free in any of the usage details - -- If it was, then we should have found a dictionary lambda first +splitUDs :: [CoreBinder] + -> UsageDetails + -> (UsageDetails, -- These don't mention the binders + ProtoUsageDetails) -- These do + +splitUDs bndrs uds@(MkUD {dict_binds = orig_dbs, + calls = orig_calls}) - if isEmptyIdSet (id_set `intersectIdSets` fvs) then + = if isEmptyBag dump_dbs && null dump_calls then -- Common case: binder doesn't affect floats - (uds, body) + (uds, ([],[])) else -- Binders bind some of the fvs of the floats - (MkUDs {fvs = filtered_fvs, - dictBinds = filtered_dbs, - calls = filtered_calls}, - foldrBag mk_dict_bind body dump_dbs) + (MkUD {dict_binds = free_dbs, + calls = listToCallDetails free_calls}, + (bagToList dump_dbs, dump_calls) + ) where - tyvar_set = mkTyVarSet [tv | TyBinder tv <- bndrs] - id_list = [id | ValBinder id <- bndrs] - id_set = mkIdSet id_list - ftvs = tyVarsOfUDs uds - filtered_fvs = orig_fvs `minusIdSet` id_set - - (filtered_dbs, dump_dbs, dump_idset) - = foldlBag dump (emptyBag, emptyBag, id_set) orig_dbs + tyvar_set = mkTyVarSet [tv | TyBinder tv <- bndrs] + id_set = mkIdSet [id | ValBinder id <- bndrs] + + (free_dbs, dump_dbs, dump_idset) + = foldlBag dump_db (emptyBag, emptyBag, id_set) orig_dbs -- Important that it's foldl not foldr; -- we're accumulating the set of dumped ids in dump_set -- Filter out any calls that mention things that are being dumped - -- It's a bit tiresome because of the two-level finite map - filtered_calls = mapFM del (foldr delFromFM orig_calls id_list) - del _ dicts = filter (not (`elementOfIdSet` dump_id_set)) dicts - - dump (ok_dbs, dump_dbs, dump_idset) db@(dict, rhs, fvs) - | isEmptyIdSet (dump_idset `intersectIdSets` fvs) - = (ok_dbs `snocBag` db, dump_dbs, dump_idset) + -- Don't need to worry about the tyvars because the dicts will + -- spot the captured ones; any fully polymorphic arguments will + -- be Nothings in the call details + orig_call_list = callDetailsToList orig_calls + (dump_calls, free_calls) = partition captured orig_call_list + captured (id,tys,dicts) = any (`elementOfIdSet` dump_idset) (id:dicts) + + dump_db (free_dbs, dump_dbs, dump_idset) db@(dict, rhs, ftvs, fvs) + | isEmptyIdSet (dump_idset `intersectIdSets` fvs) + && isEmptyTyVarSet (tyvar_set `intersectTyVarSets` ftvs) + = (free_dbs `snocBag` db, dump_dbs, dump_idset) | otherwise -- Dump it - = (ok_dbs, dump_dbs `snocBag` db, idEmptyIdSet (dump_idset `intersectIdSets` fvs) - - mk_dict_bind (dict, rhs, _) body = Let (NonRec dict rhs) body + = (free_dbs, dump_dbs `snocBag` NonRec dict rhs, + dump_idset `addOneToIdSet` dict) \end{code} Given a type and value substitution, specUDs creates a specialised copy of the given UDs \begin{code} -specUDs tv_assoc id_assoc (MkUDs {fvs = orig_fvs, dictBinds = orig_dbs, calls = orig_calls}) - = mapAccumLSM spec_bind - (tv_env, id_env) - (bagToList orig_dbs) `thenSM` \ ((tv_env', id_env'), new_dbs) -> - let - subst_call call_info = listToFM [(map (instantiateTy ty_env') ts, - map (lookupId id_env') call_ds) - | (call_ts, call_ds) <- fmToList call_info - ] - in - MkUDs { fvs = substFVSet id_env orig_fvs, - dictBinds = listToBag new_dbs, - calls = mapFM orig_calls subst_call - } +specUDs :: [(TyVar,Type)] -> [(DictVar,DictVar)] -> ProtoUsageDetails -> SpecM UsageDetails +specUDs tv_env_list dict_env_list (dbs, calls) + = specDBs dict_env dbs `thenSM` \ (dict_env', dbs') -> + returnSM (MkUD { dict_binds = dbs', + calls = listToCallDetails (map (inst_call dict_env') calls) + }) where - tv_env = mkTyVarEnv tv_assoc - id_env = mkIdEnv id_assoc - - spec_bind (ty_env, id_env) (dict, rhs, fvs) - = newIdSM dict spec_ty `thenSM` \ spec_dict -> - returnSM ((ty_env, addOneToIdEnv id_env dict spec_dict), (spec_dict, spec_rhs)) - where - spec_ty = instantiateTy ty_env (idType dict) - spec_rhs = instantiateDictRhs ty_env id_env rhs -\end{code} + tv_env = mkTyVarEnv tv_env_list + dict_env = mkIdEnv dict_env_list + + inst_call dict_env (id, tys, dicts) = (id, map inst_maybe_ty tys, + map (lookupId dict_env) dicts) + inst_maybe_ty Nothing = Nothing + inst_maybe_ty (Just ty) = Just (instantiateTy tv_env ty) + + specDBs dict_env [] + = returnSM (dict_env, emptyBag) + specDBs dict_env (NonRec dict rhs : dbs) + = newIdSM dict (instantiateTy tv_env (idType dict)) `thenSM` \ dict' -> + let + dict_env' = addOneToIdEnv dict_env dict dict' + rhs' = instantiateDictRhs tv_env dict_env rhs + in + specDBs dict_env' dbs `thenSM` \ (dict_env'', dbs') -> + returnSM ( dict_env'', mkDB dict' rhs' `consBag` dbs' ) +\end{code} %************************************************************************ %* * @@ -1079,9 +1153,6 @@ specUDs tv_assoc id_assoc (MkUDs {fvs = orig_fvs, dictBinds = orig_dbs, calls = %************************************************************************ \begin{code} -substFVSet :: IdEnv Id -> IdSet -> IdSet -substFVSet env s = mkIdSet [lookupId env id | id <- idSetToList s] - lookupId:: IdEnv Id -> Id -> Id lookupId env id = case lookupIdEnv env id of Nothing -> id @@ -1092,1873 +1163,54 @@ instantiateDictRhs :: TyVarEnv Type -> IdEnv Id -> CoreExpr -> CoreExpr instantiateDictRhs ty_env id_env rhs = go rhs where - go (App e1 (ValArg a)) = App (go e1) (ValArg (lookupId id_env a)) + go (App e1 (VarArg a)) = App (go e1) (VarArg (lookupId id_env a)) go (App e1 (TyArg t)) = App (go e1) (TyArg (instantiateTy ty_env t)) go (Var v) = Var (lookupId id_env v) go (Lit l) = Lit l dictRhsFVs :: CoreExpr -> IdSet -- Cheapo function for simple RHSs -dictRhsFVs (App e1 (ValArg a)) = dictRhsFVs e1 `addOneToIdSet` a - go (App e1 (TyArg t)) = dictRhsFVs e1 - go (Var v) = singletonIdSet v - go (Lit l) = emptyIdSet - -mkLets [] body = body -mkLets ((bndr,rhs):binds) body = Let (NonRec bndr rhs) (mkLets binds body) - -zipNothings [] [] = [] -zipNothings (Nothing : tys) (tyvar : tyvars) = mkTyVarTy tyvar : zipNothings tys tyvars -zipNothings (Just ty : tys) tyvars = ty : zipNothings tys tyvars -\end{code} - - -=========================== OLD STUFF ================================= - -%************************************************************************ -%* * -\subsubsection[CallInstances]{@CallInstances@ data type} -%* * -%************************************************************************ - -\begin{code} -type FreeVarsSet = IdSet -type FreeTyVarsSet = TyVarSet - -data CallInstance - = CallInstance - Id -- This Id; *new* ie *cloned* id - [Maybe Type] -- Specialised at these types (*new*, cloned) - -- Nothing => no specialisation on this type arg - -- is required (flag dependent). - [CoreArg] -- And these dictionaries; all ValArgs - FreeVarsSet -- Free vars of the dict-args in terms of *new* ids - (Maybe SpecInfo) -- For specialisation with explicit SpecId -\end{code} - -\begin{code} -pprCI :: CallInstance -> Doc -pprCI (CallInstance id spec_tys dicts _ maybe_specinfo) - = hang (hsep [ptext SLIT("Call inst for"), ppr id]) - 4 (vcat [hsep (text "types" : [pprMaybeTy ty | ty <- spec_tys]), - case maybe_specinfo of - Nothing -> hsep (text "dicts" : [ppr_arg dict | dict <- dicts]) - Just (SpecInfo _ _ spec_id) - -> hsep [ptext SLIT("Explicit SpecId"), ppr spec_id] - ]) - --- ToDo: instance Outputable CoreArg? -ppr_arg (TyArg t) = ppr sty t -ppr_arg (LitArg i) = ppr sty i -ppr_arg (VarArg v) = ppr sty v - -isUnboxedCI :: CallInstance -> Bool -isUnboxedCI (CallInstance _ spec_tys _ _ _) - = any isUnboxedType (catMaybes spec_tys) - -isExplicitCI :: CallInstance -> Bool -isExplicitCI (CallInstance _ _ _ _ (Just _)) - = True -isExplicitCI (CallInstance _ _ _ _ Nothing) - = False -\end{code} - -Comparisons are based on the {\em types}, ignoring the dictionary args: - -\begin{code} - -cmpCI :: CallInstance -> CallInstance -> Ordering -cmpCI (CallInstance id1 tys1 _ _ _) (CallInstance id2 tys2 _ _ _) - = compare id1 id2 `thenCmp` cmpUniTypeMaybeList tys1 tys2 - -cmpCI_tys :: CallInstance -> CallInstance -> Ordering -cmpCI_tys (CallInstance _ tys1 _ _ _) (CallInstance _ tys2 _ _ _) - = cmpUniTypeMaybeList tys1 tys2 - -eqCI_tys :: CallInstance -> CallInstance -> Bool -eqCI_tys c1 c2 - = case cmpCI_tys c1 c2 of { EQ -> True; other -> False } - -isCIofTheseIds :: [Id] -> CallInstance -> Bool -isCIofTheseIds ids (CallInstance ci_id _ _ _ _) - = any ((==) ci_id) ids - -singleCI :: Id -> [Maybe Type] -> [CoreArg] -> UsageDetails -singleCI id tys dicts - = UsageDetails (unitBag (CallInstance id tys dicts fv_set Nothing)) - emptyBag [] emptyIdSet 0 0 - where - fv_set = mkIdSet (id : [dict | (VarArg dict) <- dicts]) - -explicitCI :: Id -> [Maybe Type] -> SpecInfo -> UsageDetails -explicitCI id tys specinfo - = UsageDetails (unitBag call_inst) emptyBag [] emptyIdSet 0 0 - where - call_inst = CallInstance id tys dicts fv_set (Just specinfo) - dicts = panic "Specialise:explicitCI:dicts" - fv_set = unitIdSet id - --- We do not process the CIs for top-level dfuns or defms --- Instead we require an explicit SPEC inst pragma for dfuns --- and an explict method within any instances for the defms - -getCIids :: Bool -> [Id] -> [Id] -getCIids True ids = filter not_dict_or_defm ids -getCIids _ ids = ids - -not_dict_or_defm id - = not (isDictTy (idType id) || maybeToBool (isDefaultMethodId_maybe id)) - -getCIs :: Bool -> [Id] -> UsageDetails -> ([CallInstance], UsageDetails) -getCIs top_lev ids (UsageDetails cis tycon_cis dbs fvs c i) - = let - (cis_here, cis_not_here) = partitionBag (isCIofTheseIds (getCIids top_lev ids)) cis - cis_here_list = bagToList cis_here - in - -- pprTrace "getCIs:" - -- (hang (hcat [char '{', - -- interppSP ids, - -- char '}']) - -- 4 (vcat (map pprCI cis_here_list))) - (cis_here_list, UsageDetails cis_not_here tycon_cis dbs fvs c i) - -dumpCIs :: Bag CallInstance -- The call instances - -> Bool -- True <=> top level bound Ids - -> Bool -- True <=> dict bindings to be floated (specBind only) - -> [CallInstance] -- Call insts for bound ids (instBind only) - -> [Id] -- Bound ids *new* - -> [Id] -- Full bound ids: includes dumped dicts - -> Bag CallInstance -- Kept call instances - - -- CIs are dumped if: - -- 1) they are a CI for one of the bound ids, or - -- 2) they mention any of the dicts in a local unfloated binding - -- - -- For top-level bindings we allow the call instances to - -- float past a dict bind and place all the top-level binds - -- in a *global* Rec. - -- We leave it to the simplifier will sort it all out ... - -dumpCIs cis top_lev floating inst_cis bound_ids full_ids - = (if not (isEmptyBag cis_of_bound_id) && - not (isEmptyBag cis_of_bound_id_without_inst_cis) - then - pprTrace ("dumpCIs: dumping CI which was not instantiated ... \n" ++ - " (may be a non-HM recursive call)\n") - (hang (hcat [char '{', - interppSP bound_ids, - char '}']) - 4 (vcat [ptext SLIT("Dumping CIs:"), - vcat (map pprCI (bagToList cis_of_bound_id)), - ptext SLIT("Instantiating CIs:"), - vcat (map pprCI inst_cis)])) - else id) ( - if top_lev || floating then - cis_not_bound_id - else - (if not (isEmptyBag cis_dump_unboxed) - then pprTrace "dumpCIs: bound dictionary arg ... WITH UNBOXED TYPES!\n" - (hang (hcat [char '{', - interppSP full_ids, - char '}']) - 4 (vcat (map pprCI (bagToList cis_dump)))) - else id) - cis_keep_not_bound_id - ) - where - (cis_of_bound_id, cis_not_bound_id) - = partitionBag (isCIofTheseIds (getCIids top_lev bound_ids)) cis - - (cis_dump, cis_keep_not_bound_id) - = partitionBag ok_to_dump_ci cis_not_bound_id - - ok_to_dump_ci (CallInstance _ _ _ fv_set _) - = any (\ i -> i `elementOfIdSet` fv_set) full_ids - - (_, cis_of_bound_id_without_inst_cis) = partitionBag have_inst_ci cis_of_bound_id - have_inst_ci ci = any (eqCI_tys ci) inst_cis - - (cis_dump_unboxed, _) = partitionBag isUnboxedCI cis_dump - -\end{code} - -Any call instances of a bound_id can be safely dumped, because any -recursive calls should be at the same instance as the parent instance. - - letrec f = /\a -> \x::a -> ...(f t x')... - -Here, the type, t, at which f is used in its own RHS should be -just "a"; that is, the recursive call is at the same type as -the original call. That means that when specialising f at some -type, say Int#, we shouldn't find any *new* instances of f -arising from specialising f's RHS. The only instance we'll find -is another call of (f Int#). - -We check this in dumpCIs by passing in all the instantiated call -instances (inst_cis) and reporting any dumped cis (cis_of_bound_id) -for which there is no such instance. - -We also report CIs dumped due to a bound dictionary arg if they -contain unboxed types. - -%************************************************************************ -%* * -\subsubsection[TyConInstances]{@TyConInstances@ data type} -%* * -%************************************************************************ - -\begin{code} -data TyConInstance - = TyConInstance TyCon -- Type Constructor - [Maybe Type] -- Applied to these specialising types - -cmpTyConI :: TyConInstance -> TyConInstance -> Ordering -cmpTyConI (TyConInstance tc1 tys1) (TyConInstance tc2 tys2) - = compare tc1 tc2 `thenCmp` cmpUniTypeMaybeList tys1 tys2 - -cmpTyConI_tys :: TyConInstance -> TyConInstance -> Ordering -cmpTyConI_tys (TyConInstance _ tys1) (TyConInstance _ tys2) - = cmpUniTypeMaybeList tys1 tys2 - -singleTyConI :: TyCon -> [Maybe Type] -> UsageDetails -singleTyConI ty_con spec_tys - = UsageDetails emptyBag (unitBag (TyConInstance ty_con spec_tys)) [] emptyIdSet 0 0 - -isTyConIofThisTyCon :: TyCon -> TyConInstance -> Bool -isTyConIofThisTyCon ty_con (TyConInstance inst_ty_con _) = ty_con == inst_ty_con - -isLocalSpecTyConI :: Bool -> TyConInstance -> Bool -isLocalSpecTyConI comp_prel (TyConInstance inst_ty_con _) = isLocalSpecTyCon comp_prel inst_ty_con - -getLocalSpecTyConIs :: Bool -> UsageDetails -> ([TyConInstance], UsageDetails) -getLocalSpecTyConIs comp_prel (UsageDetails cis tycon_cis dbs fvs c i) - = let - (tycon_cis_local, tycon_cis_global) - = partitionBag (isLocalSpecTyConI comp_prel) tycon_cis - tycon_cis_local_list = bagToList tycon_cis_local - in - (tycon_cis_local_list, UsageDetails cis tycon_cis_global dbs fvs c i) -\end{code} - - -%************************************************************************ -%* * -\subsubsection[UsageDetails]{@UsageDetails@ data type} -%* * -%************************************************************************ - -\begin{code} -data UsageDetails - = UsageDetails - (Bag CallInstance) -- The collection of call-instances - (Bag TyConInstance) -- Constructor call-instances - [DictBindDetails] -- Dictionary bindings in data-dependence order! - FreeVarsSet -- Free variables (excl imported ones, incl top level) (cloned) - Int -- no. of spec calls - Int -- no. of spec insts -\end{code} - -The DictBindDetails are fully processed; their call-instance -information is incorporated in the call-instances of the UsageDetails -which includes the DictBindDetails. The free vars in a usage details -will *include* the binders of the DictBind details. +dictRhsFVs (App e1 (VarArg a)) = dictRhsFVs e1 `addOneToIdSet` a +dictRhsFVs (App e1 (TyArg t)) = dictRhsFVs e1 +dictRhsFVs (Var v) = unitIdSet v +dictRhsFVs (Lit l) = emptyIdSet -A @DictBindDetails@ contains bindings for dictionaries *only*. -\begin{code} -data DictBindDetails - = DictBindDetails - [Id] -- Main binders, originally visible in scope of binding (cloned) - CoreBinding -- Fully processed - FreeVarsSet -- Free in binding group (cloned) - FreeTyVarsSet -- Free in binding group -\end{code} - -\begin{code} -emptyUDs :: UsageDetails -unionUDs :: UsageDetails -> UsageDetails -> UsageDetails -unionUDList :: [UsageDetails] -> UsageDetails - --- tickSpecCall :: Bool -> UsageDetails -> UsageDetails -tickSpecInsts :: UsageDetails -> UsageDetails - --- tickSpecCall found (UsageDetails cis ty_cis dbs fvs c i) --- = UsageDetails cis ty_cis dbs fvs (c + (if found then 1 else 0)) i - -tickSpecInsts (UsageDetails cis ty_cis dbs fvs c i) - = UsageDetails cis ty_cis dbs fvs c (i+1) - -emptyUDs = UsageDetails emptyBag emptyBag [] emptyIdSet 0 0 - -unionUDs (UsageDetails cis1 tycon_cis1 dbs1 fvs1 c1 i1) (UsageDetails cis2 tycon_cis2 dbs2 fvs2 c2 i2) - = UsageDetails (unionBags cis1 cis2) (unionBags tycon_cis1 tycon_cis2) - (dbs1 ++ dbs2) (fvs1 `unionIdSets` fvs2) (c1+c2) (i1+i2) - -- The append here is really redundant, since the bindings don't - -- scope over each other. ToDo. - -unionUDList = foldr unionUDs emptyUDs - -singleFvUDs (VarArg v) | not (isImportedId v) - = UsageDetails emptyBag emptyBag [] (unitIdSet v) 0 0 -singleFvUDs other - = emptyUDs - -singleConUDs con = UsageDetails emptyBag emptyBag [] (unitIdSet con) 0 0 - -dumpDBs :: [DictBindDetails] - -> Bool -- True <=> top level bound Ids - -> [TyVar] -- TyVars being bound (cloned) - -> [Id] -- Ids being bound (cloned) - -> FreeVarsSet -- Fvs of body - -> ([CoreBinding], -- These ones have to go here - [DictBindDetails], -- These can float further - [Id], -- Incoming list + names of dicts bound here - FreeVarsSet -- Incoming fvs + fvs of dicts bound here - ) - - -- It is just to complex to try to float top-level - -- dict bindings with constant methods, inst methods, - -- auxillary derived instance defns and user instance - -- defns all getting in the way. - -- So we dump all dbinds as soon as we get to the top - -- level and place them in a *global* Rec. - -- We leave it to the simplifier will sort it all out ... - -dumpDBs [] top_lev bound_tyvars bound_ids fvs - = ([], [], bound_ids, fvs) - -dumpDBs ((db@(DictBindDetails dbinders dbind db_fvs db_ftv)):dbs) - top_lev bound_tyvars bound_ids fvs - | top_lev - || any (\ i -> i `elementOfIdSet` db_fvs) bound_ids - || any (\ t -> t `elementOfTyVarSet` db_ftv) bound_tyvars - = let -- Ha! Dump it! - (dbinds_here, dbs_outer, full_bound_ids, full_fvs) - = dumpDBs dbs top_lev bound_tyvars (dbinders ++ bound_ids) (db_fvs `unionIdSets` fvs) - in - (dbind : dbinds_here, dbs_outer, full_bound_ids, full_fvs) - - | otherwise -- This one can float out further - = let - (dbinds_here, dbs_outer, full_bound_ids, full_fvs) - = dumpDBs dbs top_lev bound_tyvars bound_ids fvs - in - (dbinds_here, db : dbs_outer, full_bound_ids, full_fvs) - - - -dumpUDs :: UsageDetails - -> Bool -- True <=> top level bound Ids - -> Bool -- True <=> dict bindings to be floated (specBind only) - -> [CallInstance] -- Call insts for bound Ids (instBind only) - -> [Id] -- Ids which are just being bound; *new* - -> [TyVar] -- TyVars which are just being bound - -> ([CoreBinding], -- Bindings from UsageDetails which mention the ids - UsageDetails) -- The above bindings removed, and - -- any call-instances which mention the ids dumped too - -dumpUDs (UsageDetails cis tycon_cis dbs fvs c i) top_lev floating inst_cis bound_ids tvs - = let - (dict_binds_here, dbs_outer, full_bound_ids, full_fvs) - = dumpDBs dbs top_lev tvs bound_ids fvs - cis_outer = dumpCIs cis top_lev floating inst_cis bound_ids full_bound_ids - fvs_outer = full_fvs `minusIdSet` (mkIdSet full_bound_ids) - in - (dict_binds_here, UsageDetails cis_outer tycon_cis dbs_outer fvs_outer c i) -\end{code} - -\begin{code} -addDictBinds :: [Id] -> CoreBinding -> UsageDetails -- Dict binding and RHS usage - -> UsageDetails -- The usage to augment - -> UsageDetails -addDictBinds dbinders dbind (UsageDetails db_cis db_tycon_cis db_dbs db_fvs db_c db_i) - (UsageDetails cis tycon_cis dbs fvs c i) - = UsageDetails (db_cis `unionBags` cis) - (db_tycon_cis `unionBags` tycon_cis) - (db_dbs ++ [DictBindDetails dbinders dbind db_fvs db_ftvs] ++ dbs) - fvs c i - -- NB: We ignore counts from dictbinds since it is not user code - where - -- The free tyvars of the dictionary bindings should really be - -- gotten from the RHSs, but I'm pretty sure it's good enough just - -- to look at the type of the dictionary itself. - -- Doing the proper job would entail keeping track of free tyvars as - -- well as free vars, which would be a bore. - db_ftvs = tyVarsOfTypes (map idType dbinders) -\end{code} - -%************************************************************************ -%* * -\subsection[cloning-binders]{The Specialising IdEnv and CloneInfo} -%* * -%************************************************************************ - -@SpecIdEnv@ maps old Ids to their new "clone". There are three cases: - -1) (NoLift LitArg l) : an Id which is bound to a literal - -2) (NoLift LitArg l) : an Id bound to a "new" Id - The new Id is a possibly-type-specialised clone of the original - -3) Lifted lifted_id unlifted_id : - - This indicates that the original Id has been specialised to an - unboxed value which must be lifted (see "Unboxed bindings" above) - @unlifted_id@ is the unboxed clone of the original Id - @lifted_id@ is a *lifted* version of the original Id - - When you lookup Ids which are Lifted, you have to insert a case - expression to un-lift the value (done with @bindUnlift@) - - You also have to insert a case to lift the value in the binding - (done with @liftExpr@) - - -\begin{code} -type SpecIdEnv = IdEnv CloneInfo - -data CloneInfo - = NoLift CoreArg -- refers to cloned id or literal - - | Lifted Id -- lifted, cloned id - Id -- unlifted, cloned id - -\end{code} - -%************************************************************************ -%* * -\subsection[specialise-data]{Data returned by specialiser} -%* * -%************************************************************************ - -\begin{code} --} - -data SpecialiseData - = SpecData Bool - -- True <=> Specialisation performed - Bool - -- False <=> Specialisation completed with errors - - [TyCon] - -- Local tycons declared in this module - - [TyCon] - -- Those in-scope data types for which we want to - -- generate code for their constructors. - -- Namely: data types declared in this module + - -- any big tuples used in this module - -- The initial (and default) value is the local tycons - - (FiniteMap TyCon [(Bool, [Maybe Type])]) - -- TyCon specialisations to be generated - -- We generate specialialised code (Bool=True) for data types - -- defined in this module and any tuples used in this module - -- The initial (and default) value is the specialisations - -- requested by source-level SPECIALIZE data pragmas (Bool=True) - -- and _SPECIALISE_ pragmas (Bool=False) in the interface files - - (Bag (Id,[Maybe Type])) - -- Imported specialisation errors - (Bag (Id,[Maybe Type])) - -- Imported specialisation warnings - (Bag (TyCon,[Maybe Type])) - -- Imported TyCon specialisation errors - -initSpecData local_tycons tycon_specs - = SpecData False True local_tycons local_tycons tycon_specs emptyBag emptyBag emptyBag - -{- -\end{code} - -ToDo[sansom]: Transformation data to process specialisation requests. - -%************************************************************************ -%* * -\subsection[specProgram]{Specialising a core program} -%* * -%************************************************************************ - -\begin{code} -specProgram :: UniqSupply - -> [CoreBinding] -- input ... - -> SpecialiseData - -> ([CoreBinding], -- main result - SpecialiseData) -- result specialise data - -specProgram uniqs binds - (SpecData False _ local_tycons _ init_specs init_errs init_warn init_tyerrs) - = case (initSM (specTyConsAndScope (specTopBinds binds)) uniqs) of - (final_binds, tycon_specs_list, - UsageDetails import_cis import_tycis _ fvs spec_calls spec_insts) - -> let - used_conids = filter isDataCon (uniqSetToList fvs) - used_tycons = map dataConTyCon used_conids - used_gen = filter isLocalGenTyCon used_tycons - gen_tycons = uniqSetToList (mkUniqSet local_tycons `unionUniqSets` mkUniqSet used_gen) - - result_specs = addListToFM_C (++) init_specs tycon_specs_list - - uniq_cis = map head (equivClasses cmpCI (bagToList import_cis)) - cis_list = [(id, tys) | CallInstance id tys _ _ _ <- uniq_cis] - (cis_unboxed, cis_other) = partition (isUnboxedSpecialisation . snd) cis_list - cis_warn = init_warn `unionBags` listToBag cis_other - cis_errs = init_errs `unionBags` listToBag cis_unboxed - - uniq_tycis = map head (equivClasses cmpTyConI (bagToList import_tycis)) - tycis_unboxed = [(con, tys) | TyConInstance con tys <- uniq_tycis] - tycis_errs = init_tyerrs `unionBags` listToBag tycis_unboxed - - no_errs = isEmptyBag cis_errs && isEmptyBag tycis_errs - && (not opt_SpecialiseImports || isEmptyBag cis_warn) - in - (if opt_D_simplifier_stats then - pprTrace "\nSpecialiser Stats:\n" (vcat [ - hcat [ptext SLIT("SpecCalls "), int spec_calls], - hcat [ptext SLIT("SpecInsts "), int spec_insts], - space]) - else id) - - (final_binds, - SpecData True no_errs local_tycons gen_tycons result_specs - cis_errs cis_warn tycis_errs) - -specProgram uniqs binds (SpecData True _ _ _ _ _ _ _) - = panic "Specialise:specProgram: specialiser called more than once" - --- It may be possible safely to call the specialiser more than once, --- but I am not sure there is any benefit in doing so (Patrick) - --- ToDo: What about unfoldings performed after specialisation ??? -\end{code} - -%************************************************************************ -%* * -\subsection[specTyConsAndScope]{Specialising data constructors within tycons} -%* * -%************************************************************************ - -In the specialiser we just collect up the specialisations which will -be required. We don't create the specialised constructors in -Core. These are only introduced when we convert to StgSyn. - -ToDo: Perhaps this collection should be done in CoreToStg to ensure no inconsistencies! - -\begin{code} -specTyConsAndScope :: SpecM ([CoreBinding], UsageDetails) - -> SpecM ([CoreBinding], [(TyCon,[(Bool,[Maybe Type])])], UsageDetails) - -specTyConsAndScope scopeM - = scopeM `thenSM` \ (binds, scope_uds) -> - let - (tycons_cis, gotci_scope_uds) - = getLocalSpecTyConIs False{-OLD:opt_CompilingGhcInternals-} scope_uds - - tycon_specs_list = collectTyConSpecs tycons_cis - in - (if opt_SpecialiseTrace && not (null tycon_specs_list) then - pprTrace "Specialising TyCons:\n" - (vcat [ if not (null specs) then - hang (hsep [(ppr tycon), ptext SLIT("at types")]) - 4 (vcat (map pp_specs specs)) - else empty - | (tycon, specs) <- tycon_specs_list]) - else id) ( - returnSM (binds, tycon_specs_list, gotci_scope_uds) - ) - where - collectTyConSpecs [] - = [] - collectTyConSpecs tycons_cis@(TyConInstance tycon _ : _) - = (tycon, tycon_specs) : collectTyConSpecs other_tycons_cis - where - (tycon_cis, other_tycons_cis) = partition (isTyConIofThisTyCon tycon) tycons_cis - uniq_cis = map head (equivClasses cmpTyConI_tys tycon_cis) - tycon_specs = [(False, spec_tys) | TyConInstance _ spec_tys <- uniq_cis] - - pp_specs (False, spec_tys) = hsep [pprMaybeTy spec_ty | spec_ty <- spec_tys] - -\end{code} - -%************************************************************************ -%* * -\subsection[specTopBinds]{Specialising top-level bindings} -%* * -%************************************************************************ - -\begin{code} -specTopBinds :: [CoreBinding] - -> SpecM ([CoreBinding], UsageDetails) - -specTopBinds binds - = spec_top_binds binds `thenSM` \ (binds, UsageDetails cis tycis dbind_details fvs c i) -> - let - -- Add bindings for floated dbinds and collect fvs - -- In actual fact many of these bindings are dead code since dict - -- arguments are dropped when a specialised call is created - -- The simplifier should be able to cope ... - - (dbinders_s, dbinds, dfvs_s) - = unzip3 [(dbinders, dbind, dfvs) | DictBindDetails dbinders dbind dfvs _ <- dbind_details] - - full_fvs = fvs `unionIdSets` unionManyIdSets dfvs_s - fvs_outer = full_fvs `minusIdSet` (mkIdSet (concat dbinders_s)) - - -- It is just to complex to try to sort out top-level dependencies - -- So we just place all the top-level binds in a *global* Rec and - -- leave it to the simplifier to sort it all out ... - in - ASSERT(null dbinds) - returnSM ([Rec (pairsFromCoreBinds binds)], UsageDetails cis tycis [] fvs_outer c i) - - where - spec_top_binds (first_bind:rest_binds) - = specBindAndScope True first_bind ( - spec_top_binds rest_binds `thenSM` \ (rest_binds, rest_uds) -> - returnSM (ItsABinds rest_binds, rest_uds) - ) `thenSM` \ (first_binds, ItsABinds rest_binds, all_uds) -> - returnSM (first_binds ++ rest_binds, all_uds) - - spec_top_binds [] - = returnSM ([], emptyUDs) -\end{code} - -%************************************************************************ -%* * -\subsection[specExpr]{Specialising expressions} -%* * -%************************************************************************ - -\begin{code} -specExpr :: CoreExpr - -> [CoreArg] -- The arguments: - -- TypeArgs are speced - -- ValArgs are unprocessed - -> SpecM (CoreExpr, -- Result expression with specialised versions installed - UsageDetails)-- Details of usage of enclosing binders in the result - -- expression. - -specExpr (Var v) args - = specId v $ \ v_arg -> - case v_arg of - LitArg lit -> ASSERT( null args ) - returnSM (Lit lit, emptyUDs) - - VarArg new_v -> mkCallInstance v new_v args `thenSM` \ uds -> - returnSM (mkGenApp (Var new_v) args, uds) - -specExpr expr@(Lit _) null_args - = ASSERT (null null_args) - returnSM (expr, emptyUDs) - -specExpr (Con con args) null_args - = ASSERT (null null_args) - specArgs args $ \ args' -> - mkTyConInstance con args' `thenSM` \ con_uds -> - returnSM (Con con args', con_uds) - -specExpr (Prim op@(CCallOp str is_asm may_gc arg_tys res_ty) args) null_args - = ASSERT (null null_args) - specArgs args $ \ args' -> - mapSM specTy arg_tys `thenSM` \ arg_tys' -> - specTy res_ty `thenSM` \ res_ty' -> - returnSM (Prim (CCallOp str is_asm may_gc arg_tys' res_ty') args', emptuUDs) - -specExpr (Prim prim args) null_args - = ASSERT (null null_args) - specArgs args $ \ args' -> - -- specPrimOp prim tys `thenSM` \ (prim, tys, prim_uds) -> - returnSM (Prim prim args', emptyUDs {-`unionUDs` prim_uds-} ) - -{- ToDo: specPrimOp - -specPrimOp :: PrimOp - -> [Type] - -> SpecM (PrimOp, - [Type], - UsageDetails) - --- Checks that PrimOp can handle (possibly unboxed) tys passed --- and/or chooses PrimOp specialised to any unboxed tys --- Errors are dealt with by returning a PrimOp call instance --- which will result in a cis_errs message - --- ToDo: Deal with checkSpecTyApp for Prim in CoreLint --} - - -specExpr (App fun arg) args - = specArg arg `thenSM` \ new_arg -> - specExpr fun (new_arg : args) `thenSM` \ (expr,uds) -> - returnSM (expr, uds) - -specExpr (Lam (ValBinder binder) body) (arg : args) | isValArg arg - = lookup_arg arg `thenSM` \ arg -> - bindId binder arg (specExpr body args) - where - lookup_arg (LitArg l) = returnSM (NoLift (LitArg l)) - lookup_arg (VarArg v) = lookupId v - -specExpr (Lam (ValBinder binder) body) [] - = specLambdaOrCaseBody [binder] body [] `thenSM` \ ([binder], body, uds) -> - returnSM (Lam (ValBinder binder) body, uds) - -specExpr (Lam (TyBinder tyvar) body) (TyArg ty : args) - = -- Type lambda with argument; argument already spec'd - bindTyVar tyvar ty ( specExpr body args ) - -specExpr (Lam (TyBinder tyvar) body) [] - = -- No arguments - cloneTyVarSM tyvar `thenSM` \ new_tyvar -> - bindTyVar tyvar (mkTyVarTy new_tyvar) ( - specExpr body [] `thenSM` \ (body, body_uds) -> - let - (binds_here, final_uds) = dumpUDs body_uds False False [] [] [new_tyvar] - in - returnSM (Lam (TyBinder new_tyvar) - (mkCoLetsNoUnboxed binds_here body), - final_uds) +addIdSpecialisations id spec_stuff + = (if not (null errs) then + pprTrace "Duplicate specialisations" (vcat (map ppr errs)) + else \x -> x ) - -specExpr (Case scrutinee alts) args - = specExpr scrutinee [] `thenSM` \ (scrutinee, scrut_uds) -> - specAlts alts scrutinee_type args `thenSM` \ (alts, alts_uds) -> - returnSM (Case scrutinee alts, scrut_uds `unionUDs` alts_uds) - where - scrutinee_type = coreExprType scrutinee - -specExpr (Let bind body) args - = specBindAndScope False bind ( - specExpr body args `thenSM` \ (body, body_uds) -> - returnSM (ItsAnExpr body, body_uds) - ) `thenSM` \ (binds, ItsAnExpr body, all_uds) -> - returnSM (mkCoLetsUnboxedToCase binds body, all_uds) - -specExpr (SCC cc expr) args - = specExpr expr [] `thenSM` \ (expr, expr_uds) -> - mapAndUnzip3SM specOutArg args `thenSM` \ (args, args_uds_s, unlifts) -> - let - scc_expr - = if squashableDictishCcExpr cc expr -- can toss the _scc_ - then expr - else SCC cc expr - in - returnSM (applyBindUnlifts unlifts (mkGenApp scc_expr args), - unionUDList args_uds_s `unionUDs` expr_uds) - -specExpr (Coerce _ _ _) args = panic "Specialise.specExpr:Coerce" - --- ToDo: This may leave some unspec'd dictionaries!! -\end{code} - -%************************************************************************ -%* * -\subsubsection{Specialising a lambda} -%* * -%************************************************************************ - -\begin{code} -specLambdaOrCaseBody :: [Id] -- The binders - -> CoreExpr -- The body - -> [CoreArg] -- Its args - -> SpecM ([Id], -- New binders - CoreExpr, -- New body - UsageDetails) - -specLambdaOrCaseBody bound_ids body args - = cloneLambdaOrCaseBinders bound_ids `thenSM` \ (new_ids, clone_infos) -> - bindIds bound_ids clone_infos ( - - specExpr body args `thenSM` \ (body, body_uds) -> - - let - -- Dump any dictionary bindings (and call instances) - -- from the scope which mention things bound here - (binds_here, final_uds) = dumpUDs body_uds False False [] new_ids [] - in - returnSM (new_ids, mkCoLetsNoUnboxed binds_here body, final_uds) - ) - --- ToDo: Opportunity here to common-up dictionaries with same type, --- thus avoiding recomputation. -\end{code} - -A variable bound in a lambda or case is normally monomorphic so no -specialised versions will be required. This is just as well since we -do not know what code to specialise! - -Unfortunately this is not always the case. For example a class Foo -with polymorphic methods gives rise to a dictionary with polymorphic -components as follows: - -\begin{verbatim} -class Foo a where - op1 :: a -> b -> a - op2 :: a -> c -> a - -instance Foo Int where - op1 = op1Int - op2 = op2Int - -... op1 1 3# ... - -==> - -d.Foo.Int :: ( \/b . Int -> b -> Int, \/c . Int -> c -> Int ) -d.Foo.Int = (op1_Int, op2_Int) - -op1 = /\ a b -> \ dFoo -> case dFoo of (meth1, _) -> meth1 b - -... op1 {Int Int#} d.Foo.Int 1 3# ... -\end{verbatim} - -N.B. The type of the dictionary is not Hindley Milner! - -Now we must specialise op1 at {* Int#} which requires a version of -meth1 at {Int#}. But since meth1 was extracted from a dictionary we do -not have access to its code to create the specialised version. - -If we specialise on overloaded types as well we specialise op1 at -{Int Int#} d.Foo.Int: - -op1_Int_Int# = case d.Foo.Int of (meth1, _) -> meth1 {Int#} - -Though this is still invalid, after further simplification we get: - -op1_Int_Int# = opInt1 {Int#} - -Another round of specialisation will result in the specialised -version of op1Int being called directly. - -For now we PANIC if a polymorphic lambda/case bound variable is found -in a call instance with an unboxed type. Other call instances, arising -from overloaded type arguments, are discarded since the unspecialised -version extracted from the method can be called as normal. - -ToDo: Implement and test second round of specialisation. - - -%************************************************************************ -%* * -\subsubsection{Specialising case alternatives} -%* * -%************************************************************************ - - -\begin{code} -specAlts (AlgAlts alts deflt) scrutinee_ty args - = mapSM specTy ty_args `thenSM` \ ty_args -> - mapAndUnzipSM (specAlgAlt ty_args) alts `thenSM` \ (alts, alts_uds_s) -> - specDeflt deflt args `thenSM` \ (deflt, deflt_uds) -> - returnSM (AlgAlts alts deflt, - unionUDList alts_uds_s `unionUDs` deflt_uds) - where - -- We use ty_args of scrutinee type to identify specialisation of - -- alternatives: - - (_, ty_args, _) = --trace "Specialise.specAlts:getAppData..." $ - splitAlgTyConApp scrutinee_ty - - specAlgAlt ty_args (con,binders,rhs) - = specLambdaOrCaseBody binders rhs args `thenSM` \ (binders, rhs, rhs_uds) -> - mkTyConInstance con ty_args `thenSM` \ con_uds -> - returnSM ((con,binders,rhs), rhs_uds `unionUDs` con_uds) - -specAlts (PrimAlts alts deflt) scrutinee_ty args - = mapAndUnzipSM specPrimAlt alts `thenSM` \ (alts, alts_uds_s) -> - specDeflt deflt args `thenSM` \ (deflt, deflt_uds) -> - returnSM (PrimAlts alts deflt, - unionUDList alts_uds_s `unionUDs` deflt_uds) - where - specPrimAlt (lit,rhs) = specExpr rhs args `thenSM` \ (rhs, uds) -> - returnSM ((lit,rhs), uds) - - -specDeflt NoDefault args = returnSM (NoDefault, emptyUDs) -specDeflt (BindDefault binder rhs) args - = specLambdaOrCaseBody [binder] rhs args `thenSM` \ ([binder], rhs, uds) -> - returnSM (BindDefault binder rhs, uds) -\end{code} - - -%************************************************************************ -%* * -\subsubsection{Specialising an atom} -%* * -%************************************************************************ - -\begin{code} -partition_args :: [CoreArg] -> ([CoreArg], [CoreArg]) -partition_args args - = span is_ty_arg args + addIdSpecialisation id new_spec_env where - is_ty_arg (TyArg _) = True - is_ty_arg _ = False - ----------- -specId :: Id - -> (CoreArg -> SpecM (CoreExpr, UsageDetails)) - -> SpecM (CoreExpr, UsageDetails) -specId v - = lookupId v `thenSM` \ vlookup -> - case vlookup of - - Lifted vl vu - -> thing_inside (VarArg vu) `thenSM` \ (expr, uds) -> - returnSM (bindUnlift vl vu expr, singleFvUDs (VarArg vl) `unionUDs` uds) - - NoLift vatom - -> thing_inside vatom `thenSM` \ (expr, uds) -> - returnSM (expr, singleFvUDs vatom `unionUDs` uds) - -specArg :: CoreArg - -> (CoreArg -> SpecM (CoreExpr, UsageDetails)) - -> SpecM (CoreExpr, UsageDetails)) - -specArg (TyArg ty) thing_inside - = specTy ty `thenSM` \ new_ty -> - thing_inside (TyArg new_ty) - -specArg (LitArg lit) - = thing_inside (LitArg lit) - -specArg (VarArg v) - - -specArgs [] thing_inside - = thing_inside [] - -specArgs (arg:args) thing_inside - = specArg arg $ \ arg' -> - specArgs args $ \ args' -> - thing_inside (arg' : args') -\end{code} - - -%************************************************************************ -%* * -\subsubsection{Specialising bindings} -%* * -%************************************************************************ - -A classic case of when having a polymorphic recursive function would help! - -\begin{code} -data BindsOrExpr = ItsABinds [CoreBinding] - | ItsAnExpr CoreExpr -\end{code} - -\begin{code} -specBindAndScope - :: Bool -- True <=> a top level group - -> CoreBinding -- As yet unprocessed - -> SpecM (BindsOrExpr, UsageDetails) -- Something to do the scope of the bindings - -> SpecM ([CoreBinding], -- Processed - BindsOrExpr, -- Combined result - UsageDetails) -- Usage details of the whole lot - -specBindAndScope top_lev bind scopeM - = cloneLetBinders top_lev (is_rec bind) binders - `thenSM` \ (new_binders, clone_infos) -> - - -- Two cases now: either this is a bunch of local dictionaries, - -- in which case we float them; or its a bunch of other values, - -- in which case we see if they correspond to any call-instances - -- we have from processing the scope - - if not top_lev && all (isDictTy . idType) binders - then - -- Ha! A group of local dictionary bindings - - bindIds binders clone_infos ( - - -- Process the dictionary bindings themselves - specBind False True new_binders [] bind `thenSM` \ (bind, rhs_uds) -> - - -- Process their scope - scopeM `thenSM` \ (thing, scope_uds) -> - let - -- Add the bindings to the current stuff - final_uds = addDictBinds new_binders bind rhs_uds scope_uds - in - returnSM ([], thing, final_uds) - ) - else - -- Ho! A group of bindings - - fixSM (\ ~(_, _, _, rec_spec_infos) -> - - bindSpecIds binders clone_infos rec_spec_infos ( - -- It's ok to have new binders in scope in - -- non-recursive decls too, cos name shadowing is gone by now - - -- Do the scope of the bindings - scopeM `thenSM` \ (thing, scope_uds) -> - let - (call_insts, gotci_scope_uds) = getCIs top_lev new_binders scope_uds - - equiv_ciss = equivClasses cmpCI_tys call_insts - inst_cis = map head equiv_ciss - in - - -- Do the bindings themselves - specBind top_lev False new_binders inst_cis bind - `thenSM` \ (spec_bind, spec_uds) -> - - -- Create any necessary instances - instBind top_lev new_binders bind equiv_ciss inst_cis - `thenSM` \ (inst_binds, inst_uds, spec_infos) -> - - let - -- NB: dumpUDs only worries about new_binders since the free var - -- stuff only records free new_binders - -- The spec_ids only appear in SpecInfos and final speced calls - - -- Build final binding group and usage details - (final_binds, final_uds) - = if top_lev then - -- For a top-level binding we have to dumpUDs from - -- spec_uds and inst_uds and scope_uds creating - -- *global* dict bindings - let - (scope_dict_binds, final_scope_uds) - = dumpUDs gotci_scope_uds True False [] new_binders [] - (spec_dict_binds, final_spec_uds) - = dumpUDs spec_uds True False inst_cis new_binders [] - (inst_dict_binds, final_inst_uds) - = dumpUDs inst_uds True False inst_cis new_binders [] - in - ([spec_bind] ++ inst_binds ++ scope_dict_binds - ++ spec_dict_binds ++ inst_dict_binds, - final_spec_uds `unionUDs` final_scope_uds `unionUDs` final_inst_uds) - else - -- For a local binding we only have to dumpUDs from - -- scope_uds since the UDs from spec_uds and inst_uds - -- have already been dumped by specBind and instBind - let - (scope_dict_binds, final_scope_uds) - = dumpUDs gotci_scope_uds False False [] new_binders [] - in - ([spec_bind] ++ inst_binds ++ scope_dict_binds, - spec_uds `unionUDs` final_scope_uds `unionUDs` inst_uds) - - -- inst_uds comes last, because there may be dict bindings - -- floating outward in scope_uds which are mentioned - -- in the call-instances, and hence in spec_uds. - -- This ordering makes sure that the precedence order - -- among the dict bindings finally floated out is maintained. - in - returnSM (final_binds, thing, final_uds, spec_infos) - ) - ) `thenSM` \ (binds, thing, final_uds, spec_infos) -> - returnSM (binds, thing, final_uds) - where - binders = bindersOf bind - - is_rec (NonRec _ _) = False - is_rec _ = True -\end{code} - -\begin{code} -specBind :: Bool -> Bool -> [Id] -> [CallInstance] - -> CoreBinding - -> SpecM (CoreBinding, UsageDetails) - -- The UsageDetails returned has already had stuff to do with this group - -- of binders deleted; that's why new_binders is passed in. -specBind top_lev floating new_binders inst_cis (NonRec binder rhs) - = specOneBinding top_lev floating new_binders inst_cis (binder,rhs) - `thenSM` \ ((binder,rhs), rhs_uds) -> - returnSM (NonRec binder rhs, rhs_uds) - -specBind top_lev floating new_binders inst_cis (Rec pairs) - = mapAndUnzipSM (specOneBinding top_lev floating new_binders inst_cis) pairs - `thenSM` \ (pairs, rhs_uds_s) -> - returnSM (Rec pairs, unionUDList rhs_uds_s) - - -specOneBinding :: Bool -> Bool -> [Id] -> [CallInstance] - -> (Id,CoreExpr) - -> SpecM ((Id,CoreExpr), UsageDetails) - -specOneBinding top_lev floating new_binders inst_cis (binder, rhs) - = lookupId binder `thenSM` \ blookup -> - specExpr rhs [] `thenSM` \ (rhs, rhs_uds) -> - let - specid_maybe_maybe = isSpecPragmaId_maybe binder - is_specid = maybeToBool specid_maybe_maybe - Just specinfo_maybe = specid_maybe_maybe - specid_with_info = maybeToBool specinfo_maybe - Just spec_info = specinfo_maybe - - -- If we have a SpecInfo stored in a SpecPragmaId binder - -- it will contain a SpecInfo with an explicit SpecId - -- We add the explicit ci to the usage details - -- Any ordinary cis for orig_id (there should only be one) - -- will be ignored later - - pragma_uds - = if is_specid && specid_with_info then - let - (SpecInfo spec_tys _ spec_id) = spec_info - Just (orig_id, _) = isSpecId_maybe spec_id - in - ASSERT(toplevelishId orig_id) -- must not be cloned! - explicitCI orig_id spec_tys spec_info - else - emptyUDs - - -- For a local binding we dump the usage details, creating - -- any local dict bindings required - -- At the top-level the uds will be dumped in specBindAndScope - -- and the dict bindings made *global* - - (local_dict_binds, final_uds) - = if not top_lev then - dumpUDs rhs_uds False floating inst_cis new_binders [] - else - ([], rhs_uds) - in - case blookup of - Lifted lift_binder unlift_binder - -> -- We may need to record an unboxed instance of - -- the _Lift data type in the usage details - mkTyConInstance liftDataCon [idType unlift_binder] - `thenSM` \ lift_uds -> - returnSM ((lift_binder, - mkCoLetsNoUnboxed local_dict_binds (liftExpr unlift_binder rhs)), - final_uds `unionUDs` pragma_uds `unionUDs` lift_uds) - - NoLift (VarArg binder) - -> returnSM ((binder, mkCoLetsNoUnboxed local_dict_binds rhs), - final_uds `unionUDs` pragma_uds) -\end{code} - - -%************************************************************************ -%* * -\subsection{@instBind@} -%* * -%************************************************************************ - -\begin{code} -instBind top_lev new_ids@(first_binder:other_binders) bind equiv_ciss inst_cis - | null equiv_ciss - = returnSM ([], emptyUDs, []) - - | all same_overloading other_binders - = -- For each call_inst, build an instance - mapAndUnzip3SM do_this_class equiv_ciss - `thenSM` \ (inst_binds, inst_uds_s, spec_infos) -> - - -- Add in the remaining UDs - returnSM (catMaybes inst_binds, - unionUDList inst_uds_s, - spec_infos - ) - - | otherwise -- Incompatible overloadings; see below by same_overloading - = (if not (null (filter isUnboxedCI (concat equiv_ciss))) - then pprTrace "dumpCIs: not same overloading ... WITH UNBOXED TYPES!\n" - else if top_lev - then pprTrace "dumpCIs: not same overloading ... top level \n" - else (\ x y -> y) - ) (hang (hcat [ptext SLIT("{"), - interppSP new_ids, - ptext SLIT("}")]) - 4 (vcat [vcat (map (pprGenType . idType) new_ids), - vcat (map pprCI (concat equiv_ciss))])) - (returnSM ([], emptyUDs, [])) - - where - (tyvar_tmpls, class_tyvar_pairs) = getIdOverloading first_binder - tyvar_tmpl_tys = mkTyVarTys tyvar_tmpls - - no_of_tyvars = length tyvar_tmpls - no_of_dicts = length class_tyvar_pairs - - do_this_class equiv_cis - = mkOneInst do_cis explicit_cis no_of_dicts top_lev inst_cis new_ids bind - where - (explicit_cis, normal_cis) = partition isExplicitCI equiv_cis - do_cis = head (normal_cis ++ explicit_cis) - -- must choose a normal_cis in preference since dict_args will - -- not be defined for an explicit_cis - - -- same_overloading tests whether the types of all the binders - -- are "compatible"; ie have the same type and dictionary abstractions - -- Almost always this is the case, because a recursive group is abstracted - -- all together. But, it can happen that it ain't the case, because of - -- code generated from instance decls: - -- - -- rec - -- dfun.Foo.Int :: (forall a. a -> Int, Int) - -- dfun.Foo.Int = (const.op1.Int, const.op2.Int) - -- - -- const.op1.Int :: forall a. a -> Int - -- const.op1.Int a = defm.Foo.op1 Int a dfun.Foo.Int - -- - -- const.op2.Int :: Int - -- const.op2.Int = 3 - -- - -- Note that the first two defns have different polymorphism, but they are - -- mutually recursive! - - same_overloading :: Id -> Bool - same_overloading id - = no_of_tyvars == length this_id_tyvars - -- Same no of tyvars - && no_of_dicts == length this_id_class_tyvar_pairs - -- Same no of vdicts - && and (zipWith same_ov class_tyvar_pairs this_id_class_tyvar_pairs) - && length class_tyvar_pairs == length this_id_class_tyvar_pairs - -- Same overloading - where - (this_id_tyvars, this_id_class_tyvar_pairs) = getIdOverloading id - tyvar_pairs = this_id_tyvars `zip` tyvar_tmpls - - same_ov (clas1,tyvar1) (clas2,tyvar2) - = clas1 == clas2 && - tyvar1 == assoc "same_overloading" tyvar_pairs tyvar2 -\end{code} - -OK, so we have: - - a call instance eg f [t1,t2,t3] [d1,d2] - - the rhs of the function eg orig_rhs - - a constraint vector, saying which of eg [T,F,T] - the functions type args are constrained - (ie overloaded) - -We return a new definition - - $f1 = /\a -> orig_rhs t1 a t3 d1 d2 - -The SpecInfo for f will be: - - SpecInfo [t1, a, t3] (\d1 d2 -> $f1 a) - -Based on this SpecInfo, a call instance of f - - ...(f t1 t2 t3)... - -should get replaced by - - ...(\d1 d2 -> $f1 t2)... - -(But that is the business of the simplifier.) - -\begin{code} -mkOneInst :: CallInstance - -> [CallInstance] -- Any explicit cis for this inst - -> Int -- No of dicts to specialise - -> Bool -- Top level binders? - -> [CallInstance] -- Instantiated call insts for binders - -> [Id] -- New binders - -> CoreBinding -- Unprocessed - -> SpecM (Maybe CoreBinding, -- Instantiated version of input - UsageDetails, - [Maybe SpecInfo] -- One for each id in the original binding - ) - -mkOneInst do_cis@(CallInstance _ spec_tys dict_args _ _) explicit_cis - no_of_dicts_to_specialise top_lev inst_cis new_ids orig_bind - = newSpecIds new_ids spec_tys no_of_dicts_to_specialise - `thenSM` \ spec_ids -> - newTyVars (length [() | Nothing <- spec_tys]) `thenSM` \ poly_tyvars -> - let - -- arg_tys is spec_tys with tyvars instead of the Nothing spec_tys - -- which correspond to unspecialised args - arg_tys :: [Type] - (_,arg_tys) = mapAccumL do_the_wotsit poly_tyvars spec_tys - - args :: [CoreArg] - args = map TyArg arg_tys ++ dict_args - - (new_id:_) = new_ids - (spec_id:_) = spec_ids - - do_bind (NonRec orig_id rhs) - = do_one_rhs (spec_id, new_id, (orig_id,rhs)) - `thenSM` \ (maybe_spec, rhs_uds, spec_info) -> - case maybe_spec of - Just (spec_id, rhs) -> returnSM (Just (NonRec spec_id rhs), rhs_uds, [spec_info]) - Nothing -> returnSM (Nothing, rhs_uds, [spec_info]) - - do_bind (Rec pairs) - = mapAndUnzip3SM do_one_rhs (zip3 spec_ids new_ids pairs) - `thenSM` \ (maybe_pairs, rhss_uds_s, spec_infos) -> - returnSM (Just (Rec (catMaybes maybe_pairs)), - unionUDList rhss_uds_s, spec_infos) - - do_one_rhs (spec_id, new_id, (orig_id, orig_rhs)) - - -- Avoid duplicating a spec which has already been created ... - -- This can arise in a Rec involving a dfun for which a - -- a specialised instance has been created but specialisation - -- "required" by one of the other Ids in the Rec - | top_lev && maybeToBool lookup_orig_spec - = (if opt_SpecialiseTrace - then trace_nospec " Exists: " orig_id - else id) ( - - returnSM (Nothing, emptyUDs, Nothing) - ) - - -- Check for a (single) explicit call instance for this id - | not (null explicit_cis_for_this_id) - = ASSERT (length explicit_cis_for_this_id == 1) - (if opt_SpecialiseTrace - then trace_nospec " Explicit: " explicit_id - else id) ( - - returnSM (Nothing, tickSpecInsts emptyUDs, Just explicit_spec_info) - ) - - -- Apply the specialiser to (orig_rhs t1 a t3 d1 d2) - | otherwise - = ASSERT (no_of_dicts_to_specialise == length dict_args) - specExpr orig_rhs args `thenSM` \ (inst_rhs, inst_uds) -> - let - -- For a local binding we dump the usage details, creating - -- any local dict bindings required - -- At the top-level the uds will be dumped in specBindAndScope - -- and the dict bindings made *global* - - (local_dict_binds, final_uds) - = if not top_lev then - dumpUDs inst_uds False False inst_cis new_ids [] - else - ([], inst_uds) - - spec_info = Just (SpecInfo spec_tys no_of_dicts_to_specialise spec_id) - in - if isUnboxedType (idType spec_id) then - ASSERT (null poly_tyvars) - liftId spec_id `thenSM` \ (lift_spec_id, unlift_spec_id) -> - mkTyConInstance liftDataCon [idType unlift_spec_id] - `thenSM` \ lift_uds -> - returnSM (Just (lift_spec_id, - mkCoLetsNoUnboxed local_dict_binds (liftExpr unlift_spec_id inst_rhs)), - tickSpecInsts (final_uds `unionUDs` lift_uds), spec_info) - else - returnSM (Just (spec_id, - mkCoLetsNoUnboxed local_dict_binds (mkTyLam poly_tyvars inst_rhs)), - tickSpecInsts final_uds, spec_info) - where - lookup_orig_spec = matchSpecEnv (getIdSpecialisation orig_id) arg_tys - - explicit_cis_for_this_id = filter (isCIofTheseIds [new_id]) explicit_cis - [CallInstance _ _ _ _ (Just explicit_spec_info)] = explicit_cis_for_this_id - SpecInfo _ _ explicit_id = explicit_spec_info - - trace_nospec :: String -> Id -> a -> a - trace_nospec str spec_id - = pprTrace str - (hsep [ppr new_id, hsep (map pp_ty arg_tys), - ptext SLIT("==>"), ppr spec_id]) - in - (if opt_SpecialiseTrace then - pprTrace "Specialising:" - (hang (hcat [char '{', - interppSP new_ids, - char '}']) - 4 (vcat [ - hcat [ptext SLIT("types: "), hsep (map pp_ty arg_tys)], - if isExplicitCI do_cis then empty else - hcat [ptext SLIT("dicts: "), hsep (map pp_dict dict_args)], - hcat [ptext SLIT("specs: "), ppr spec_ids]])) - else id) ( - - do_bind orig_bind `thenSM` \ (maybe_inst_bind, inst_uds, spec_infos) -> - - returnSM (maybe_inst_bind, inst_uds, spec_infos) + (new_spec_env, errs) = foldr add (getIdSpecialisation id, []) spec_stuff + + add (tys, template) (spec_env, errs) + = case addToSpecEnv spec_env tys (occurAnalyseGlobalExpr template) of + Succeeded spec_env' -> (spec_env', errs) + Failed err -> (spec_env, err:errs) + +---------------------------------------- +type SpecM a = UniqSM a + +thenSM = thenUs +returnSM = returnUs +getUniqSM = getUnique +mapSM = mapUs +initSM = initUs + +mapAndCombineSM f [] = returnSM ([], emptyUDs) +mapAndCombineSM f (x:xs) = f x `thenSM` \ (y, uds1) -> + mapAndCombineSM f xs `thenSM` \ (ys, uds2) -> + returnSM (y:ys, uds1 `plusUDs` uds2) + +newIdSM old_id new_ty + = getUnique `thenSM` \ uniq -> + returnSM (mkUserLocal (getOccName old_id) + uniq + new_ty + (getSrcLoc old_id) ) - where - pp_dict d = ppr_arg d - pp_ty t = pprParendGenType t - - do_the_wotsit (tyvar:tyvars) Nothing = (tyvars, mkTyVarTy tyvar) - do_the_wotsit tyvars (Just ty) = (tyvars, ty) - \end{code} -%************************************************************************ -%* * -\subsection[Misc]{Miscellaneous junk} -%* * -%************************************************************************ - -\begin{code} -mkCallInstance :: Id - -> Id - -> [CoreArg] - -> SpecM UsageDetails - -mkCallInstance id new_id args - | null args || -- No args at all - idWantsToBeINLINEd id || -- It's going to be inlined anyway - not enough_args || -- Not enough type and dict args - not interesting_overloading -- Overloaded types are just tyvars - = returnSM emptyUDs - - | otherwise - = returnSM (singleCI new_id spec_tys dicts) - - where - (tyvars, theta, _) = splitSigmaTy (idType id) - constrained_tyvars = tyvarsOfTypes (map snd class_tyvar_pairs) - - arg_res = take_type_args tyvars class_tyvar_pairs args - enough_args = maybeToBool arg_res - (Just (tys, dicts, rest_args)) = arg_res - - interesting_overloading = not (null (catMaybes spec_tys)) - spec_tys = zipWithEqual "spec_ty" spec_ty tyvars tys - - --------------------------------------------------------------- - -- Should we specialise on this type argument? - spec_ty tyvar ty | isTyVarTy ty = Nothing - - spec_ty tyvar ty | opt_SpecialiseAll - || (opt_SpecialiseUnboxed - && isUnboxedType ty - && isBoxedTypeKind (tyVarKind tyvar)) - || (opt_SpecialiseOverloaded - && tyvar `elemTyVarSet` constrained_tyvars) - = Just ty - - | otherwise = Nothing - - ----------------- Rather a gruesome help-function --------------- - take_type_args (_:tyvars) (TyArg ty : args) - = case (take_type_args tyvars args) of - Nothing -> Nothing - Just (tys, dicts, others) -> Just (ty:tys, dicts, others) - - take_type_args (_:tyvars) [] = Nothing - - take_type_args [] args - = case (take_dict_args class_tyvar_pairs args) of - Nothing -> Nothing - Just (dicts, others) -> Just ([], dicts, others) - - take_dict_args (_:class_tyvar_pairs) (dict : args) | isValArg dict - = case (take_dict_args class_tyvar_pairs args) of - Nothing -> Nothing - Just (dicts, others) -> Just (dict:dicts, others) - - take_dict_args (_:class_tyvar_pairs) args = Nothing - - take_dict_args [] args = Just ([], args) -\end{code} - - -\begin{code} -mkTyConInstance :: Id - -> [Type] - -> SpecM UsageDetails -mkTyConInstance con tys - = recordTyConInst con tys `thenSM` \ record_inst -> - case record_inst of - Nothing -- No TyCon instance - -> -- pprTrace "NoTyConInst:" - -- (hsep [ppr tycon, ptext SLIT("at"), - -- ppr con, hsep (map (ppr) tys)]) - (returnSM (singleConUDs con)) - - Just spec_tys -- Record TyCon instance - -> -- pprTrace "TyConInst:" - -- (hsep [ppr tycon, ptext SLIT("at"), - -- ppr con, hsep (map (ppr) tys), - -- hcat [char '(', - -- hsep [pprMaybeTy ty | ty <- spec_tys], - -- char ')']]) - (returnSM (singleTyConI tycon spec_tys `unionUDs` singleConUDs con)) - where - tycon = dataConTyCon con -\end{code} - -\begin{code} -recordTyConInst :: Id - -> [Type] - -> SpecM (Maybe [Maybe Type]) - -recordTyConInst con tys - = let - spec_tys = specialiseConstrTys tys - - do_tycon_spec = maybeToBool (firstJust spec_tys) - - spec_exists = maybeToBool (lookupSpecEnv - (getIdSpecialisation con) - tys) - in - -- pprTrace "ConSpecExists?: " - -- (vcat [ptext (if spec_exists then SLIT("True") else SLIT("False")), - -- ppr PprShowAll con, hsep (map ppr tys)]) - (if (not spec_exists && do_tycon_spec) - then returnSM (Just spec_tys) - else returnSM Nothing) -\end{code} - -%************************************************************************ -%* * -\subsection[monad-Specialise]{Monad used in specialisation} -%* * -%************************************************************************ - -Monad has: - - inherited: control flags and - recordInst functions with flags cached - - environment mapping tyvars to types - environment mapping Ids to Atoms - - threaded in and out: unique supply - -\begin{code} -type TypeEnv = TyVarEnv Type - -type SpecM result - = TypeEnv - -> SpecIdEnv - -> UniqSupply - -> result - -initSM m uniqs = m emptyTyVarEnv nullIdEnv uniqs - -returnSM :: a -> SpecM a -thenSM :: SpecM a -> (a -> SpecM b) -> SpecM b -fixSM :: (a -> SpecM a) -> SpecM a - -thenSM m k tvenv idenv us - = case splitUniqSupply us of { (s1, s2) -> - case (m tvenv idenv s1) of { r -> - k r tvenv idenv s2 }} - -returnSM r tvenv idenv us = r - -fixSM k tvenv idenv us - = r - where - r = k r tvenv idenv us -- Recursive in r! -\end{code} - -The only interesting bit is figuring out the type of the SpecId! - -\begin{code} -newSpecIds :: [Id] -- The id of which to make a specialised version - -> [Maybe Type] -- Specialise to these types - -> Int -- No of dicts to specialise - -> SpecM [Id] - -newSpecIds new_ids maybe_tys dicts_to_ignore tvenv idenv us - = [ mkSpecId uniq id maybe_tys (spec_id_ty id) (selectIdInfoForSpecId id) - | (id,uniq) <- zipEqual "newSpecIds" new_ids uniqs ] - where - uniqs = getUniques (length new_ids) us - spec_id_ty id = specialiseTy (idType id) maybe_tys dicts_to_ignore - -newTyVars :: Int -> SpecM [TyVar] -newTyVars n tvenv idenv us - = [mkSysTyVar uniq mkBoxedTypeKind | uniq <- getUniques n us] -\end{code} - -@cloneLambdaOrCaseBinders@ and @cloneLetBinders@ take a bunch of -binders, and build ``clones'' for them. The clones differ from the -originals in three ways: - - (a) they have a fresh unique - (b) they have the current type environment applied to their type - (c) for Let binders which have been specialised to unboxed values - the clone will have a lifted type - -As well as returning the list of cloned @Id@s they also return a list of -@CloneInfo@s which the original binders should be bound to. - -\begin{code} -cloneLambdaOrCaseBinders :: [Id] -- Old binders - -> SpecM ([Id], [CloneInfo]) -- New ones -cloneLambdaOrCaseBinders old_ids tvenv idenv us - = let - uniqs = getUniques (length old_ids) us - in - unzip (zipWithEqual "cloneLambdaOrCaseBinders" clone_it old_ids uniqs) - where - clone_it old_id uniq - = (new_id, NoLift (VarArg new_id)) - where - new_id = applyTypeEnvToId tvenv (mkIdWithNewUniq old_id uniq) - -cloneLetBinders :: Bool -- Top level ? - -> Bool -- Recursice - -> [Id] -- Old binders - -> SpecM ([Id], [CloneInfo]) -- New ones - -cloneLetBinders top_lev is_rec old_ids tvenv idenv us - = let - uniqs = getUniques (2 * length old_ids) us - in - unzip (clone_them old_ids uniqs) - where - clone_them [] [] = [] - - clone_them (old_id:olds) (u1:u2:uniqs) - | top_lev - = (old_id, - NoLift (VarArg old_id)) : clone_rest - - -- Don't clone if it is a top-level thing. Why not? - -- (a) we don't want to change the uniques - -- on such things - -- (b) we don't have to be paranoid about name capture - -- (c) the thing is polymorphic so no need to subst - - | otherwise - = if (is_rec && isUnboxedType new_ty && not (isUnboxedType old_ty)) - then (lifted_id, - Lifted lifted_id unlifted_id) : clone_rest - else (new_id, - NoLift (VarArg new_id)) : clone_rest - - where - clone_rest = clone_them olds uniqs - - new_id = applyTypeEnvToId tvenv (mkIdWithNewUniq old_id u1) - new_ty = idType new_id - old_ty = idType old_id - - (lifted_id, unlifted_id) = mkLiftedId new_id u2 - - -cloneTyVarSM :: TyVar -> SpecM TyVar - -cloneTyVarSM old_tyvar tvenv idenv us - = let - uniq = getUnique us - in - cloneTyVar old_tyvar uniq -- new_tyvar - -bindId :: Id -> CloneInfo -> SpecM thing -> SpecM thing - -bindId id val specm tvenv idenv us - = specm tvenv (addOneToIdEnv idenv id val) us - -bindIds :: [Id] -> [CloneInfo] -> SpecM thing -> SpecM thing - -bindIds olds news specm tvenv idenv us - = specm tvenv (growIdEnvList idenv (zip olds news)) us - -bindSpecIds :: [Id] -- Old - -> [(CloneInfo)] -- New - -> [[Maybe SpecInfo]] -- Corresponding specialisations - -- Each sub-list corresponds to a different type, - -- and contains one Maybe spec_info for each id - -> SpecM thing - -> SpecM thing - -bindSpecIds olds clones spec_infos specm tvenv idenv us - = specm tvenv (growIdEnvList idenv old_to_clone) us - where - old_to_clone = mk_old_to_clone olds clones spec_infos - - -- The important thing here is that we are *lazy* in spec_infos - mk_old_to_clone [] [] _ = [] - mk_old_to_clone (old:rest_olds) (clone:rest_clones) spec_infos - = (old, add_spec_info clone) : - mk_old_to_clone rest_olds rest_clones spec_infos_rest - where - add_spec_info (NoLift (VarArg new)) - = NoLift (VarArg (new `addIdSpecialisation` (mkSpecEnv spec_infos_this_id))) - add_spec_info lifted - = lifted -- no specialised instances for unboxed lifted values - - spec_infos_this_id = catMaybes (map head spec_infos) - spec_infos_rest = map tail spec_infos - - -bindTyVar :: TyVar -> Type -> SpecM thing -> SpecM thing - -bindTyVar tyvar ty specm tvenv idenv us - = specm (growTyVarEnvList tvenv [(tyvar,ty)]) idenv us -\end{code} - -\begin{code} -lookupId :: Id -> SpecM CloneInfo - -lookupId id tvenv idenv us - = case lookupIdEnv idenv id of - Nothing -> NoLift (VarArg id) - Just info -> info -\end{code} - -\begin{code} -specTy :: Type -> SpecM Type -- Apply the current type envt to the type - -specTy ty tvenv idenv us - = instantiateTy tvenv ty -\end{code} - -\begin{code} -liftId :: Id -> SpecM (Id, Id) -liftId id tvenv idenv us - = let - uniq = getUnique us - in - mkLiftedId id uniq -\end{code} - -In other monads these @mapSM@ things are usually called @listM@. -I think @mapSM@ is a much better name. The `2' and `3' variants are -when you want to return two or three results, and get at them -separately. It saves you having to do an (unzip stuff) right after. - -\begin{code} -mapSM :: (a -> SpecM b) -> [a] -> SpecM [b] -mapAndUnzipSM :: (a -> SpecM (b1, b2)) -> [a] -> SpecM ([b1],[b2]) -mapAndUnzip3SM :: (a -> SpecM (b1, b2, b3)) -> [a] -> SpecM ([b1],[b2],[b3]) -mapAndUnzip4SM :: (a -> SpecM (b1, b2, b3, b4)) -> [a] -> SpecM ([b1],[b2],[b3],[b4]) - -mapSM f [] = returnSM [] -mapSM f (x:xs) = f x `thenSM` \ r -> - mapSM f xs `thenSM` \ rs -> - returnSM (r:rs) - -mapAndUnzipSM f [] = returnSM ([],[]) -mapAndUnzipSM f (x:xs) = f x `thenSM` \ (r1, r2) -> - mapAndUnzipSM f xs `thenSM` \ (rs1,rs2) -> - returnSM ((r1:rs1),(r2:rs2)) - -mapAndUnzip3SM f [] = returnSM ([],[],[]) -mapAndUnzip3SM f (x:xs) = f x `thenSM` \ (r1,r2,r3) -> - mapAndUnzip3SM f xs `thenSM` \ (rs1,rs2,rs3) -> - returnSM ((r1:rs1),(r2:rs2),(r3:rs3)) - -mapAndUnzip4SM f [] = returnSM ([],[],[],[]) -mapAndUnzip4SM f (x:xs) = f x `thenSM` \ (r1,r2,r3,r4) -> - mapAndUnzip4SM f xs `thenSM` \ (rs1,rs2,rs3,rs4) -> - returnSM ((r1:rs1),(r2:rs2),(r3:rs3),(r4:rs4)) --} -\end{code} - - - -===================== OLD CODE, scheduled for deletion ================= - -\begin{code} -{- -mkCall :: Id - -> [(CoreArg, UsageDetails, CoreExpr -> CoreExpr)] - -> SpecM CoreExpr - -mkCall new_id arg_infos = returnSM ( - - | maybeToBool (isSuperDictSelId_maybe new_id) - && any isUnboxedType ty_args - -- No specialisations for super-dict selectors - -- Specialise unboxed calls to SuperDictSelIds by extracting - -- the super class dictionary directly form the super class - -- NB: This should be dead code since all uses of this dictionary should - -- have been specialised. We only do this to keep core-lint happy. - = let - Just (_, super_class) = isSuperDictSelId_maybe new_id - super_dict_id = case lookupClassInstAtSimpleType super_class (head ty_args) of - Nothing -> panic "Specialise:mkCall:SuperDictId" - Just id -> id - in - returnSM (False, Var super_dict_id) - - | otherwise - = case lookupSpecEnv (getIdSpecialisation new_id) ty_args of - Nothing -> checkUnspecOK new_id ty_args ( - returnSM (False, unspec_call) - ) - - Just spec_1_details@(spec_id_1, tys_left_1, dicts_to_toss_1) - -> let - -- It may be necessary to specialsie a constant method spec_id again - (spec_id, tys_left, dicts_to_toss) = - case (maybeToBool (isConstMethodId_maybe spec_id_1), - lookupSpecEnv (getIdSpecialisation spec_id_1) tys_left_1) of - (False, _ ) -> spec_1_details - (True, Nothing) -> spec_1_details - (True, Just (spec_id_2, tys_left_2, dicts_to_toss_2)) - -> (spec_id_2, tys_left_2, dicts_to_toss_1 + dicts_to_toss_2) - - args_left = toss_dicts dicts_to_toss val_args - in - checkSpecOK new_id ty_args spec_id tys_left ( - - -- The resulting spec_id may be a top-level unboxed value - -- This can arise for: - -- 1) constant method values - -- eq: class Num a where pi :: a - -- instance Num Double# where pi = 3.141# - -- 2) specilised overloaded values - -- eq: i1 :: Num a => a - -- i1 Int# d.Num.Int# ==> i1.Int# - -- These top level defns should have been lifted. - -- We must add code to unlift such a spec_id. - - if isUnboxedType (idType spec_id) then - ASSERT (null tys_left && null args_left) - if toplevelishId spec_id then - liftId spec_id `thenSM` \ (lift_spec_id, unlift_spec_id) -> - returnSM (True, bindUnlift lift_spec_id unlift_spec_id - (Var unlift_spec_id)) - else - pprPanic "Specialise:mkCall: unboxed spec_id not top-level ...\n" - (hsep [ppr new_id, - hsep (map (pprParendGenType) ty_args), - ptext SLIT("==>"), - ppr spec_id]) - else - let - (vals_left, _, unlifts_left) = unzip3 args_left - applied_tys = mkTyApp (Var spec_id) tys_left - applied_vals = mkGenApp applied_tys vals_left - in - returnSM (True, applyBindUnlifts unlifts_left applied_vals) - ) - where - (tys_and_vals, _, unlifts) = unzip3 args - unspec_call = applyBindUnlifts unlifts (mkGenApp (Var new_id) tys_and_vals) - - - -- ty_args is the types at the front of the arg list - -- val_args is the rest of the arg-list - - (ty_args, val_args) = get args - where - get ((TyArg ty,_,_) : args) = (ty : tys, rest) where (tys,rest) = get args - get args = ([], args) - - - -- toss_dicts chucks away dict args, checking that they ain't types! - toss_dicts 0 args = args - toss_dicts n ((a,_,_) : args) - | isValArg a = toss_dicts (n-1) args - -\end{code} - -\begin{code} -checkUnspecOK :: Id -> [Type] -> a -> a -checkUnspecOK check_id tys - = if isLocallyDefined check_id && any isUnboxedType tys - then pprPanic "Specialise:checkUnspecOK: unboxed instance for local id not found\n" - (hsep [ppr check_id, - hsep (map (pprParendGenType) tys)]) - else id - -checkSpecOK :: Id -> [Type] -> Id -> [Type] -> a -> a -checkSpecOK check_id tys spec_id tys_left - = if any isUnboxedType tys_left - then pprPanic "Specialise:checkSpecOK: unboxed type args in specialised application\n" - (vcat [hsep [ppr check_id, - hsep (map (pprParendGenType) tys)], - hsep [ppr spec_id, - hsep (map (pprParendGenType) tys_left)]]) - else id --} -\end{code} diff --git a/ghc/compiler/stranal/WwLib.lhs b/ghc/compiler/stranal/WwLib.lhs index 8ef584a..237667a 100644 --- a/ghc/compiler/stranal/WwLib.lhs +++ b/ghc/compiler/stranal/WwLib.lhs @@ -29,7 +29,7 @@ import BasicTypes ( NewOrData(..) ) import TyVar ( TyVar ) import PprType ( GenType, GenTyVar ) import UniqSupply ( returnUs, thenUs, getUniques, getUnique, UniqSM ) -import Util ( zipEqual ) +import Util ( zipEqual, zipWithEqual ) import Outputable \end{code} @@ -241,7 +241,9 @@ mkWrapper fun_ty demands -- and as such might have some strictness info attached. -- Then we need to have enough args to zip to the strictness info - wrap_args = zipWith mk_ww_local wrap_uniqs arg_tys + wrap_args = ASSERT( n_wrap_args <= length arg_tys ) + zipWith mk_ww_local wrap_uniqs arg_tys + leftover_arg_tys = drop n_wrap_args arg_tys final_body_ty = mkFunTys leftover_arg_tys body_ty in diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 0bd6e24..5176fde 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -139,23 +139,23 @@ Primitive literals: \begin{code} tcExpr (HsLit lit@(HsCharPrim c)) res_ty - = unifyTauTy charPrimTy res_ty `thenTc_` + = unifyTauTy res_ty charPrimTy `thenTc_` returnTc (HsLitOut lit charPrimTy, emptyLIE) tcExpr (HsLit lit@(HsStringPrim s)) res_ty - = unifyTauTy addrPrimTy res_ty `thenTc_` + = unifyTauTy res_ty addrPrimTy `thenTc_` returnTc (HsLitOut lit addrPrimTy, emptyLIE) tcExpr (HsLit lit@(HsIntPrim i)) res_ty - = unifyTauTy intPrimTy res_ty `thenTc_` + = unifyTauTy res_ty intPrimTy `thenTc_` returnTc (HsLitOut lit intPrimTy, emptyLIE) tcExpr (HsLit lit@(HsFloatPrim f)) res_ty - = unifyTauTy floatPrimTy res_ty `thenTc_` + = unifyTauTy res_ty floatPrimTy `thenTc_` returnTc (HsLitOut lit floatPrimTy, emptyLIE) tcExpr (HsLit lit@(HsDoublePrim d)) res_ty - = unifyTauTy doublePrimTy res_ty `thenTc_` + = unifyTauTy res_ty doublePrimTy `thenTc_` returnTc (HsLitOut lit doublePrimTy, emptyLIE) \end{code} @@ -163,11 +163,11 @@ Unoverloaded literals: \begin{code} tcExpr (HsLit lit@(HsChar c)) res_ty - = unifyTauTy charTy res_ty `thenTc_` + = unifyTauTy res_ty charTy `thenTc_` returnTc (HsLitOut lit charTy, emptyLIE) tcExpr (HsLit lit@(HsString str)) res_ty - = unifyTauTy stringTy res_ty `thenTc_` + = unifyTauTy res_ty stringTy `thenTc_` returnTc (HsLitOut lit stringTy, emptyLIE) \end{code} @@ -241,7 +241,7 @@ tcExpr in_expr@(SectionR op expr) res_ty tcAddErrCtxt (sectionRAppCtxt in_expr) $ split_fun_ty op_ty 2 {- two args -} `thenTc` \ ([arg1_ty, arg2_ty], op_res_ty) -> tcExpr expr arg2_ty `thenTc` \ (expr',lie2) -> - unifyTauTy (mkFunTy arg1_ty op_res_ty) res_ty `thenTc_` + unifyTauTy res_ty (mkFunTy arg1_ty op_res_ty) `thenTc_` returnTc (SectionR op' expr', lie1 `plusLIE` lie2) \end{code} @@ -280,7 +280,7 @@ tcExpr (CCall lbl args may_gc is_asm ignored_fake_result_ty) res_ty io_result_ty = mkTyConApp ioTyCon [result_ty] in case tyConDataCons ioTyCon of { [ioDataCon] -> - unifyTauTy io_result_ty res_ty `thenTc_` + unifyTauTy res_ty io_result_ty `thenTc_` -- Construct the extra insts, which encode the -- constraints on the argument and result types. @@ -589,7 +589,7 @@ tcExpr in_expr@(ExprWithTySig expr poly_ty) res_ty -- mention variables free in the environment, and we'd get -- bogus complaints about not being able to for-all the -- sig_tyvars - unifyTauTy sig_tau' res_ty `thenTc_` + unifyTauTy res_ty sig_tau' `thenTc_` -- If everything is ok, return the stuff unchanged, except for -- the effect of any substutions etc. We simply discard the @@ -831,7 +831,7 @@ tcDoStmts do_or_lc stmts src_loc res_ty combine_stmts stmt _ (stmts, ty) = (stmt:stmts, ty) in tc_stmts stmts `thenTc` \ ((stmts', result_ty), final_lie) -> - unifyTauTy result_ty res_ty `thenTc_` + unifyTauTy res_ty result_ty `thenTc_` -- Build the then and zero methods in case we need them -- It's important that "then" and "return" appear just once in the final LIE, diff --git a/ghc/compiler/utils/Bag.lhs b/ghc/compiler/utils/Bag.lhs index 546ad2f..fe27061 100644 --- a/ghc/compiler/utils/Bag.lhs +++ b/ghc/compiler/utils/Bag.lhs @@ -10,7 +10,7 @@ module Bag ( emptyBag, unitBag, unionBags, unionManyBags, mapBag, elemBag, - filterBag, partitionBag, concatBag, foldBag, foldrBag, + filterBag, partitionBag, concatBag, foldBag, foldrBag, foldlBag, isEmptyBag, consBag, snocBag, listToBag, bagToList ) where @@ -130,6 +130,16 @@ foldrBag k z (TwoBags b1 b2) = foldrBag k (foldrBag k z b2) b1 foldrBag k z (ListBag xs) = foldr k z xs foldrBag k z (ListOfBags bs) = foldr (\b r -> foldrBag k r b) z bs +foldlBag :: (r -> a -> r) -> r + -> Bag a + -> r + +foldlBag k z EmptyBag = z +foldlBag k z (UnitBag x) = k z x +foldlBag k z (TwoBags b1 b2) = foldlBag k (foldlBag k z b1) b2 +foldlBag k z (ListBag xs) = foldl k z xs +foldlBag k z (ListOfBags bs) = foldl (\r b -> foldlBag k r b) z bs + mapBag :: (a -> b) -> Bag a -> Bag b mapBag f EmptyBag = EmptyBag diff --git a/ghc/compiler/utils/FiniteMap.lhs b/ghc/compiler/utils/FiniteMap.lhs index 432d4f2..cf08d7c 100644 --- a/ghc/compiler/utils/FiniteMap.lhs +++ b/ghc/compiler/utils/FiniteMap.lhs @@ -38,7 +38,7 @@ module FiniteMap ( intersectFM, intersectFM_C, - mapFM, filterFM, + mapFM, filterFM, sizeFM, isEmptyFM, elemFM, lookupFM, lookupWithDefaultFM, @@ -139,6 +139,7 @@ mapFM :: (key -> elt1 -> elt2) -> FiniteMap key elt1 -> FiniteMap key elt2 filterFM :: (Ord key OUTPUTABLE_key) => (key -> elt -> Bool) -> FiniteMap key elt -> FiniteMap key elt + -- INTERROGATING sizeFM :: FiniteMap key elt -> Int isEmptyFM :: FiniteMap key elt -> Bool -- 1.7.10.4