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}
%************************************************************************
%************************************************************************
\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 _))
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 [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)
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
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
= 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
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*.
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}
+-}
+
data SpecialiseData
= SpecData Bool
-- True <=> Specialisation performed
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.
%************************************************************************
\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],
+ ppBesides [ppPStr SLIT("SpecCalls "), ppInt spec_calls],
+ ppBesides [ppPStr SLIT("SpecInsts "), ppInt spec_insts],
ppSP])
else id)
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"])
+ ppHang (ppCat [(ppr PprDebug tycon), ppPStr SLIT("at types")])
4 (ppAboves (map pp_specs specs))
else ppNil
| (tycon, specs) <- tycon_specs_list])
(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 ->
- 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
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) (
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)
-
-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}
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
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
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
-- 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])
+ 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) ->
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)
\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
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}
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)
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
-- 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,
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
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}
projects / ghc-hetmet.git / blobdiff