specProgram,
initSpecData,
- SpecialiseData(..),
- FiniteMap, Bag
-
+ SpecialiseData(..)
) where
-import Ubiq{-uitous-}
+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-} )
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 PrelInfo ( liftDataCon )
import Pretty ( ppHang, ppCat, ppStr, ppAboves, ppBesides,
- ppInt, ppSP, ppInterleave, ppNil, Pretty(..)
+ ppInt, ppSP, ppInterleave, ppNil, SYN_IE(Pretty)
)
import PrimOp ( PrimOp(..) )
import SpecUtils
-import Type ( mkTyVarTy, mkTyVarTys, isTyVarTy, getAppDataTyCon,
+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 )
import Unique ( Unique{-instance Eq-} )
import UniqSet ( mkUniqSet, unionUniqSets, uniqSetToList )
import UniqSupply ( splitUniqSupply, getUniques, getUnique )
-import Util ( equivClasses, mapAccumL, assoc, zipWithEqual,
- panic, pprTrace, pprPanic, assertPanic
+import Util ( equivClasses, mapAccumL, assoc, zipEqual, zipWithEqual,
+ thenCmp, panic, pprTrace, pprPanic, assertPanic
)
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)"
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)"
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 _ _ _)
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)
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)
= 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
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)
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}
-- We use ty_args of scrutinee type to identify specialisation of
-- alternatives:
- (_, ty_args, _) = getAppDataTyCon 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) ->
-- "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)
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
\begin{code}
mkCall :: Id
-> [(CoreArg, UsageDetails, CoreExpr -> CoreExpr)]
- -> SpecM (Bool, CoreExpr)
+ -> SpecM CoreExpr
+
+mkCall new_id arg_infos = returnSM (mkGenApp (Var new_id) [arg | (arg, _, _) <- arg_infos])
-mkCall new_id args
+{-
| maybeToBool (isSuperDictSelId_maybe new_id)
&& any isUnboxedType ty_args
-- No specialisations for super-dict selectors
ppCat [ppr PprDebug spec_id,
ppInterleave ppNil (map (pprParendGenType PprDebug) tys_left)]])
else id
+-}
\end{code}
\begin{code}
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 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
= 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))
projects / ghc-hetmet.git / blobdiff