\section[Specialise]{Stamping out overloading, and (optionally) polymorphism}
\begin{code}
-#include "HsVersions.h"
-
module Specialise (
specProgram,
initSpecData,
SpecialiseData(..)
) where
-IMP_Ubiq(){-uitous-}
-IMPORT_1_3(List(partition))
+#include "HsVersions.h"
import Bag ( emptyBag, unitBag, isEmptyBag, unionBags,
- partitionBag, listToBag, bagToList
+ partitionBag, listToBag, bagToList, Bag
)
-import Class ( GenClass{-instance Eq-} )
+import Class ( Class )
import CmdLineOpts ( opt_SpecialiseImports, opt_D_simplifier_stats,
- opt_CompilingGhcInternals, opt_SpecialiseTrace
+ opt_SpecialiseTrace
)
import CoreLift ( mkLiftedId, liftExpr, bindUnlift, applyBindUnlifts )
import CoreSyn
import CoreUtils ( coreExprType, squashableDictishCcExpr )
import FiniteMap ( addListToFM_C, FiniteMap )
-import Kind ( mkBoxedTypeKind )
+import Kind ( mkBoxedTypeKind, isBoxedTypeKind )
import Id ( idType, isDefaultMethodId_maybe, toplevelishId,
- isSuperDictSelId_maybe, isBottomingId,
- isConstMethodId_maybe, isDataCon,
+ isBottomingId,
+ isDataCon,
isImportedId, mkIdWithNewUniq,
dataConTyCon, applyTypeEnvToId,
nullIdEnv, addOneToIdEnv, growIdEnvList,
- lookupIdEnv, SYN_IE(IdEnv),
+ lookupIdEnv, IdEnv,
emptyIdSet, mkIdSet, unitIdSet,
elementOfIdSet, minusIdSet,
- unionIdSets, unionManyIdSets, SYN_IE(IdSet),
- GenId{-instance Eq-}
+ unionIdSets, unionManyIdSets, IdSet,
+ GenId{-instance Eq-}, Id
)
import Literal ( Literal{-instance Outputable-} )
import Maybes ( catMaybes, firstJust, maybeToBool )
import Name ( isLocallyDefined )
-import Outputable ( interppSP, Outputable(..){-instance * []-} )
-import PprStyle ( PprStyle(..) )
import PprType ( pprGenType, pprParendGenType, pprMaybeTy,
GenType{-instance Outputable-}, GenTyVar{-ditto-},
TyCon{-ditto-}
)
-import Pretty ( ppHang, ppCat, ppStr, ppAboves, ppBesides, 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 Type ( mkTyVarTy, mkTyVarTys, isTyVarTy, splitAlgTyConApp,
+ tyVarsOfTypes, instantiateTy, isUnboxedType, isDictTy,
+ Type
)
import TyCon ( TyCon{-instance Eq-} )
import TyVar ( cloneTyVar, mkSysTyVar,
- elementOfTyVarSet, SYN_IE(TyVarSet),
- nullTyVarEnv, growTyVarEnvList, SYN_IE(TyVarEnv),
+ elementOfTyVarSet, TyVarSet,
+ emptyTyVarEnv, growTyVarEnvList, TyVarEnv,
GenTyVar{-instance Eq-}
)
import TysWiredIn ( liftDataCon )
import UniqSet ( mkUniqSet, unionUniqSets, uniqSetToList )
import UniqSupply ( splitUniqSupply, getUniques, getUnique )
import Util ( equivClasses, mapAccumL, assoc, zipEqual, zipWithEqual,
- thenCmp, panic, pprTrace, pprPanic, assertPanic
+ thenCmp
)
+import List ( partition )
+import Outputable
infixr 9 `thenSM`
strictness analyser deems the lifted binding strict.
+A note about non-tyvar dictionaries
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Some Ids have types like
+
+ forall a,b,c. Eq a -> Ord [a] -> tau
+
+This seems curious at first, because we usually only have dictionary
+args whose types are of the form (C a) where a is a type variable.
+But this doesn't hold for the functions arising from instance decls,
+which sometimes get arguements with types of form (C (T a)) for some
+type constructor T.
+
+Should we specialise wrt this compound-type dictionary? We used to say
+"no", saying:
+ "This is a heuristic judgement, as indeed is the fact that we
+ specialise wrt only dictionaries. We choose *not* to specialise
+ wrt compound dictionaries because at the moment the only place
+ they show up is in instance decls, where they are simply plugged
+ into a returned dictionary. So nothing is gained by specialising
+ wrt them."
+
+But it is simpler and more uniform to specialise wrt these dicts too;
+and in future GHC is likely to support full fledged type signatures
+like
+ f ;: Eq [(a,b)] => ...
+
%************************************************************************
%* *
\end{code}
\begin{code}
-pprCI :: CallInstance -> Pretty
+pprCI :: CallInstance -> Doc
pprCI (CallInstance id spec_tys dicts _ maybe_specinfo)
- = ppHang (ppCat [ppPStr SLIT("Call inst for"), ppr PprDebug id])
- 4 (ppAboves [ppCat (ppStr "types" : [pprMaybeTy PprDebug ty | ty <- spec_tys]),
+ = hang (hsep [ptext SLIT("Call inst for"), ppr id])
+ 4 (vcat [hsep (text "types" : [pprMaybeTy ty | ty <- spec_tys]),
case maybe_specinfo of
- Nothing -> ppCat (ppStr "dicts" : [ppr_arg PprDebug dict | dict <- dicts])
+ Nothing -> hsep (text "dicts" : [ppr_arg dict | dict <- dicts])
Just (SpecInfo _ _ spec_id)
- -> ppCat [ppPStr SLIT("Explicit SpecId"), ppr PprDebug spec_id]
+ -> hsep [ptext SLIT("Explicit SpecId"), ppr spec_id]
])
-- ToDo: instance Outputable CoreArg?
-ppr_arg sty (TyArg t) = ppr sty t
-ppr_arg sty (LitArg i) = ppr sty i
-ppr_arg sty (VarArg v) = ppr sty v
+ppr_arg (TyArg t) = ppr sty t
+ppr_arg (LitArg i) = ppr sty i
+ppr_arg (VarArg v) = ppr sty v
isUnboxedCI :: CallInstance -> Bool
isUnboxedCI (CallInstance _ spec_tys _ _ _)
\begin{code}
-cmpCI :: CallInstance -> CallInstance -> TAG_
+cmpCI :: CallInstance -> CallInstance -> Ordering
cmpCI (CallInstance id1 tys1 _ _ _) (CallInstance id2 tys2 _ _ _)
- = cmp id1 id2 `thenCmp` cmpUniTypeMaybeList tys1 tys2
+ = compare id1 id2 `thenCmp` cmpUniTypeMaybeList tys1 tys2
-cmpCI_tys :: CallInstance -> CallInstance -> TAG_
+cmpCI_tys :: CallInstance -> CallInstance -> Ordering
cmpCI_tys (CallInstance _ tys1 _ _ _) (CallInstance _ tys2 _ _ _)
= cmpUniTypeMaybeList tys1 tys2
eqCI_tys :: CallInstance -> CallInstance -> Bool
eqCI_tys c1 c2
- = case cmpCI_tys c1 c2 of { EQ_ -> True; other -> False }
+ = case cmpCI_tys c1 c2 of { EQ -> True; other -> False }
isCIofTheseIds :: [Id] -> CallInstance -> Bool
isCIofTheseIds ids (CallInstance ci_id _ _ _ _)
cis_here_list = bagToList cis_here
in
-- pprTrace "getCIs:"
- -- (ppHang (ppBesides [ppChar '{',
- -- interppSP PprDebug ids,
- -- ppChar '}'])
- -- 4 (ppAboves (map pprCI cis_here_list)))
+ -- (hang (hcat [char '{',
+ -- interppSP ids,
+ -- char '}'])
+ -- 4 (vcat (map pprCI cis_here_list)))
(cis_here_list, UsageDetails cis_not_here tycon_cis dbs fvs c i)
dumpCIs :: Bag CallInstance -- The call instances
then
pprTrace ("dumpCIs: dumping CI which was not instantiated ... \n" ++
" (may be a non-HM recursive call)\n")
- (ppHang (ppBesides [ppChar '{',
- interppSP PprDebug bound_ids,
- ppChar '}'])
- 4 (ppAboves [ppPStr SLIT("Dumping CIs:"),
- ppAboves (map pprCI (bagToList cis_of_bound_id)),
- ppPStr SLIT("Instantiating CIs:"),
- ppAboves (map pprCI inst_cis)]))
+ (hang (hcat [char '{',
+ interppSP bound_ids,
+ char '}'])
+ 4 (vcat [ptext SLIT("Dumping CIs:"),
+ vcat (map pprCI (bagToList cis_of_bound_id)),
+ ptext SLIT("Instantiating CIs:"),
+ vcat (map pprCI inst_cis)]))
else id) (
if top_lev || floating then
cis_not_bound_id
else
(if not (isEmptyBag cis_dump_unboxed)
then pprTrace "dumpCIs: bound dictionary arg ... WITH UNBOXED TYPES!\n"
- (ppHang (ppBesides [ppChar '{',
- interppSP PprDebug full_ids,
- ppChar '}'])
- 4 (ppAboves (map pprCI (bagToList cis_dump))))
+ (hang (hcat [char '{',
+ interppSP full_ids,
+ char '}'])
+ 4 (vcat (map pprCI (bagToList cis_dump))))
else id)
cis_keep_not_bound_id
)
= TyConInstance TyCon -- Type Constructor
[Maybe Type] -- Applied to these specialising types
-cmpTyConI :: TyConInstance -> TyConInstance -> TAG_
+cmpTyConI :: TyConInstance -> TyConInstance -> Ordering
cmpTyConI (TyConInstance tc1 tys1) (TyConInstance tc2 tys2)
- = cmp tc1 tc2 `thenCmp` cmpUniTypeMaybeList tys1 tys2
+ = compare tc1 tc2 `thenCmp` cmpUniTypeMaybeList tys1 tys2
-cmpTyConI_tys :: TyConInstance -> TyConInstance -> TAG_
+cmpTyConI_tys :: TyConInstance -> TyConInstance -> Ordering
cmpTyConI_tys (TyConInstance _ tys1) (TyConInstance _ tys2)
= cmpUniTypeMaybeList tys1 tys2
&& (not opt_SpecialiseImports || isEmptyBag cis_warn)
in
(if opt_D_simplifier_stats then
- pprTrace "\nSpecialiser Stats:\n" (ppAboves [
- ppBesides [ppPStr SLIT("SpecCalls "), ppInt spec_calls],
- ppBesides [ppPStr SLIT("SpecInsts "), ppInt spec_insts],
- ppSP])
+ pprTrace "\nSpecialiser Stats:\n" (vcat [
+ hcat [ptext SLIT("SpecCalls "), int spec_calls],
+ hcat [ptext SLIT("SpecInsts "), int spec_insts],
+ space])
else id)
(final_binds,
= scopeM `thenSM` \ (binds, scope_uds) ->
let
(tycons_cis, gotci_scope_uds)
- = getLocalSpecTyConIs opt_CompilingGhcInternals scope_uds
+ = getLocalSpecTyConIs False{-OLD:opt_CompilingGhcInternals-} scope_uds
tycon_specs_list = collectTyConSpecs tycons_cis
in
(if opt_SpecialiseTrace && not (null tycon_specs_list) then
pprTrace "Specialising TyCons:\n"
- (ppAboves [ if not (null specs) then
- ppHang (ppCat [(ppr PprDebug tycon), ppPStr SLIT("at types")])
- 4 (ppAboves (map pp_specs specs))
- else ppNil
+ (vcat [ if not (null specs) then
+ hang (hsep [(ppr tycon), ptext SLIT("at types")])
+ 4 (vcat (map pp_specs specs))
+ else empty
| (tycon, specs) <- tycon_specs_list])
else id) (
returnSM (binds, tycon_specs_list, gotci_scope_uds)
uniq_cis = map head (equivClasses cmpTyConI_tys tycon_cis)
tycon_specs = [(False, spec_tys) | TyConInstance _ spec_tys <- uniq_cis]
- pp_specs (False, spec_tys) = ppInterleave ppNil [pprMaybeTy PprDebug spec_ty | spec_ty <- spec_tys]
+ pp_specs (False, spec_tys) = hsep [pprMaybeTy spec_ty | spec_ty <- spec_tys]
\end{code}
-- alternatives:
(_, ty_args, _) = --trace "Specialise.specAlts:getAppData..." $
- getAppDataTyConExpandingDicts scrutinee_ty
+ splitAlgTyConApp scrutinee_ty
specAlgAlt ty_args (con,binders,rhs)
= specLambdaOrCaseBody binders rhs args `thenSM` \ (binders, rhs, rhs_uds) ->
else if top_lev
then pprTrace "dumpCIs: not same overloading ... top level \n"
else (\ x y -> y)
- ) (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))]))
+ ) (hang (hcat [ptext SLIT("{"),
+ interppSP new_ids,
+ ptext SLIT("}")])
+ 4 (vcat [vcat (map (pprGenType . idType) new_ids),
+ vcat (map pprCI (concat equiv_ciss))]))
(returnSM ([], emptyUDs, []))
where
mkCoLetsNoUnboxed local_dict_binds (mkTyLam poly_tyvars inst_rhs)),
tickSpecInsts final_uds, spec_info)
where
- lookup_orig_spec = lookupSpecEnv (getIdSpecialisation orig_id) arg_tys
+ lookup_orig_spec = matchSpecEnv (getIdSpecialisation orig_id) arg_tys
explicit_cis_for_this_id = filter (isCIofTheseIds [new_id]) explicit_cis
[CallInstance _ _ _ _ (Just explicit_spec_info)] = explicit_cis_for_this_id
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),
- ppPStr SLIT("==>"), ppr PprDebug spec_id])
+ (hsep [ppr new_id, hsep (map pp_ty arg_tys),
+ ptext SLIT("==>"), ppr spec_id])
in
(if opt_SpecialiseTrace then
pprTrace "Specialising:"
- (ppHang (ppBesides [ppChar '{',
- interppSP PprDebug new_ids,
- ppChar '}'])
- 4 (ppAboves [
- ppBesides [ppPStr SLIT("types: "), ppInterleave ppNil (map pp_ty arg_tys)],
- if isExplicitCI do_cis then ppNil else
- ppBesides [ppPStr SLIT("dicts: "), ppInterleave ppNil (map pp_dict dict_args)],
- ppBesides [ppPStr SLIT("specs: "), ppr PprDebug spec_ids]]))
+ (hang (hcat [char '{',
+ interppSP new_ids,
+ char '}'])
+ 4 (vcat [
+ hcat [ptext SLIT("types: "), hsep (map pp_ty arg_tys)],
+ if isExplicitCI do_cis then empty else
+ hcat [ptext SLIT("dicts: "), hsep (map pp_dict dict_args)],
+ hcat [ptext SLIT("specs: "), ppr spec_ids]]))
else id) (
do_bind orig_bind `thenSM` \ (maybe_inst_bind, inst_uds, spec_infos) ->
returnSM (maybe_inst_bind, inst_uds, spec_infos)
)
where
- pp_dict d = ppr_arg PprDebug d
- pp_ty t = pprParendGenType PprDebug t
+ pp_dict d = ppr_arg d
+ pp_ty t = pprParendGenType t
do_the_wotsit (tyvar:tyvars) Nothing = (tyvars, mkTyVarTy tyvar)
do_the_wotsit tyvars (Just ty) = (tyvars, ty)
mkCallInstance id new_id args
| 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 (singleCI new_id spec_tys dicts)
where
- (tyvars, class_tyvar_pairs) = getIdOverloading id
- constrained_tyvars = map snd class_tyvar_pairs -- May contain dups
- constraint_vec = [tyvar `elem` constrained_tyvars | tyvar <- tyvars]
+ (tyvars, theta, _) = splitSigmaTy (idType id)
+ constrained_tyvars = tyvarsOfTypes (map snd class_tyvar_pairs)
arg_res = take_type_args tyvars class_tyvar_pairs args
enough_args = maybeToBool arg_res
(Just (tys, dicts, rest_args)) = arg_res
- interesting_overloading = any (not . isTyVarTy) (catMaybes spec_tys)
- spec_tys = specialiseCallTys constraint_vec tys
+ interesting_overloading = not (null (catMaybes spec_tys))
+ spec_tys = zipWithEqual "spec_ty" spec_ty tyvars tys
+
+ ---------------------------------------------------------------
+ -- Should we specialise on this type argument?
+ spec_ty tyvar ty | isTyVarTy ty = Nothing
+
+ spec_ty tyvar ty | opt_SpecialiseAll
+ || (opt_SpecialiseUnboxed
+ && isUnboxedType ty
+ && isBoxedTypeKind (tyVarKind tyvar))
+ || (opt_SpecialiseOverloaded
+ && tyvar `elemTyVarSet` constrained_tyvars)
+ = Just ty
+
+ | otherwise = Nothing
----------------- Rather a gruesome help-function ---------------
take_type_args (_:tyvars) (TyArg ty : args)
case record_inst of
Nothing -- No TyCon instance
-> -- pprTrace "NoTyConInst:"
- -- (ppCat [ppr PprDebug tycon, ppPStr SLIT("at"),
- -- ppr PprDebug con, ppCat (map (ppr PprDebug) tys)])
+ -- (hsep [ppr tycon, ptext SLIT("at"),
+ -- ppr con, hsep (map (ppr) tys)])
(returnSM (singleConUDs con))
Just spec_tys -- Record TyCon instance
-> -- pprTrace "TyConInst:"
- -- (ppCat [ppr PprDebug tycon, ppPStr SLIT("at"),
- -- ppr PprDebug con, ppCat (map (ppr PprDebug) tys),
- -- ppBesides [ppChar '(',
- -- ppCat [pprMaybeTy PprDebug ty | ty <- spec_tys],
- -- ppChar ')']])
+ -- (hsep [ppr tycon, ptext SLIT("at"),
+ -- ppr con, hsep (map (ppr) tys),
+ -- hcat [char '(',
+ -- hsep [pprMaybeTy ty | ty <- spec_tys],
+ -- char ')']])
(returnSM (singleTyConI tycon spec_tys `unionUDs` singleConUDs con))
where
tycon = dataConTyCon con
tys)
in
-- pprTrace "ConSpecExists?: "
- -- (ppAboves [ppPStr (if spec_exists then SLIT("True") else SLIT("False")),
- -- ppr PprShowAll con, ppCat (map (ppr PprDebug) tys)])
+ -- (vcat [ptext (if spec_exists then SLIT("True") else SLIT("False")),
+ -- ppr PprShowAll con, hsep (map ppr tys)])
(if (not spec_exists && do_tycon_spec)
then returnSM (Just spec_tys)
else returnSM Nothing)
-> UniqSupply
-> result
-initSM m uniqs = m nullTyVarEnv nullIdEnv uniqs
+initSM m uniqs = m emptyTyVarEnv nullIdEnv uniqs
returnSM :: a -> SpecM a
thenSM :: SpecM a -> (a -> SpecM b) -> SpecM b
mk_old_to_clone rest_olds rest_clones spec_infos_rest
where
add_spec_info (NoLift (VarArg new))
- = NoLift (VarArg (new `addIdSpecialisation`
- (mkSpecEnv spec_infos_this_id)))
+ = NoLift (VarArg (new `addIdSpecialisation` (mkSpecEnv spec_infos_this_id)))
add_spec_info lifted
= lifted -- no specialised instances for unboxed lifted values
specTy :: Type -> SpecM Type -- Apply the current type envt to the type
specTy ty tvenv idenv us
- = applyTypeEnvToTy tvenv ty
+ = instantiateTy tvenv ty
\end{code}
\begin{code}
(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])
+ (hsep [ppr new_id,
+ hsep (map (pprParendGenType) ty_args),
+ ptext SLIT("==>"),
+ ppr spec_id])
else
let
(vals_left, _, unlifts_left) = unzip3 args_left
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)])
+ (hsep [ppr check_id,
+ hsep (map (pprParendGenType) tys)])
else id
checkSpecOK :: Id -> [Type] -> Id -> [Type] -> a -> a
checkSpecOK check_id tys spec_id tys_left
= if any isUnboxedType tys_left
then pprPanic "Specialise:checkSpecOK: unboxed type args in specialised application\n"
- (ppAboves [ppCat [ppr PprDebug check_id,
- ppInterleave ppNil (map (pprParendGenType PprDebug) tys)],
- ppCat [ppr PprDebug spec_id,
- ppInterleave ppNil (map (pprParendGenType PprDebug) tys_left)]])
+ (vcat [hsep [ppr check_id,
+ hsep (map (pprParendGenType) tys)],
+ hsep [ppr spec_id,
+ hsep (map (pprParendGenType) tys_left)]])
else id
-}
\end{code}