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,
+ opt_SpecialiseOverloaded, opt_SpecialiseUnboxed,
+ opt_SpecialiseAll
)
-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,
+ ppInt, ppSP, ppInterleave, ppNil, SYN_IE(Pretty)
+ )
+import PrimOp ( PrimOp(..) )
+import SpecUtils
+import Type ( mkTyVarTy, mkTyVarTys, isTyVarTy, getAppDataTyConExpandingDicts,
+ tyVarsOfTypes, applyTypeEnvToTy, isUnboxedType
+ )
+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`
+
+--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)"
+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}
%************************************************************************
%************************************************************************
\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}
= ppHang (ppCat [ppStr "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]
])
+-- 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 _))
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 _ _ _)
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
cis_here_list = bagToList cis_here
in
-- pprTrace "getCIs:"
- -- (ppHang (ppBesides [ppStr "{", ppr PprDebug ids, ppStr "}"])
+ -- (ppHang (ppBesides [ppStr "{",
+ -- interppSP PprDebug ids,
+ -- ppStr "}"])
-- 4 (ppAboves (map pprCI cis_here_list)))
(cis_here_list, UsageDetails cis_not_here tycon_cis dbs fvs c i)
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 "}"])
+ (ppHang (ppBesides [ppStr "{",
+ interppSP PprDebug bound_ids,
+ ppStr "}"])
4 (ppAboves [ppStr "Dumping CIs:",
ppAboves (map pprCI (bagToList cis_of_bound_id)),
ppStr "Instantiating CIs:",
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 [ppStr "{",
+ interppSP PprDebug full_ids,
+ ppStr "}"])
4 (ppAboves (map pprCI (bagToList cis_dump))))
else id)
cis_keep_not_bound_id
= 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
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)
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
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
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)
(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}
%************************************************************************
\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
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],
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,
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"])
(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
\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 ->
returnSM (bindUnlift vl vu (Var vu), singleFvUDs (VarArg vl))
NoLift vatom@(VarArg new_v)
- -> mapSM specArg args `thenSM` \ arg_info ->
+ -> 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 (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),
+ 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)
-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),
+ 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)
-specExpr (Prim prim tys args) null_args
+specExpr (Prim prim args) null_args
= ASSERT (null null_args)
- mapSM specTy tys `thenSM` \ tys ->
- mapAndUnzip3SM specAtom args `thenSM` \ (args, args_uds_s, unlifts) ->
+ let
+ (targs, vargs) = partition_args args
+ in
+ mapAndUnzipSM specTyArg targs `thenSM` \ (targs, tys) ->
+ mapAndUnzip3SM specValArg vargs `thenSM` \ (vargs, args_uds_s, unlifts) ->
-- specPrimOp prim tys `thenSM` \ (prim, tys, prim_uds) ->
- returnSM (applyBindUnlifts unlifts (Prim prim tys args),
+ returnSM (applyBindUnlifts unlifts (Prim prim (targs ++ vargs)),
unionUDList args_uds_s {-`unionUDs` prim_uds-} )
{- ToDo: specPrimOp
specExpr (App fun arg) args
- = -- Arg is passed on unprocessed
- specExpr fun (ValArg arg : args) `thenSM` \ (expr,uds) ->
+ = -- If TyArg, arg will be processed; otherwise, left alone
+ preSpecArg 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) (
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
where
scrutinee_type = coreExprType scrutinee
-
specExpr (Let bind body) args
= specBindAndScope False bind (
specExpr body args `thenSM` \ (body, body_uds) ->
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_
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}
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:
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) ->
%************************************************************************
\begin{code}
-specAtom :: CoreArg -> SpecM (CoreArg, UsageDetails,
- CoreExpr -> CoreExpr)
+partition_args :: [CoreArg] -> ([CoreArg], [CoreArg])
+partition_args args
+ = span is_ty_arg args
+ where
+ is_ty_arg (TyArg _) = True
+ 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
-specAtom (LitArg lit)
+--------------------
+specValArg :: CoreArg -> SpecM (CoreArg, UsageDetails,
+ CoreExpr -> CoreExpr)
+
+specValArg (LitArg lit)
= returnSM (LitArg lit, emptyUDs, id)
-specAtom (VarArg v)
+specValArg (VarArg v)
= lookupId v `thenSM` \ vlookup ->
case vlookup of
Lifted vl vu
-> returnSM (vatom, singleFvUDs vatom, id)
-specArg :: CoreArg -> SpecM (CoreArg, UsageDetails,
+------------------
+specTyArg (TyArg ty)
+ = specTy ty `thenSM` \ new_ty ->
+ returnSM (TyArg new_ty, new_ty)
+
+--------------
+specOutArg :: CoreArg -> SpecM (CoreArg, UsageDetails,
CoreExpr -> CoreExpr)
-specArg (ValArg arg) -- unprocessed; spec the atom
- = specAtom arg `thenSM` \ (arg, uds, unlift) ->
- returnSM (ValArg arg, uds, unlift)
+specOutArg (TyArg ty) -- already speced; no action
+ = returnSM (TyArg ty, emptyUDs, id)
-specArg (TypeArg ty) -- already speced; no action
- = returnSM (TypeArg ty, emptyUDs, id)
+specOutArg other_arg -- unprocessed; spec the atom
+ = specValArg other_arg
\end{code}
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 [ppStr "{",
+ interppSP PprDebug new_ids,
+ ppStr "}"])
+ 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
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) = 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
-- 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)
-- 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) (
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]
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])
in
- (if sw_chkr SpecialiseTrace then
+ (if opt_SpecialiseTrace then
pprTrace "Specialising:"
- (ppHang (ppBesides [ppStr "{", ppr PprDebug new_ids, ppStr "}"])
+ (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
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)
-- 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
+ = let
+ spec_overloading = opt_SpecialiseOverloaded
+ spec_unboxed = opt_SpecialiseUnboxed
+ spec_all = opt_SpecialiseAll
(tyvars, class_tyvar_pairs) = getIdOverloading id
in
if (not enough_args) then
pprPanic "Specialise:recordCallInst: Unsaturated Type & Dict Application:\n\t"
- (ppCat [ppr PprDebug id, ppr PprDebug [arg | (arg,_,_) <- args] ])
+ (ppCat (ppr PprDebug id : map (ppr_arg PprDebug) [arg | (arg,_,_) <- args]))
else
case record_spec id tys of
(False, _, _)
(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 (_:tyvars) class_tyvar_pairs ((TyArg 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)
+ = 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) [] = Nothing
+
+take_dict_args [] args = Just ([], args)
\end{code}
\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 isUnboxedDataType ty_args
+ && 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
-- These top level defns should have been lifted.
-- We must add code to unlift such a spec_id.
- if isUnboxedDataType (idType spec_id) then
+ 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) ->
else
pprPanic "Specialise:mkCall: unboxed spec_id not top-level ...\n"
(ppCat [ppr PprDebug new_id,
- ppInterleave ppNil (map (pprParendType PprDebug) ty_args),
+ ppInterleave ppNil (map (pprParendGenType 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_tys = mkTyApp (Var spec_id) tys_left
applied_vals = mkGenApp applied_tys vals_left
in
returnSM (True, applyBindUnlifts unlifts_left applied_vals)
(ty_args, val_args) = get args
where
- get ((TypeArg ty,_,_) : args) = (ty : tys, rest) where (tys,rest) = get args
- get args = ([], args)
+ 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 ((ValArg _,_,_) : args) = toss_dicts (n-1) args
+ 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 isUnboxedDataType 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 (pprParendType PprDebug) tys)])
+ 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 isUnboxedDataType 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 (pprParendType PprDebug) tys)],
+ ppInterleave ppNil (map (pprParendGenType PprDebug) tys)],
ppCat [ppr PprDebug spec_id,
- ppInterleave ppNil (map (pprParendType PprDebug) tys_left)]])
+ ppInterleave ppNil (map (pprParendGenType PprDebug) tys_left)]])
else id
+-}
\end{code}
\begin{code}
-- ppStr ")"]])
(returnSM (singleTyConI tycon spec_tys `unionUDs` singleConUDs con))
where
- tycon = getDataConTyCon con
+ tycon = dataConTyCon con
\end{code}
\begin{code}
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!
-> 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
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))
-> [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
-- (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,
cloneTyVarSM :: TyVar -> SpecM TyVar
-cloneTyVarSM old_tyvar sw_chkr tvenv idenv us
+cloneTyVarSM old_tyvar tvenv idenv us
= let
uniq = getUnique us
in
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
-> 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
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
\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
projects / ghc-hetmet.git / blobdiff