X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fspecialise%2FSpecialise.lhs;h=02bcc9dd7bc3bce5e55145e59789759c3e0ea816;hb=d3e697b8d842bd43329d470f2bc424a6dcb88d89;hp=424bcad5e4f73dc148d530de6ec500babc8b4b17;hpb=12899612693163154531da3285ec99c1c8ca2226;p=ghc-hetmet.git diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs index 424bcad..02bcc9d 100644 --- a/ghc/compiler/specialise/Specialise.lhs +++ b/ghc/compiler/specialise/Specialise.lhs @@ -4,8 +4,6 @@ \section[Specialise]{Stamping out overloading, and (optionally) polymorphism} \begin{code} -#include "HsVersions.h" - module Specialise ( specProgram, initSpecData, @@ -13,56 +11,49 @@ module Specialise ( SpecialiseData(..) ) where -IMP_Ubiq(){-uitous-} -IMPORT_1_3(List(partition)) +#include "HsVersions.h" import Bag ( emptyBag, unitBag, isEmptyBag, unionBags, - partitionBag, listToBag, bagToList + partitionBag, listToBag, bagToList, Bag ) -import Class ( GenClass{-instance Eq-} ) +import Class ( Class ) import CmdLineOpts ( opt_SpecialiseImports, opt_D_simplifier_stats, - opt_CompilingGhcInternals, opt_SpecialiseTrace, - opt_SpecialiseOverloaded, opt_SpecialiseUnboxed, - opt_SpecialiseAll + opt_SpecialiseTrace ) import CoreLift ( mkLiftedId, liftExpr, bindUnlift, applyBindUnlifts ) import CoreSyn import CoreUtils ( coreExprType, squashableDictishCcExpr ) import FiniteMap ( addListToFM_C, FiniteMap ) -import Kind ( mkBoxedTypeKind ) +import Kind ( mkBoxedTypeKind, isBoxedTypeKind ) import Id ( idType, isDefaultMethodId_maybe, toplevelishId, - isSuperDictSelId_maybe, isBottomingId, - isConstMethodId_maybe, isDataCon, + isBottomingId, + isDataCon, isImportedId, mkIdWithNewUniq, dataConTyCon, applyTypeEnvToId, nullIdEnv, addOneToIdEnv, growIdEnvList, - lookupIdEnv, SYN_IE(IdEnv), + lookupIdEnv, IdEnv, emptyIdSet, mkIdSet, unitIdSet, elementOfIdSet, minusIdSet, - unionIdSets, unionManyIdSets, SYN_IE(IdSet), - GenId{-instance Eq-} + unionIdSets, unionManyIdSets, IdSet, + GenId{-instance Eq-}, Id ) 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, - ppInt, ppSP, ppInterleave, ppNil, SYN_IE(Pretty) - ) import PrimOp ( PrimOp(..) ) import SpecUtils -import Type ( mkTyVarTy, mkTyVarTys, isTyVarTy, getAppDataTyConExpandingDicts, - tyVarsOfTypes, applyTypeEnvToTy, isUnboxedType +import Type ( mkTyVarTy, mkTyVarTys, isTyVarTy, splitAlgTyConApp, + tyVarsOfTypes, instantiateTy, isUnboxedType, isDictTy, + Type ) import TyCon ( TyCon{-instance Eq-} ) import TyVar ( cloneTyVar, mkSysTyVar, - elementOfTyVarSet, SYN_IE(TyVarSet), - nullTyVarEnv, growTyVarEnvList, SYN_IE(TyVarEnv), + elementOfTyVarSet, TyVarSet, + emptyTyVarEnv, growTyVarEnvList, TyVarEnv, GenTyVar{-instance Eq-} ) import TysWiredIn ( liftDataCon ) @@ -70,19 +61,25 @@ 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 + thenCmp ) +import List ( partition ) +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)" -isDictTy = panic "Specialise.isDictTy (ToDo)" isLocalGenTyCon = panic "Specialise.isLocalGenTyCon (ToDo)" isLocalSpecTyCon = panic "Specialise.isLocalSpecTyCon (ToDo)" isSpecId_maybe = panic "Specialise.isSpecId_maybe (ToDo)" @@ -664,6 +661,32 @@ options). However, the _Lifting will still be eliminated if the strictness analyser deems the lifted binding strict. +A note about non-tyvar dictionaries +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Some Ids have types like + + forall a,b,c. Eq a -> Ord [a] -> tau + +This seems curious at first, because we usually only have dictionary +args whose types are of the form (C a) where a is a type variable. +But this doesn't hold for the functions arising from instance decls, +which sometimes get arguements with types of form (C (T a)) for some +type constructor T. + +Should we specialise wrt this compound-type dictionary? We used to say +"no", saying: + "This is a heuristic judgement, as indeed is the fact that we + specialise wrt only dictionaries. We choose *not* to specialise + wrt compound dictionaries because at the moment the only place + they show up is in instance decls, where they are simply plugged + into a returned dictionary. So nothing is gained by specialising + wrt them." + +But it is simpler and more uniform to specialise wrt these dicts too; +and in future GHC is likely to support full fledged type signatures +like + f ;: Eq [(a,b)] => ... + %************************************************************************ %* * @@ -687,20 +710,20 @@ data CallInstance \end{code} \begin{code} -pprCI :: CallInstance -> Pretty +pprCI :: CallInstance -> Doc pprCI (CallInstance id spec_tys dicts _ maybe_specinfo) - = ppHang (ppCat [ppStr "Call inst for", ppr PprDebug id]) - 4 (ppAboves [ppCat (ppStr "types" : [pprMaybeTy PprDebug ty | ty <- spec_tys]), + = hang (hsep [ptext SLIT("Call inst for"), ppr id]) + 4 (vcat [hsep (text "types" : [pprMaybeTy ty | ty <- spec_tys]), case maybe_specinfo of - Nothing -> ppCat (ppStr "dicts" : [ppr_arg PprDebug dict | dict <- dicts]) + Nothing -> hsep (text "dicts" : [ppr_arg dict | dict <- dicts]) Just (SpecInfo _ _ spec_id) - -> ppCat [ppStr "Explicit SpecId", ppr PprDebug spec_id] + -> hsep [ptext SLIT("Explicit SpecId"), ppr 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 +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 _ _ _) @@ -717,17 +740,17 @@ Comparisons are based on the {\em types}, ignoring the dictionary args: \begin{code} -cmpCI :: CallInstance -> CallInstance -> TAG_ +cmpCI :: CallInstance -> CallInstance -> Ordering cmpCI (CallInstance id1 tys1 _ _ _) (CallInstance id2 tys2 _ _ _) - = cmp id1 id2 `thenCmp` cmpUniTypeMaybeList tys1 tys2 + = compare id1 id2 `thenCmp` cmpUniTypeMaybeList tys1 tys2 -cmpCI_tys :: CallInstance -> CallInstance -> TAG_ +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 } + = case cmpCI_tys c1 c2 of { EQ -> True; other -> False } isCIofTheseIds :: [Id] -> CallInstance -> Bool isCIofTheseIds ids (CallInstance ci_id _ _ _ _) @@ -766,10 +789,10 @@ getCIs top_lev ids (UsageDetails cis tycon_cis dbs fvs c i) cis_here_list = bagToList cis_here in -- pprTrace "getCIs:" - -- (ppHang (ppBesides [ppStr "{", - -- interppSP PprDebug ids, - -- ppStr "}"]) - -- 4 (ppAboves (map pprCI cis_here_list))) + -- (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 @@ -795,23 +818,23 @@ 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 "{", - interppSP PprDebug bound_ids, - ppStr "}"]) - 4 (ppAboves [ppStr "Dumping CIs:", - ppAboves (map pprCI (bagToList cis_of_bound_id)), - ppStr "Instantiating CIs:", - ppAboves (map pprCI inst_cis)])) + (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" - (ppHang (ppBesides [ppStr "{", - interppSP PprDebug full_ids, - ppStr "}"]) - 4 (ppAboves (map pprCI (bagToList cis_dump)))) + (hang (hcat [char '{', + interppSP full_ids, + char '}']) + 4 (vcat (map pprCI (bagToList cis_dump)))) else id) cis_keep_not_bound_id ) @@ -862,11 +885,11 @@ data TyConInstance = TyConInstance TyCon -- Type Constructor [Maybe Type] -- Applied to these specialising types -cmpTyConI :: TyConInstance -> TyConInstance -> TAG_ +cmpTyConI :: TyConInstance -> TyConInstance -> Ordering cmpTyConI (TyConInstance tc1 tys1) (TyConInstance tc2 tys2) - = cmp tc1 tc2 `thenCmp` cmpUniTypeMaybeList tys1 tys2 + = compare tc1 tc2 `thenCmp` cmpUniTypeMaybeList tys1 tys2 -cmpTyConI_tys :: TyConInstance -> TyConInstance -> TAG_ +cmpTyConI_tys :: TyConInstance -> TyConInstance -> Ordering cmpTyConI_tys (TyConInstance _ tys1) (TyConInstance _ tys2) = cmpUniTypeMaybeList tys1 tys2 @@ -908,9 +931,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*. @@ -1082,6 +1105,8 @@ data CloneInfo %************************************************************************ \begin{code} +-} + data SpecialiseData = SpecData Bool -- True <=> Specialisation performed @@ -1115,6 +1140,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. @@ -1159,10 +1186,10 @@ specProgram uniqs binds && (not opt_SpecialiseImports || isEmptyBag cis_warn) in (if opt_D_simplifier_stats then - pprTrace "\nSpecialiser Stats:\n" (ppAboves [ - ppBesides [ppStr "SpecCalls ", ppInt spec_calls], - ppBesides [ppStr "SpecInsts ", ppInt spec_insts], - ppSP]) + pprTrace "\nSpecialiser Stats:\n" (vcat [ + hcat [ptext SLIT("SpecCalls "), int spec_calls], + hcat [ptext SLIT("SpecInsts "), int spec_insts], + space]) else id) (final_binds, @@ -1198,16 +1225,16 @@ specTyConsAndScope scopeM = scopeM `thenSM` \ (binds, scope_uds) -> let (tycons_cis, gotci_scope_uds) - = getLocalSpecTyConIs opt_CompilingGhcInternals 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" - (ppAboves [ if not (null specs) then - ppHang (ppCat [(ppr PprDebug tycon), ppStr "at types"]) - 4 (ppAboves (map pp_specs specs)) - else ppNil + (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) @@ -1222,7 +1249,7 @@ specTyConsAndScope scopeM uniq_cis = map head (equivClasses cmpTyConI_tys tycon_cis) tycon_specs = [(False, spec_tys) | TyConInstance _ spec_tys <- uniq_cis] - pp_specs (False, spec_tys) = ppInterleave ppNil [pprMaybeTy PprDebug spec_ty | spec_ty <- spec_tys] + pp_specs (False, spec_tys) = hsep [pprMaybeTy spec_ty | spec_ty <- spec_tys] \end{code} @@ -1285,26 +1312,13 @@ specExpr :: CoreExpr -- 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 specOutArg args `thenSM` \ arg_info -> - mkCallInstance v new_v arg_info `thenSM` \ call_uds -> - mkCall new_v arg_info `thenSM` \ 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) @@ -1312,37 +1326,22 @@ specExpr expr@(Lit _) null_args specExpr (Con con args) null_args = ASSERT (null null_args) - let - (targs, vargs) = partition_args args - in - mapAndUnzipSM specTyArg targs `thenSM` \ (targs, tys) -> - mapAndUnzip3SM specValArg vargs `thenSM` \ (vargs, args_uds_s, unlifts) -> - mkTyConInstance con tys `thenSM` \ con_uds -> - returnSM (applyBindUnlifts unlifts (Con con (targs ++ vargs)), - 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) args) null_args = ASSERT (null null_args) - let - (targs, vargs) = partition_args args - in - ASSERT (null targs) - mapSM specTy arg_tys `thenSM` \ arg_tys -> - specTy res_ty `thenSM` \ res_ty -> - mapAndUnzip3SM specValArg vargs `thenSM` \ (vargs, args_uds_s, unlifts) -> - returnSM (applyBindUnlifts unlifts (Prim (CCallOp str is_asm may_gc arg_tys res_ty) vargs), - unionUDList args_uds_s) + 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) - let - (targs, vargs) = partition_args args - in - mapAndUnzipSM specTyArg targs `thenSM` \ (targs, tys) -> - mapAndUnzip3SM specValArg vargs `thenSM` \ (vargs, args_uds_s, unlifts) -> + specArgs args $ \ args' -> -- specPrimOp prim tys `thenSM` \ (prim, tys, prim_uds) -> - returnSM (applyBindUnlifts unlifts (Prim prim (targs ++ vargs)), - unionUDList args_uds_s {-`unionUDs` prim_uds-} ) + returnSM (Prim prim args', emptyUDs {-`unionUDs` prim_uds-} ) {- ToDo: specPrimOp @@ -1362,9 +1361,8 @@ specPrimOp :: PrimOp specExpr (App fun arg) args - = -- If TyArg, arg will be processed; otherwise, left alone - preSpecArg arg `thenSM` \ new_arg -> - specExpr fun (new_arg : args) `thenSM` \ (expr,uds) -> + = 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 @@ -1531,7 +1529,8 @@ specAlts (AlgAlts alts deflt) scrutinee_ty args -- We use ty_args of scrutinee type to identify specialisation of -- alternatives: - (_, ty_args, _) = getAppDataTyConExpandingDicts scrutinee_ty + (_, ty_args, _) = --trace "Specialise.specAlts:getAppData..." $ + splitAlgTyConApp scrutinee_ty specAlgAlt ty_args (con,binders,rhs) = specLambdaOrCaseBody binders rhs args `thenSM` \ (binders, rhs, rhs_uds) -> @@ -1570,45 +1569,42 @@ partition_args args is_ty_arg _ = False ---------- -preSpecArg :: CoreArg -> SpecM CoreArg -- diddle TyArgs, but nothing else - -preSpecArg (TyArg ty) - = specTy ty `thenSM` \ new_ty -> - returnSM (TyArg new_ty) - -preSpecArg other = returnSM other - --------------------- -specValArg :: CoreArg -> SpecM (CoreArg, UsageDetails, - CoreExpr -> CoreExpr) - -specValArg (LitArg lit) - = returnSM (LitArg lit, emptyUDs, id) - -specValArg (VarArg v) +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)) ------------------- -specTyArg (TyArg ty) +specArg (TyArg ty) thing_inside = specTy ty `thenSM` \ new_ty -> - returnSM (TyArg new_ty, new_ty) + thing_inside (TyArg new_ty) + +specArg (LitArg lit) + = thing_inside (LitArg lit) --------------- -specOutArg :: CoreArg -> SpecM (CoreArg, UsageDetails, - CoreExpr -> CoreExpr) +specArg (VarArg v) -specOutArg (TyArg ty) -- already speced; no action - = returnSM (TyArg ty, emptyUDs, id) -specOutArg other_arg -- unprocessed; spec the atom - = specValArg other_arg +specArgs [] thing_inside + = thing_inside [] + +specArgs (arg:args) thing_inside + = specArg arg $ \ arg' -> + specArgs args $ \ args' -> + thing_inside (arg' : args') \end{code} @@ -1839,11 +1835,11 @@ 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 "{", - interppSP PprDebug new_ids, - ppStr "}"]) - 4 (ppAboves [ppAboves (map (pprGenType PprDebug . idType) new_ids), - ppAboves (map pprCI (concat equiv_ciss))])) + ) (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 @@ -1907,21 +1903,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 @@ -1943,7 +1939,7 @@ mkOneInst do_cis@(CallInstance _ spec_tys dict_args _ _) explicit_cis 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 @@ -2021,7 +2017,7 @@ mkOneInst do_cis@(CallInstance _ spec_tys dict_args _ _) explicit_cis mkCoLetsNoUnboxed local_dict_binds (mkTyLam poly_tyvars inst_rhs)), tickSpecInsts final_uds, spec_info) where - lookup_orig_spec = lookupSpecEnv (getIdSpecialisation orig_id) arg_tys + 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 @@ -2030,19 +2026,19 @@ mkOneInst do_cis@(CallInstance _ spec_tys dict_args _ _) explicit_cis 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]) + (hsep [ppr new_id, hsep (map pp_ty arg_tys), + ptext SLIT("==>"), ppr spec_id]) in (if opt_SpecialiseTrace then pprTrace "Specialising:" - (ppHang (ppBesides [ppStr "{", - interppSP PprDebug new_ids, - ppStr "}"]) - 4 (ppAboves [ - ppBesides [ppStr "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]])) + (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) -> @@ -2050,8 +2046,8 @@ mkOneInst do_cis@(CallInstance _ spec_tys dict_args _ _) explicit_cis returnSM (maybe_inst_bind, inst_uds, spec_infos) ) where - pp_dict d = ppr_arg PprDebug d - pp_ty t = pprParendGenType PprDebug t + 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) @@ -2067,249 +2063,67 @@ 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 + | 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 - -- No call instances for SuperDictSelIds - -- These are a special case in mkCall - - | maybeToBool (isSuperDictSelId_maybe id) - = 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 - = let - spec_overloading = opt_SpecialiseOverloaded - spec_unboxed = opt_SpecialiseUnboxed - spec_all = opt_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 + = returnSM (singleCI new_id spec_tys dicts) - record_spec id tys - = (record, lookup, spec_tys) - where - spec_tys = specialiseCallTys spec_all spec_unboxed spec_overloading - (mkConstraintVector id) tys - - 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 : map (ppr_arg 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 ((TyArg ty,_,_):args) - = case (take_type_args tyvars class_tyvar_pairs args) of - Nothing -> Nothing + 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) class_tyvar_pairs [] = Nothing + take_type_args (_:tyvars) [] = Nothing -take_type_args [] class_tyvar_pairs args + 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 + 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) [] = Nothing - -take_dict_args [] args = Just ([], args) -\end{code} - -\begin{code} -mkCall :: Id - -> [(CoreArg, UsageDetails, CoreExpr -> CoreExpr)] - -> SpecM CoreExpr - -mkCall new_id arg_infos = returnSM (mkGenApp (Var new_id) [arg | (arg, _, _) <- arg_infos]) - -{- - | 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), - ppStr "==>", - 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 + 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 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} \begin{code} mkTyConInstance :: Id @@ -2320,17 +2134,17 @@ mkTyConInstance con tys case record_inst of Nothing -- No TyCon instance -> -- pprTrace "NoTyConInst:" - -- (ppCat [ppr PprDebug tycon, ppStr "at", - -- ppr PprDebug con, ppCat (map (ppr PprDebug) tys)]) + -- (hsep [ppr tycon, ptext SLIT("at"), + -- ppr con, hsep (map (ppr) tys)]) (returnSM (singleConUDs con)) Just spec_tys -- Record TyCon instance -> -- pprTrace "TyConInst:" - -- (ppCat [ppr PprDebug tycon, ppStr "at", - -- ppr PprDebug con, ppCat (map (ppr PprDebug) tys), - -- ppBesides [ppStr "(", - -- ppCat [pprMaybeTy PprDebug ty | ty <- spec_tys], - -- ppStr ")"]]) + -- (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 @@ -2352,8 +2166,8 @@ recordTyConInst con tys tys) in -- pprTrace "ConSpecExists?: " - -- (ppAboves [ppStr (if spec_exists then "True" else "False"), - -- ppr PprShowAll con, ppCat (map (ppr PprDebug) tys)]) + -- (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) @@ -2384,8 +2198,7 @@ type SpecM result -> UniqSupply -> result -initSM m uniqs - = m nullTyVarEnv nullIdEnv uniqs +initSM m uniqs = m emptyTyVarEnv nullIdEnv uniqs returnSM :: a -> SpecM a thenSM :: SpecM a -> (a -> SpecM b) -> SpecM b @@ -2414,7 +2227,7 @@ newSpecIds :: [Id] -- The id of which to make a specialised version 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 ] + | (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 @@ -2471,7 +2284,7 @@ cloneLetBinders top_lev is_rec old_ids 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 @@ -2530,8 +2343,7 @@ bindSpecIds olds clones spec_infos specm tvenv idenv us 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))) + = NoLift (VarArg (new `addIdSpecialisation` (mkSpecEnv spec_infos_this_id))) add_spec_info lifted = lifted -- no specialised instances for unboxed lifted values @@ -2558,7 +2370,7 @@ lookupId id tvenv idenv us specTy :: Type -> SpecM Type -- Apply the current type envt to the type specTy ty tvenv idenv us - = applyTypeEnvToTy tvenv ty + = instantiateTy tvenv ty \end{code} \begin{code} @@ -2600,4 +2412,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" + (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}