X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fspecialise%2FSpecialise.lhs;h=d49604adaace60054d4840b3c056062186a8882f;hb=2494407a750053daa61718fac371487d04818e57;hp=e96941a549f9560ba109e53b7d5dd3118e53da81;hpb=0596517a9b4b2b32e5d375a986351102ac4540fc;p=ghc-hetmet.git diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs index e96941a..d49604a 100644 --- a/ghc/compiler/specialise/Specialise.lhs +++ b/ghc/compiler/specialise/Specialise.lhs @@ -10,30 +10,90 @@ module Specialise ( specProgram, initSpecData, - SpecialiseData(..), - FiniteMap, Bag - + SpecialiseData(..) ) where -import SpecUtils +IMP_Ubiq(){-uitous-} +IMPORT_1_3(List(partition)) -import PrelInfo ( liftDataCon, PrimOp(..), PrimRep -- for CCallOp - IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) - IF_ATTACK_PRAGMAS(COMMA pprPrimOp) +import Bag ( emptyBag, unitBag, isEmptyBag, unionBags, + partitionBag, listToBag, bagToList + ) +import Class ( GenClass{-instance Eq-} ) +import CmdLineOpts ( opt_SpecialiseImports, opt_D_simplifier_stats, + opt_CompilingGhcInternals, opt_SpecialiseTrace ) -import Type -import Bag -import CmdLineOpts ( GlobalSwitch(..) ) import CoreLift ( mkLiftedId, liftExpr, bindUnlift, applyBindUnlifts ) -import FiniteMap -import Id -import IdInfo -- All of it -import Maybes ( catMaybes, firstJust, maybeToBool, Maybe(..) ) -import UniqSet -- All of it -import Util -import UniqSupply +import CoreSyn +import CoreUtils ( coreExprType, squashableDictishCcExpr ) +import FiniteMap ( addListToFM_C, FiniteMap ) +import Kind ( mkBoxedTypeKind ) +import Id ( idType, isDefaultMethodId_maybe, toplevelishId, + isSuperDictSelId_maybe, isBottomingId, + isConstMethodId_maybe, isDataCon, + isImportedId, mkIdWithNewUniq, + dataConTyCon, applyTypeEnvToId, + nullIdEnv, addOneToIdEnv, growIdEnvList, + lookupIdEnv, SYN_IE(IdEnv), + emptyIdSet, mkIdSet, unitIdSet, + elementOfIdSet, minusIdSet, + unionIdSets, unionManyIdSets, SYN_IE(IdSet), + GenId{-instance Eq-} + ) +import Literal ( Literal{-instance Outputable-} ) +import Maybes ( catMaybes, firstJust, maybeToBool ) +import Name ( isLocallyDefined ) +import Outputable ( interppSP, Outputable(..){-instance * []-} ) +import PprStyle ( PprStyle(..) ) +import PprType ( pprGenType, pprParendGenType, pprMaybeTy, + GenType{-instance Outputable-}, GenTyVar{-ditto-}, + TyCon{-ditto-} + ) +import Pretty ( ppHang, ppCat, ppStr, ppAboves, ppBesides, ppPStr, ppChar, + ppInt, ppSP, ppInterleave, ppNil, SYN_IE(Pretty) + ) +import PrimOp ( PrimOp(..) ) +import SpecUtils +import Type ( mkTyVarTy, mkTyVarTys, isTyVarTy, getAppDataTyConExpandingDicts, + tyVarsOfTypes, applyTypeEnvToTy, isUnboxedType, isDictTy + ) +import TyCon ( TyCon{-instance Eq-} ) +import TyVar ( cloneTyVar, mkSysTyVar, + elementOfTyVarSet, SYN_IE(TyVarSet), + nullTyVarEnv, growTyVarEnvList, SYN_IE(TyVarEnv), + GenTyVar{-instance Eq-} + ) +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, panic, pprTrace, pprPanic, assertPanic + ) 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)" \end{code} %************************************************************************ @@ -614,34 +674,39 @@ strictness analyser deems the lifted binding strict. %************************************************************************ \begin{code} -type FreeVarsSet = UniqSet Id -type FreeTyVarsSet = UniqSet TyVar +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 + 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 -> Pretty pprCI (CallInstance id spec_tys dicts _ maybe_specinfo) - = ppHang (ppCat [ppStr "Call inst for", ppr PprDebug id]) + = ppHang (ppCat [ppPStr SLIT("Call inst for"), ppr PprDebug id]) 4 (ppAboves [ppCat (ppStr "types" : [pprMaybeTy PprDebug ty | ty <- spec_tys]), case maybe_specinfo of - Nothing -> ppCat (ppStr "dicts" : [ppr PprDebug dict | dict <- dicts]) + Nothing -> ppCat (ppStr "dicts" : [ppr_arg PprDebug dict | dict <- dicts]) Just (SpecInfo _ _ spec_id) - -> ppCat [ppStr "Explicit SpecId", ppr PprDebug spec_id] + -> ppCat [ppPStr SLIT("Explicit SpecId"), ppr PprDebug spec_id] ]) +-- ToDo: instance Outputable CoreArg? +ppr_arg sty (TyArg t) = ppr sty t +ppr_arg sty (LitArg i) = ppr sty i +ppr_arg sty (VarArg v) = ppr sty v + isUnboxedCI :: CallInstance -> Bool isUnboxedCI (CallInstance _ spec_tys _ _ _) - = any isUnboxedDataType (catMaybes spec_tys) + = any isUnboxedType (catMaybes spec_tys) isExplicitCI :: CallInstance -> Bool isExplicitCI (CallInstance _ _ _ _ (Just _)) @@ -656,7 +721,7 @@ Comparisons are based on the {\em types}, ignoring the dictionary args: cmpCI :: CallInstance -> CallInstance -> TAG_ cmpCI (CallInstance id1 tys1 _ _ _) (CallInstance id2 tys2 _ _ _) - = case (id1 `cmp` id2) of { EQ_ -> cmpUniTypeMaybeList tys1 tys2; other -> other } + = cmp id1 id2 `thenCmp` cmpUniTypeMaybeList tys1 tys2 cmpCI_tys :: CallInstance -> CallInstance -> TAG_ cmpCI_tys (CallInstance _ tys1 _ _ _) (CallInstance _ tys2 _ _ _) @@ -668,22 +733,22 @@ eqCI_tys c1 c2 isCIofTheseIds :: [Id] -> CallInstance -> Bool isCIofTheseIds ids (CallInstance ci_id _ _ _ _) - = any (eqId ci_id) ids + = any ((==) ci_id) ids singleCI :: Id -> [Maybe Type] -> [CoreArg] -> UsageDetails singleCI id tys dicts = UsageDetails (unitBag (CallInstance id tys dicts fv_set Nothing)) - emptyBag [] emptyUniqSet 0 0 + emptyBag [] emptyIdSet 0 0 where - fv_set = mkUniqSet (id : [dict | ValArg (VarArg dict) <- dicts]) + fv_set = mkIdSet (id : [dict | (VarArg dict) <- dicts]) explicitCI :: Id -> [Maybe Type] -> SpecInfo -> UsageDetails explicitCI id tys specinfo - = UsageDetails (unitBag call_inst) emptyBag [] emptyUniqSet 0 0 + = 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 = singletonUniqSet id + 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 @@ -703,7 +768,9 @@ getCIs top_lev ids (UsageDetails cis tycon_cis dbs fvs c i) cis_here_list = bagToList cis_here in -- pprTrace "getCIs:" - -- (ppHang (ppBesides [ppStr "{", ppr PprDebug ids, ppStr "}"]) + -- (ppHang (ppBesides [ppChar '{', + -- interppSP PprDebug ids, + -- ppChar '}']) -- 4 (ppAboves (map pprCI cis_here_list))) (cis_here_list, UsageDetails cis_not_here tycon_cis dbs fvs c i) @@ -730,10 +797,12 @@ dumpCIs cis top_lev floating inst_cis bound_ids full_ids then pprTrace ("dumpCIs: dumping CI which was not instantiated ... \n" ++ " (may be a non-HM recursive call)\n") - (ppHang (ppBesides [ppStr "{", ppr PprDebug bound_ids, ppStr "}"]) - 4 (ppAboves [ppStr "Dumping CIs:", + (ppHang (ppBesides [ppChar '{', + interppSP PprDebug bound_ids, + ppChar '}']) + 4 (ppAboves [ppPStr SLIT("Dumping CIs:"), ppAboves (map pprCI (bagToList cis_of_bound_id)), - ppStr "Instantiating CIs:", + ppPStr SLIT("Instantiating CIs:"), ppAboves (map pprCI inst_cis)])) else id) ( if top_lev || floating then @@ -741,7 +810,9 @@ dumpCIs cis top_lev floating inst_cis bound_ids full_ids else (if not (isEmptyBag cis_dump_unboxed) then pprTrace "dumpCIs: bound dictionary arg ... WITH UNBOXED TYPES!\n" - (ppHang (ppBesides [ppStr "{", ppr PprDebug full_ids, ppStr "}"]) + (ppHang (ppBesides [ppChar '{', + interppSP PprDebug full_ids, + ppChar '}']) 4 (ppAboves (map pprCI (bagToList cis_dump)))) else id) cis_keep_not_bound_id @@ -754,7 +825,7 @@ dumpCIs cis top_lev floating inst_cis bound_ids full_ids = partitionBag ok_to_dump_ci cis_not_bound_id ok_to_dump_ci (CallInstance _ _ _ fv_set _) - = or [i `elementOfUniqSet` fv_set | i <- full_ids] + = 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 @@ -795,7 +866,7 @@ data TyConInstance cmpTyConI :: TyConInstance -> TyConInstance -> TAG_ cmpTyConI (TyConInstance tc1 tys1) (TyConInstance tc2 tys2) - = case (cmp tc1 tc2) of { EQ_ -> cmpUniTypeMaybeList tys1 tys2; other -> other } + = cmp tc1 tc2 `thenCmp` cmpUniTypeMaybeList tys1 tys2 cmpTyConI_tys :: TyConInstance -> TyConInstance -> TAG_ cmpTyConI_tys (TyConInstance _ tys1) (TyConInstance _ tys2) @@ -803,10 +874,10 @@ cmpTyConI_tys (TyConInstance _ tys1) (TyConInstance _ tys2) singleTyConI :: TyCon -> [Maybe Type] -> UsageDetails singleTyConI ty_con spec_tys - = UsageDetails emptyBag (unitBag (TyConInstance ty_con spec_tys)) [] emptyUniqSet 0 0 + = UsageDetails emptyBag (unitBag (TyConInstance ty_con spec_tys)) [] emptyIdSet 0 0 isTyConIofThisTyCon :: TyCon -> TyConInstance -> Bool -isTyConIofThisTyCon ty_con (TyConInstance inst_ty_con _) = eqTyCon ty_con inst_ty_con +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 @@ -839,9 +910,9 @@ data UsageDetails 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 +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. A @DictBindDetails@ contains bindings for dictionaries *only*. @@ -860,31 +931,31 @@ emptyUDs :: UsageDetails unionUDs :: UsageDetails -> UsageDetails -> UsageDetails unionUDList :: [UsageDetails] -> UsageDetails -tickSpecCall :: Bool -> 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 +-- 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 [] emptyUniqSet 0 0 +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 `unionUniqSets` fvs2) (c1+c2) (i1+i2) + (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 [] (singletonUniqSet v) 0 0 + = UsageDetails emptyBag emptyBag [] (unitIdSet v) 0 0 singleFvUDs other = emptyUDs -singleConUDs con = UsageDetails emptyBag emptyBag [] (singletonUniqSet con) 0 0 +singleConUDs con = UsageDetails emptyBag emptyBag [] (unitIdSet con) 0 0 dumpDBs :: [DictBindDetails] -> Bool -- True <=> top level bound Ids @@ -911,11 +982,11 @@ dumpDBs [] top_lev bound_tyvars bound_ids fvs dumpDBs ((db@(DictBindDetails dbinders dbind db_fvs db_ftv)):dbs) top_lev bound_tyvars bound_ids fvs | top_lev - || or [i `elementOfUniqSet` db_fvs | i <- bound_ids] - || or [tv `elementOfUniqSet` db_ftv | tv <- bound_tyvars] + || 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 `unionUniqSets` 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) @@ -943,7 +1014,7 @@ dumpUDs (UsageDetails cis tycon_cis dbs fvs c i) top_lev floating inst_cis bound (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 `minusUniqSet` (mkUniqSet 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} @@ -1013,6 +1084,8 @@ data CloneInfo %************************************************************************ \begin{code} +-} + data SpecialiseData = SpecData Bool -- True <=> Specialisation performed @@ -1046,6 +1119,8 @@ data SpecialiseData 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. @@ -1057,23 +1132,22 @@ ToDo[sansom]: Transformation data to process specialisation requests. %************************************************************************ \begin{code} -specProgram :: (GlobalSwitch -> Bool) - -> UniqSupply +specProgram :: UniqSupply -> [CoreBinding] -- input ... -> SpecialiseData -> ([CoreBinding], -- main result SpecialiseData) -- result specialise data -specProgram sw_chker uniqs binds +specProgram uniqs binds (SpecData False _ local_tycons _ init_specs init_errs init_warn init_tyerrs) - = case (initSM (specTyConsAndScope (specTopBinds binds)) sw_chker uniqs) of + = 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 getDataConTyCon used_conids + used_tycons = map dataConTyCon used_conids used_gen = filter isLocalGenTyCon used_tycons - gen_tycons = setToList (mkSet local_tycons `union` mkSet used_gen) + gen_tycons = uniqSetToList (mkUniqSet local_tycons `unionUniqSets` mkUniqSet used_gen) result_specs = addListToFM_C (++) init_specs tycon_specs_list @@ -1088,12 +1162,12 @@ specProgram sw_chker uniqs binds tycis_errs = init_tyerrs `unionBags` listToBag tycis_unboxed no_errs = isEmptyBag cis_errs && isEmptyBag tycis_errs - && (not (sw_chker SpecialiseImports) || isEmptyBag cis_warn) + && (not opt_SpecialiseImports || isEmptyBag cis_warn) in - (if sw_chker D_simplifier_stats then + (if opt_D_simplifier_stats then pprTrace "\nSpecialiser Stats:\n" (ppAboves [ - ppBesides [ppStr "SpecCalls ", ppInt spec_calls], - ppBesides [ppStr "SpecInsts ", ppInt spec_insts], + ppBesides [ppPStr SLIT("SpecCalls "), ppInt spec_calls], + ppBesides [ppPStr SLIT("SpecInsts "), ppInt spec_insts], ppSP]) else id) @@ -1101,7 +1175,7 @@ specProgram sw_chker uniqs binds SpecData True no_errs local_tycons gen_tycons result_specs cis_errs cis_warn tycis_errs) -specProgram sw_chker uniqs binds (SpecData True _ _ _ _ _ _ _) +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, @@ -1128,17 +1202,16 @@ specTyConsAndScope :: SpecM ([CoreBinding], UsageDetails) specTyConsAndScope scopeM = scopeM `thenSM` \ (binds, scope_uds) -> - getSwitchCheckerSM `thenSM` \ sw_chkr -> let (tycons_cis, gotci_scope_uds) - = getLocalSpecTyConIs (sw_chkr CompilingPrelude) scope_uds + = getLocalSpecTyConIs opt_CompilingGhcInternals scope_uds tycon_specs_list = collectTyConSpecs tycons_cis in - (if sw_chkr SpecialiseTrace && not (null tycon_specs_list) then + (if opt_SpecialiseTrace && not (null tycon_specs_list) then pprTrace "Specialising TyCons:\n" (ppAboves [ if not (null specs) then - ppHang (ppCat [(ppr PprDebug tycon), ppStr "at types"]) + ppHang (ppCat [(ppr PprDebug tycon), ppPStr SLIT("at types")]) 4 (ppAboves (map pp_specs specs)) else ppNil | (tycon, specs) <- tycon_specs_list]) @@ -1180,8 +1253,8 @@ specTopBinds binds (dbinders_s, dbinds, dfvs_s) = unzip3 [(dbinders, dbind, dfvs) | DictBindDetails dbinders dbind dfvs _ <- dbind_details] - full_fvs = fvs `unionUniqSets` unionManyUniqSets dfvs_s - fvs_outer = full_fvs `minusUniqSet` (mkUniqSet (concat dbinders_s)) + 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 @@ -1211,62 +1284,43 @@ specTopBinds binds \begin{code} specExpr :: CoreExpr -> [CoreArg] -- The arguments: - -- TypeArgs are speced - -- ValArgs are unprocessed + -- 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. + UsageDetails)-- Details of usage of enclosing binders in the result + -- expression. specExpr (Var v) args - = lookupId v `thenSM` \ vlookup -> - case vlookup of - Lifted vl vu - -> -- Binding has been lifted, need to extract un-lifted value - -- NB: a function binding will never be lifted => args always null - -- i.e. no call instance required or call to be constructed - ASSERT (null args) - returnSM (bindUnlift vl vu (Var vu), singleFvUDs (VarArg vl)) - - NoLift vatom@(VarArg new_v) - -> mapSM specArg args `thenSM` \ arg_info -> - mkCallInstance v new_v arg_info `thenSM` \ call_uds -> - mkCall new_v arg_info `thenSM` \ ~(speced, call) -> - let - uds = unionUDList [call_uds, - singleFvUDs vatom, - unionUDList [uds | (_,uds,_) <- arg_info] - ] - in - returnSM (call, tickSpecCall speced uds) + = 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 tys args) null_args +specExpr (Con con args) null_args = ASSERT (null null_args) - mapSM specTy tys `thenSM` \ tys -> - mapAndUnzip3SM specAtom args `thenSM` \ (args, args_uds_s, unlifts) -> - mkTyConInstance con tys `thenSM` \ con_uds -> - returnSM (applyBindUnlifts unlifts (Con con tys args), - unionUDList args_uds_s `unionUDs` con_uds) + 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) tys args) null_args +specExpr (Prim op@(CCallOp str is_asm may_gc arg_tys res_ty) args) null_args = ASSERT (null null_args) - ASSERT (null tys) - mapSM specTy arg_tys `thenSM` \ arg_tys -> - specTy res_ty `thenSM` \ res_ty -> - mapAndUnzip3SM specAtom args `thenSM` \ (args, args_uds_s, unlifts) -> - returnSM (applyBindUnlifts unlifts (Prim (CCallOp str is_asm may_gc arg_tys res_ty) tys args), - unionUDList args_uds_s) - -specExpr (Prim prim tys args) 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) - mapSM specTy tys `thenSM` \ tys -> - mapAndUnzip3SM specAtom args `thenSM` \ (args, args_uds_s, unlifts) -> + specArgs args $ \ args' -> -- specPrimOp prim tys `thenSM` \ (prim, tys, prim_uds) -> - returnSM (applyBindUnlifts unlifts (Prim prim tys args), - unionUDList args_uds_s {-`unionUDs` prim_uds-} ) + returnSM (Prim prim args', emptyUDs {-`unionUDs` prim_uds-} ) {- ToDo: specPrimOp @@ -1286,33 +1340,26 @@ specPrimOp :: PrimOp specExpr (App fun arg) args - = -- Arg is passed on unprocessed - specExpr fun (ValArg arg : args) `thenSM` \ (expr,uds) -> + = specArg arg `thenSM` \ new_arg -> + specExpr fun (new_arg : args) `thenSM` \ (expr,uds) -> returnSM (expr, uds) -specExpr (CoTyApp fun ty) args - = -- Spec the tyarg and pass it on - specTy ty `thenSM` \ ty -> - specExpr fun (TypeArg ty : args) - -specExpr (Lam binder body) (ValArg arg : args) +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 binder body) [] +specExpr (Lam (ValBinder binder) body) [] = specLambdaOrCaseBody [binder] body [] `thenSM` \ ([binder], body, uds) -> - returnSM (Lam binder body, uds) + returnSM (Lam (ValBinder binder) body, uds) -specExpr (CoTyLam tyvar body) (TypeArg ty : args) +specExpr (Lam (TyBinder tyvar) body) (TyArg ty : args) = -- Type lambda with argument; argument already spec'd - bindTyVar tyvar ty ( - specExpr body args - ) + bindTyVar tyvar ty ( specExpr body args ) -specExpr (CoTyLam tyvar body) [] +specExpr (Lam (TyBinder tyvar) body) [] = -- No arguments cloneTyVarSM tyvar `thenSM` \ new_tyvar -> bindTyVar tyvar (mkTyVarTy new_tyvar) ( @@ -1320,7 +1367,9 @@ specExpr (CoTyLam tyvar body) [] let (binds_here, final_uds) = dumpUDs body_uds False False [] [] [new_tyvar] in - returnSM (CoTyLam new_tyvar (mkCoLetsNoUnboxed binds_here body), final_uds) + returnSM (Lam (TyBinder new_tyvar) + (mkCoLetsNoUnboxed binds_here body), + final_uds) ) specExpr (Case scrutinee alts) args @@ -1330,7 +1379,6 @@ specExpr (Case scrutinee alts) args where scrutinee_type = coreExprType scrutinee - specExpr (Let bind body) args = specBindAndScope False bind ( specExpr body args `thenSM` \ (body, body_uds) -> @@ -1339,8 +1387,8 @@ specExpr (Let bind body) args returnSM (mkCoLetsUnboxedToCase binds body, all_uds) specExpr (SCC cc expr) args - = specExpr expr [] `thenSM` \ (expr, expr_uds) -> - mapAndUnzip3SM specArg args `thenSM` \ (args, args_uds_s, unlifts) -> + = 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_ @@ -1350,6 +1398,8 @@ specExpr (SCC cc expr) args 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} @@ -1420,7 +1470,6 @@ 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: @@ -1455,10 +1504,12 @@ specAlts (AlgAlts alts deflt) scrutinee_ty args 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, _) = getAppDataTyCon scrutinee_ty + -- We use ty_args of scrutinee type to identify specialisation of + -- alternatives: + + (_, ty_args, _) = --trace "Specialise.specAlts:getAppData..." $ + getAppDataTyConExpandingDicts scrutinee_ty specAlgAlt ty_args (con,binders,rhs) = specLambdaOrCaseBody binders rhs args `thenSM` \ (binders, rhs, rhs_uds) -> @@ -1489,31 +1540,50 @@ specDeflt (BindDefault binder rhs) args %************************************************************************ \begin{code} -specAtom :: CoreArg -> SpecM (CoreArg, UsageDetails, - CoreExpr -> CoreExpr) - -specAtom (LitArg lit) - = returnSM (LitArg lit, emptyUDs, id) - -specAtom (VarArg v) +partition_args :: [CoreArg] -> ([CoreArg], [CoreArg]) +partition_args args + = span is_ty_arg args + 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 - -> returnSM (VarArg vu, singleFvUDs (VarArg vl), bindUnlift vl vu) + -> thing_inside (VarArg vu) `thenSM` \ (expr, uds) -> + returnSM (bindUnlift vl vu expr, singleFvUDs (VarArg vl) `unionUDs` uds) NoLift vatom - -> returnSM (vatom, singleFvUDs vatom, id) + -> 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 :: CoreArg -> SpecM (CoreArg, UsageDetails, - CoreExpr -> CoreExpr) +specArg (LitArg lit) + = thing_inside (LitArg lit) -specArg (ValArg arg) -- unprocessed; spec the atom - = specAtom arg `thenSM` \ (arg, uds, unlift) -> - returnSM (ValArg arg, uds, unlift) +specArg (VarArg v) -specArg (TypeArg ty) -- already speced; no action - = returnSM (TypeArg ty, emptyUDs, id) + +specArgs [] thing_inside + = thing_inside [] + +specArgs (arg:args) thing_inside + = specArg arg $ \ arg' -> + specArgs args $ \ args' -> + thing_inside (arg' : args') \end{code} @@ -1744,14 +1814,16 @@ instBind top_lev new_ids@(first_binder:other_binders) bind equiv_ciss inst_cis else if top_lev then pprTrace "dumpCIs: not same overloading ... top level \n" else (\ x y -> y) - ) (ppHang (ppBesides [ppStr "{", ppr PprDebug new_ids, ppStr "}"]) - 4 (ppAboves [ppAboves (map (pprType PprDebug . idType) new_ids), + ) (ppHang (ppBesides [ppPStr SLIT("{"), + interppSP PprDebug new_ids, + ppPStr SLIT("}")]) + 4 (ppAboves [ppAboves (map (pprGenType PprDebug . idType) new_ids), ppAboves (map pprCI (concat equiv_ciss))])) (returnSM ([], emptyUDs, [])) where (tyvar_tmpls, class_tyvar_pairs) = getIdOverloading first_binder - tyvar_tmpl_tys = map mkTyVarTemplateTy tyvar_tmpls + tyvar_tmpl_tys = mkTyVarTys tyvar_tmpls no_of_tyvars = length tyvar_tmpls no_of_dicts = length class_tyvar_pairs @@ -1810,21 +1882,21 @@ OK, so we have: We return a new definition - f@t1//t3 = /\a -> orig_rhs t1 a t3 d1 d2 + $f1 = /\a -> orig_rhs t1 a t3 d1 d2 -The SpecInfo for f will be (the "2" indicates 2 dictionaries to eat) +The SpecInfo for f will be: - SpecInfo [Just t1, Nothing, Just t3] 2 f@t1//t3 + SpecInfo [t1, a, t3] (\d1 d2 -> $f1 a) Based on this SpecInfo, a call instance of f - ...(f t1 t2 t3 d1 d2)... + ...(f t1 t2 t3)... should get replaced by - ...(f@t1//t3 t2)... + ...(\d1 d2 -> $f1 t2)... -(But that is the business of @mkCall@.) +(But that is the business of the simplifier.) \begin{code} mkOneInst :: CallInstance @@ -1841,18 +1913,17 @@ mkOneInst :: CallInstance mkOneInst do_cis@(CallInstance _ spec_tys dict_args _ _) explicit_cis no_of_dicts_to_specialise top_lev inst_cis new_ids orig_bind - = getSwitchCheckerSM `thenSM` \ sw_chkr -> - newSpecIds new_ids spec_tys no_of_dicts_to_specialise + = 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 unspeciailsed args + -- which correspond to unspecialised args arg_tys :: [Type] (_,arg_tys) = mapAccumL do_the_wotsit poly_tyvars spec_tys args :: [CoreArg] - args = map TypeArg arg_tys ++ dict_args + args = map TyArg arg_tys ++ dict_args (new_id:_) = new_ids (spec_id:_) = spec_ids @@ -1877,8 +1948,8 @@ mkOneInst do_cis@(CallInstance _ spec_tys dict_args _ _) explicit_cis -- 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 sw_chkr SpecialiseTrace - then trace_nospec " Exists: " exists_id + = (if opt_SpecialiseTrace + then trace_nospec " Exists: " orig_id else id) ( returnSM (Nothing, emptyUDs, Nothing) @@ -1887,7 +1958,7 @@ mkOneInst do_cis@(CallInstance _ spec_tys dict_args _ _) explicit_cis -- 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 sw_chkr SpecialiseTrace + (if opt_SpecialiseTrace then trace_nospec " Explicit: " explicit_id else id) ( @@ -1912,7 +1983,7 @@ mkOneInst do_cis@(CallInstance _ spec_tys dict_args _ _) explicit_cis spec_info = Just (SpecInfo spec_tys no_of_dicts_to_specialise spec_id) in - if isUnboxedDataType (idType spec_id) then + 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] @@ -1922,29 +1993,31 @@ mkOneInst do_cis@(CallInstance _ spec_tys dict_args _ _) explicit_cis tickSpecInsts (final_uds `unionUDs` lift_uds), spec_info) else returnSM (Just (spec_id, - mkCoLetsNoUnboxed local_dict_binds (mkCoTyLam poly_tyvars inst_rhs)), + mkCoLetsNoUnboxed local_dict_binds (mkTyLam poly_tyvars inst_rhs)), tickSpecInsts final_uds, spec_info) where lookup_orig_spec = lookupSpecEnv (getIdSpecialisation orig_id) arg_tys - Just (exists_id, _, _) = lookup_orig_spec 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 (ppCat [ppr PprDebug new_id, ppInterleave ppNil (map pp_ty arg_tys), - ppStr "==>", ppr PprDebug spec_id]) + ppPStr SLIT("==>"), ppr PprDebug spec_id]) in - (if sw_chkr SpecialiseTrace then + (if opt_SpecialiseTrace then pprTrace "Specialising:" - (ppHang (ppBesides [ppStr "{", ppr PprDebug new_ids, ppStr "}"]) + (ppHang (ppBesides [ppChar '{', + interppSP PprDebug new_ids, + ppChar '}']) 4 (ppAboves [ - ppBesides [ppStr "types: ", ppInterleave ppNil (map pp_ty arg_tys)], + ppBesides [ppPStr SLIT("types: "), ppInterleave ppNil (map pp_ty arg_tys)], if isExplicitCI do_cis then ppNil else - ppBesides [ppStr "dicts: ", ppInterleave ppNil (map pp_dict dict_args)], - ppBesides [ppStr "specs: ", ppr PprDebug spec_ids]])) + ppBesides [ppPStr SLIT("dicts: "), ppInterleave ppNil (map pp_dict dict_args)], + ppBesides [ppPStr SLIT("specs: "), ppr PprDebug spec_ids]])) else id) ( do_bind orig_bind `thenSM` \ (maybe_inst_bind, inst_uds, spec_infos) -> @@ -1952,8 +2025,8 @@ mkOneInst do_cis@(CallInstance _ spec_tys dict_args _ _) explicit_cis returnSM (maybe_inst_bind, inst_uds, spec_infos) ) where - pp_dict (ValArg d) = ppr PprDebug d - pp_ty t = pprParendType PprDebug t + pp_dict d = ppr_arg PprDebug d + pp_ty t = pprParendGenType PprDebug t do_the_wotsit (tyvar:tyvars) Nothing = (tyvars, mkTyVarTy tyvar) do_the_wotsit tyvars (Just ty) = (tyvars, ty) @@ -1969,245 +2042,56 @@ mkOneInst do_cis@(CallInstance _ spec_tys dict_args _ _) explicit_cis \begin{code} mkCallInstance :: Id -> Id - -> [(CoreArg, UsageDetails, CoreExpr -> CoreExpr)] + -> [CoreArg] -> SpecM UsageDetails -mkCallInstance id new_id [] - = returnSM emptyUDs - mkCallInstance id new_id args - - -- No specialised versions for "error" and friends are req'd. - -- This is a special case in core lint etc. - - | isBottomingId id - = returnSM emptyUDs - - -- No call instances for SuperDictSelIds - -- These are a special case in mkCall - - | maybeToBool (isSuperDictSelId_maybe id) + | null args || -- No args at all + isBottomingId id || -- No point in specialising "error" and friends + -- even at unboxed types + 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 - -- There are also no call instances for ClassOpIds - -- However, we need to process it to get any second-level call - -- instances for a ConstMethodId extracted from its SpecEnv - | otherwise - = getSwitchCheckerSM `thenSM` \ sw_chkr -> - let - spec_overloading = sw_chkr SpecialiseOverloaded - spec_unboxed = sw_chkr SpecialiseUnboxed - spec_all = sw_chkr SpecialiseAll - - (tyvars, class_tyvar_pairs) = getIdOverloading id - - arg_res = take_type_args tyvars class_tyvar_pairs args - enough_args = maybeToBool arg_res - - (Just (tys, dicts, rest_args)) = arg_res - - record_spec id tys - = (record, lookup, spec_tys) - where - spec_tys = specialiseCallTys spec_all spec_unboxed spec_overloading - (mkConstraintVector id) tys + = returnSM (singleCI new_id spec_tys dicts) - record = any (not . isTyVarTy) (catMaybes spec_tys) - - lookup = lookupSpecEnv (getIdSpecialisation id) tys - in - if (not enough_args) then - pprPanic "Specialise:recordCallInst: Unsaturated Type & Dict Application:\n\t" - (ppCat [ppr PprDebug id, ppr PprDebug [arg | (arg,_,_) <- args] ]) - else - case record_spec id tys of - (False, _, _) - -> -- pprTrace "CallInst:NotReqd\n" - -- (ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)]) - (returnSM emptyUDs) - - (True, Nothing, spec_tys) - -> if isClassOpId id then -- No CIs for class ops, dfun will give SPEC inst - returnSM emptyUDs - else - -- pprTrace "CallInst:Reqd\n" - -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)], - -- ppCat [ppStr "CI", ppCat (map (pprMaybeTy PprDebug) spec_tys), - -- ppCat (map (ppr PprDebug) dicts)]]) - (returnSM (singleCI new_id spec_tys dicts)) - - (True, Just (spec_id, tys_left, toss), _) - -> if maybeToBool (isConstMethodId_maybe spec_id) then - -- If we got a const method spec_id see if further spec required - -- NB: const method is top-level so spec_id will not be cloned - case record_spec spec_id tys_left of - (False, _, _) - -> -- pprTrace "CallInst:Exists\n" - -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)], - -- ppCat [ppStr "->", ppr PprDebug spec_id, - -- ppr PprDebug (tys_left ++ drop toss dicts)]]) - (returnSM emptyUDs) - - (True, Nothing, spec_tys) - -> -- pprTrace "CallInst:Exists:Reqd\n" - -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)], - -- ppCat [ppStr "->", ppr PprDebug spec_id, - -- ppr PprDebug (tys_left ++ drop toss dicts)], - -- ppCat [ppStr "CI", ppCat (map (pprMaybeTy PprDebug) spec_tys), - -- ppCat (map (ppr PprDebug) (drop toss dicts))]]) - (returnSM (singleCI spec_id spec_tys (drop toss dicts))) - - (True, Just (spec_spec_id, tys_left_left, toss_toss), _) - -> -- pprTrace "CallInst:Exists:Exists\n" - -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)], - -- ppCat [ppStr "->", ppr PprDebug spec_id, - -- ppr PprDebug (tys_left ++ drop toss dicts)], - -- ppCat [ppStr "->", ppr PprDebug spec_spec_id, - -- ppr PprDebug (tys_left_left ++ drop (toss + toss_toss) dicts)]]) - (returnSM emptyUDs) - - else - -- pprTrace "CallInst:Exists\n" - -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)], - -- ppCat [ppStr "->", ppr PprDebug spec_id, - -- ppr PprDebug (tys_left ++ drop toss dicts)]]) - (returnSM emptyUDs) - - -take_type_args (_:tyvars) class_tyvar_pairs ((TypeArg ty,_,_):args) - = case take_type_args tyvars class_tyvar_pairs args of - Nothing -> Nothing - Just (tys, dicts, others) -> Just (ty:tys, dicts, others) -take_type_args (_:tyvars) class_tyvar_pairs [] - = Nothing -take_type_args [] class_tyvar_pairs 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@(ValArg _),_,_):args) - = case take_dict_args class_tyvar_pairs args of - Nothing -> Nothing - Just (dicts, others) -> Just (dict:dicts, others) -take_dict_args (_:class_tyvar_pairs) [] - = Nothing -take_dict_args [] args - = Just ([], args) -\end{code} - -\begin{code} -mkCall :: Id - -> [(CoreArg, UsageDetails, CoreExpr -> CoreExpr)] - -> SpecM (Bool, CoreExpr) - -mkCall new_id args - | maybeToBool (isSuperDictSelId_maybe new_id) - && any isUnboxedDataType 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 isUnboxedDataType (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" - (ppCat [ppr PprDebug new_id, - ppInterleave ppNil (map (pprParendType PprDebug) ty_args), - ppStr "==>", - ppr PprDebug spec_id]) - else - let - (vals_left, _, unlifts_left) = unzip3 args_left - applied_tys = mkCoTyApps (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 ((TypeArg 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 ((ValArg _,_,_) : args) = toss_dicts (n-1) args - + (tyvars, class_tyvar_pairs) = getIdOverloading id + constrained_tyvars = map snd class_tyvar_pairs -- May contain dups + constraint_vec = [tyvar `elem` constrained_tyvars | tyvar <- tyvars] + + arg_res = take_type_args tyvars class_tyvar_pairs args + enough_args = maybeToBool arg_res + (Just (tys, dicts, rest_args)) = arg_res + + interesting_overloading = any (not . isTyVarTy) (catMaybes spec_tys) + spec_tys = specialiseCallTys constraint_vec tys + + ----------------- 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} -checkUnspecOK :: Id -> [Type] -> a -> a -checkUnspecOK check_id tys - = if isLocallyDefined check_id && any isUnboxedDataType tys - then pprPanic "Specialise:checkUnspecOK: unboxed instance for local id not found\n" - (ppCat [ppr PprDebug check_id, - ppInterleave ppNil (map (pprParendType PprDebug) tys)]) - else id - -checkSpecOK :: Id -> [Type] -> Id -> [Type] -> a -> a -checkSpecOK check_id tys spec_id tys_left - = if any isUnboxedDataType tys_left - then pprPanic "Specialise:checkSpecOK: unboxed type args in specialised application\n" - (ppAboves [ppCat [ppr PprDebug check_id, - ppInterleave ppNil (map (pprParendType PprDebug) tys)], - ppCat [ppr PprDebug spec_id, - ppInterleave ppNil (map (pprParendType PprDebug) tys_left)]]) - else id -\end{code} \begin{code} mkTyConInstance :: Id @@ -2218,20 +2102,20 @@ mkTyConInstance con tys case record_inst of Nothing -- No TyCon instance -> -- pprTrace "NoTyConInst:" - -- (ppCat [ppr PprDebug tycon, ppStr "at", + -- (ppCat [ppr PprDebug tycon, ppPStr SLIT("at"), -- ppr PprDebug con, ppCat (map (ppr PprDebug) tys)]) (returnSM (singleConUDs con)) Just spec_tys -- Record TyCon instance -> -- pprTrace "TyConInst:" - -- (ppCat [ppr PprDebug tycon, ppStr "at", + -- (ppCat [ppr PprDebug tycon, ppPStr SLIT("at"), -- ppr PprDebug con, ppCat (map (ppr PprDebug) tys), - -- ppBesides [ppStr "(", + -- ppBesides [ppChar '(', -- ppCat [pprMaybeTy PprDebug ty | ty <- spec_tys], - -- ppStr ")"]]) + -- ppChar ')']]) (returnSM (singleTyConI tycon spec_tys `unionUDs` singleConUDs con)) where - tycon = getDataConTyCon con + tycon = dataConTyCon con \end{code} \begin{code} @@ -2250,7 +2134,7 @@ recordTyConInst con tys tys) in -- pprTrace "ConSpecExists?: " - -- (ppAboves [ppStr (if spec_exists then "True" else "False"), + -- (ppAboves [ppPStr (if spec_exists then SLIT("True") else SLIT("False")), -- ppr PprShowAll con, ppCat (map (ppr PprDebug) tys)]) (if (not spec_exists && do_tycon_spec) then returnSM (Just spec_tys) @@ -2274,35 +2158,31 @@ Monad has: threaded in and out: unique supply \begin{code} +type TypeEnv = TyVarEnv Type + type SpecM result - = (GlobalSwitch -> Bool) - -> TypeEnv + = TypeEnv -> SpecIdEnv -> UniqSupply -> result -initSM m sw_chker uniqs - = m sw_chker nullTyVarEnv nullIdEnv uniqs +initSM m uniqs = m nullTyVarEnv nullIdEnv uniqs returnSM :: a -> SpecM a thenSM :: SpecM a -> (a -> SpecM b) -> SpecM b fixSM :: (a -> SpecM a) -> SpecM a -thenSM m k sw_chkr tvenv idenv us +thenSM m k tvenv idenv us = case splitUniqSupply us of { (s1, s2) -> - case (m sw_chkr tvenv idenv s1) of { r -> - k r sw_chkr tvenv idenv s2 }} + case (m tvenv idenv s1) of { r -> + k r tvenv idenv s2 }} -returnSM r sw_chkr tvenv idenv us = r +returnSM r tvenv idenv us = r -fixSM k sw_chkr tvenv idenv us +fixSM k tvenv idenv us = r where - r = k r sw_chkr tvenv idenv us -- Recursive in r! -\end{code} - -\begin{code} -getSwitchCheckerSM sw_chkr tvenv idenv us = sw_chkr + r = k r tvenv idenv us -- Recursive in r! \end{code} The only interesting bit is figuring out the type of the SpecId! @@ -2313,18 +2193,16 @@ newSpecIds :: [Id] -- The id of which to make a specialised version -> Int -- No of dicts to specialise -> SpecM [Id] -newSpecIds new_ids maybe_tys dicts_to_ignore sw_chkr tvenv idenv us +newSpecIds new_ids maybe_tys dicts_to_ignore tvenv idenv us = [ mkSpecId uniq id maybe_tys (spec_id_ty id) (selectIdInfoForSpecId id) - | (id,uniq) <- new_ids `zip` uniqs ] + | (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 sw_chkr tvenv idenv us - = map mkPolySysTyVar uniqs - where - uniqs = getUniques n us +newTyVars n tvenv idenv us + = [mkSysTyVar uniq mkBoxedTypeKind | uniq <- getUniques n us] \end{code} @cloneLambdaOrCaseBinders@ and @cloneLetBinders@ take a bunch of @@ -2343,11 +2221,11 @@ As well as returning the list of cloned @Id@s they also return a list of cloneLambdaOrCaseBinders :: [Id] -- Old binders -> SpecM ([Id], [CloneInfo]) -- New ones -cloneLambdaOrCaseBinders old_ids sw_chkr tvenv idenv us +cloneLambdaOrCaseBinders old_ids tvenv idenv us = let uniqs = getUniques (length old_ids) us in - unzip (zipWithEqual clone_it old_ids uniqs) + unzip (zipWithEqual "cloneLambdaOrCaseBinders" clone_it old_ids uniqs) where clone_it old_id uniq = (new_id, NoLift (VarArg new_id)) @@ -2359,7 +2237,7 @@ cloneLetBinders :: Bool -- Top level ? -> [Id] -- Old binders -> SpecM ([Id], [CloneInfo]) -- New ones -cloneLetBinders top_lev is_rec old_ids sw_chkr tvenv idenv us +cloneLetBinders top_lev is_rec old_ids tvenv idenv us = let uniqs = getUniques (2 * length old_ids) us in @@ -2374,12 +2252,12 @@ cloneLetBinders top_lev is_rec old_ids sw_chkr tvenv idenv us -- Don't clone if it is a top-level thing. Why not? -- (a) we don't want to change the uniques - -- on such things (see TopLevId in Id.lhs) + -- 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 && isUnboxedDataType new_ty && not (isUnboxedDataType old_ty)) + = if (is_rec && isUnboxedType new_ty && not (isUnboxedType old_ty)) then (lifted_id, Lifted lifted_id unlifted_id) : clone_rest else (new_id, @@ -2397,7 +2275,7 @@ cloneLetBinders top_lev is_rec old_ids sw_chkr tvenv idenv us cloneTyVarSM :: TyVar -> SpecM TyVar -cloneTyVarSM old_tyvar sw_chkr tvenv idenv us +cloneTyVarSM old_tyvar tvenv idenv us = let uniq = getUnique us in @@ -2405,13 +2283,13 @@ cloneTyVarSM old_tyvar sw_chkr tvenv idenv us bindId :: Id -> CloneInfo -> SpecM thing -> SpecM thing -bindId id val specm sw_chkr tvenv idenv us - = specm sw_chkr tvenv (addOneToIdEnv idenv id val) us +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 sw_chkr tvenv idenv us - = specm sw_chkr tvenv (growIdEnvList idenv (zip olds news)) us +bindIds olds news specm tvenv idenv us + = specm tvenv (growIdEnvList idenv (zip olds news)) us bindSpecIds :: [Id] -- Old -> [(CloneInfo)] -- New @@ -2421,8 +2299,8 @@ bindSpecIds :: [Id] -- Old -> SpecM thing -> SpecM thing -bindSpecIds olds clones spec_infos specm sw_chkr tvenv idenv us - = specm sw_chkr tvenv (growIdEnvList idenv old_to_clone) us +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 @@ -2444,14 +2322,14 @@ bindSpecIds olds clones spec_infos specm sw_chkr tvenv idenv us bindTyVar :: TyVar -> Type -> SpecM thing -> SpecM thing -bindTyVar tyvar ty specm sw_chkr tvenv idenv us - = specm sw_chkr (growTyVarEnvList tvenv [(tyvar,ty)]) idenv us +bindTyVar tyvar ty specm tvenv idenv us + = specm (growTyVarEnvList tvenv [(tyvar,ty)]) idenv us \end{code} \begin{code} lookupId :: Id -> SpecM CloneInfo -lookupId id sw_chkr tvenv idenv us +lookupId id tvenv idenv us = case lookupIdEnv idenv id of Nothing -> NoLift (VarArg id) Just info -> info @@ -2460,13 +2338,13 @@ lookupId id sw_chkr tvenv idenv us \begin{code} specTy :: Type -> SpecM Type -- Apply the current type envt to the type -specTy ty sw_chkr tvenv idenv us +specTy ty tvenv idenv us = applyTypeEnvToTy tvenv ty \end{code} \begin{code} liftId :: Id -> SpecM (Id, Id) -liftId id sw_chkr tvenv idenv us +liftId id tvenv idenv us = let uniq = getUnique us in @@ -2503,4 +2381,126 @@ 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" + (ppCat [ppr PprDebug new_id, + ppInterleave ppNil (map (pprParendGenType PprDebug) ty_args), + ppPStr SLIT("==>"), + ppr PprDebug 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" + (ppCat [ppr PprDebug check_id, + ppInterleave ppNil (map (pprParendGenType PprDebug) 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" + (ppAboves [ppCat [ppr PprDebug check_id, + ppInterleave ppNil (map (pprParendGenType PprDebug) tys)], + ppCat [ppr PprDebug spec_id, + ppInterleave ppNil (map (pprParendGenType PprDebug) tys_left)]]) + else id +-} \end{code}