X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=ghc%2Fcompiler%2Fspecialise%2FSpecialise.lhs;h=8164e0ce052aee5f7435126d95a82816df5574af;hp=dcbf88c18153c45b47fccaded1530fd120e633a6;hb=5eb1c77c795f92ed0f4c8023847e9d4be1a4fd0d;hpb=e7498a3ee1d0484d02a9e86633cc179c76ebf36e diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs index dcbf88c..8164e0c 100644 --- a/ghc/compiler/specialise/Specialise.lhs +++ b/ghc/compiler/specialise/Specialise.lhs @@ -14,30 +14,32 @@ module Specialise ( ) where IMP_Ubiq(){-uitous-} +IMPORT_1_3(List(partition)) import Bag ( emptyBag, unitBag, isEmptyBag, unionBags, partitionBag, listToBag, bagToList ) import Class ( GenClass{-instance Eq-} ) import CmdLineOpts ( opt_SpecialiseImports, opt_D_simplifier_stats, - opt_CompilingPrelude, opt_SpecialiseTrace, + opt_CompilingGhcInternals, opt_SpecialiseTrace, opt_SpecialiseOverloaded, opt_SpecialiseUnboxed, opt_SpecialiseAll ) import CoreLift ( mkLiftedId, liftExpr, bindUnlift, applyBindUnlifts ) import CoreSyn import CoreUtils ( coreExprType, squashableDictishCcExpr ) -import FiniteMap ( addListToFM_C ) +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, IdEnv(..), + lookupIdEnv, SYN_IE(IdEnv), emptyIdSet, mkIdSet, unitIdSet, elementOfIdSet, minusIdSet, - unionIdSets, unionManyIdSets, IdSet(..), + unionIdSets, unionManyIdSets, SYN_IE(IdSet), GenId{-instance Eq-} ) import Literal ( Literal{-instance Outputable-} ) @@ -50,7 +52,7 @@ import PprType ( pprGenType, pprParendGenType, pprMaybeTy, TyCon{-ditto-} ) import Pretty ( ppHang, ppCat, ppStr, ppAboves, ppBesides, - ppInt, ppSP, ppInterleave, ppNil, Pretty(..) + ppInt, ppSP, ppInterleave, ppNil, SYN_IE(Pretty) ) import PrimOp ( PrimOp(..) ) import SpecUtils @@ -58,9 +60,9 @@ import Type ( mkTyVarTy, mkTyVarTys, isTyVarTy, getAppDataTyConExpandingDicts, tyVarsOfTypes, applyTypeEnvToTy, isUnboxedType ) import TyCon ( TyCon{-instance Eq-} ) -import TyVar ( cloneTyVar, - elementOfTyVarSet, TyVarSet(..), - nullTyVarEnv, growTyVarEnvList, TyVarEnv(..), +import TyVar ( cloneTyVar, mkSysTyVar, + elementOfTyVarSet, SYN_IE(TyVarSet), + nullTyVarEnv, growTyVarEnvList, SYN_IE(TyVarEnv), GenTyVar{-instance Eq-} ) import TysWiredIn ( liftDataCon ) @@ -75,7 +77,7 @@ infixr 9 `thenSM` --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)" @@ -86,8 +88,6 @@ isLocalSpecTyCon = panic "Specialise.isLocalSpecTyCon (ToDo)" isSpecId_maybe = panic "Specialise.isSpecId_maybe (ToDo)" isSpecPragmaId_maybe = panic "Specialise.isSpecPragmaId_maybe (ToDo)" lookupClassInstAtSimpleType = panic "Specialise.lookupClassInstAtSimpleType (ToDo)" -lookupSpecEnv = panic "Specialise.lookupSpecEnv (ToDo)" -mkPolySysTyVar = panic "Specialise.mkPolySysTyVar (ToDo)" mkSpecEnv = panic "Specialise.mkSpecEnv (ToDo)" mkSpecId = panic "Specialise.mkSpecId (ToDo)" selectIdInfoForSpecId = panic "Specialise.selectIdInfoForSpecId (ToDo)" @@ -929,11 +929,11 @@ 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) @@ -1198,7 +1198,7 @@ specTyConsAndScope scopeM = scopeM `thenSM` \ (binds, scope_uds) -> let (tycons_cis, gotci_scope_uds) - = getLocalSpecTyConIs opt_CompilingPrelude scope_uds + = getLocalSpecTyConIs opt_CompilingGhcInternals scope_uds tycon_specs_list = collectTyConSpecs tycons_cis in @@ -1297,14 +1297,14 @@ specExpr (Var v) args 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` \ ~(speced, call) -> + 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) + returnSM (call, {- tickSpecCall speced -} uds) specExpr expr@(Lit _) null_args = ASSERT (null null_args) @@ -1531,7 +1531,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..." $ + getAppDataTyConExpandingDicts scrutinee_ty specAlgAlt ty_args (con,binders,rhs) = specLambdaOrCaseBody binders rhs args `thenSM` \ (binders, rhs, rhs_uds) -> @@ -1974,7 +1975,7 @@ mkOneInst do_cis@(CallInstance _ spec_tys dict_args _ _) explicit_cis -- "required" by one of the other Ids in the Rec | top_lev && maybeToBool lookup_orig_spec = (if opt_SpecialiseTrace - then trace_nospec " Exists: " exists_id + then trace_nospec " Exists: " orig_id else id) ( returnSM (Nothing, emptyUDs, Nothing) @@ -2022,7 +2023,6 @@ mkOneInst do_cis@(CallInstance _ spec_tys dict_args _ _) explicit_cis 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 @@ -2198,9 +2198,11 @@ take_dict_args [] args = Just ([], args) \begin{code} mkCall :: Id -> [(CoreArg, UsageDetails, CoreExpr -> CoreExpr)] - -> SpecM (Bool, CoreExpr) + -> SpecM CoreExpr -mkCall new_id args +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 @@ -2307,6 +2309,7 @@ checkSpecOK check_id tys spec_id tys_left ppCat [ppr PprDebug spec_id, ppInterleave ppNil (map (pprParendGenType PprDebug) tys_left)]]) else id +-} \end{code} \begin{code} @@ -2418,10 +2421,8 @@ newSpecIds new_ids maybe_tys dicts_to_ignore tvenv idenv us spec_id_ty id = specialiseTy (idType id) maybe_tys dicts_to_ignore newTyVars :: Int -> SpecM [TyVar] -newTyVars n 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