\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_SpecialiseOverloaded, opt_SpecialiseUnboxed,
- opt_SpecialiseAll
+ 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,
- ppInt, ppSP, ppInterleave, ppNil, SYN_IE(Pretty)
- )
import PrimOp ( PrimOp(..) )
import SpecUtils
-import Type ( mkTyVarTy, mkTyVarTys, isTyVarTy, getAppDataTyConExpandingDicts,
- tyVarsOfTypes, applyTypeEnvToTy, isUnboxedType
+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`
+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)"
-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)"
-lookupSpecEnv = panic "Specialise.lookupSpecEnv (ToDo)"
mkSpecEnv = panic "Specialise.mkSpecEnv (ToDo)"
mkSpecId = panic "Specialise.mkSpecId (ToDo)"
selectIdInfoForSpecId = panic "Specialise.selectIdInfoForSpecId (ToDo)"
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 [ppStr "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 [ppStr "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 [ppStr "{",
- -- interppSP PprDebug ids,
- -- ppStr "}"])
- -- 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 [ppStr "{",
- interppSP PprDebug bound_ids,
- ppStr "}"])
- 4 (ppAboves [ppStr "Dumping CIs:",
- ppAboves (map pprCI (bagToList cis_of_bound_id)),
- ppStr "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 [ppStr "{",
- interppSP PprDebug full_ids,
- ppStr "}"])
- 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
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)
%************************************************************************
\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.
&& (not opt_SpecialiseImports || isEmptyBag cis_warn)
in
(if opt_D_simplifier_stats then
- pprTrace "\nSpecialiser Stats:\n" (ppAboves [
- ppBesides [ppStr "SpecCalls ", ppInt spec_calls],
- ppBesides [ppStr "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), ppStr "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}
-- 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 specOutArg 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)
specExpr (Con con args) null_args
= ASSERT (null null_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)
+ 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) args) null_args
= ASSERT (null null_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)
+ 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)
- let
- (targs, vargs) = partition_args args
- in
- mapAndUnzipSM specTyArg targs `thenSM` \ (targs, tys) ->
- mapAndUnzip3SM specValArg vargs `thenSM` \ (vargs, args_uds_s, unlifts) ->
+ specArgs args $ \ args' ->
-- specPrimOp prim tys `thenSM` \ (prim, tys, prim_uds) ->
- returnSM (applyBindUnlifts unlifts (Prim prim (targs ++ vargs)),
- unionUDList args_uds_s {-`unionUDs` prim_uds-} )
+ returnSM (Prim prim args', emptyUDs {-`unionUDs` prim_uds-} )
{- ToDo: specPrimOp
specExpr (App fun arg) args
- = -- If TyArg, arg will be processed; otherwise, left alone
- preSpecArg arg `thenSM` \ new_arg ->
- specExpr fun (new_arg : args) `thenSM` \ (expr,uds) ->
+ = specArg arg `thenSM` \ new_arg ->
+ specExpr fun (new_arg : args) `thenSM` \ (expr,uds) ->
returnSM (expr, uds)
specExpr (Lam (ValBinder binder) body) (arg : args) | isValArg arg
-- We use ty_args of scrutinee type to identify specialisation of
-- alternatives:
- (_, ty_args, _) = getAppDataTyConExpandingDicts scrutinee_ty
+ (_, ty_args, _) = --trace "Specialise.specAlts:getAppData..." $
+ splitAlgTyConApp scrutinee_ty
specAlgAlt ty_args (con,binders,rhs)
= specLambdaOrCaseBody binders rhs args `thenSM` \ (binders, rhs, rhs_uds) ->
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
-
---------------------
-specValArg :: CoreArg -> SpecM (CoreArg, UsageDetails,
- CoreExpr -> CoreExpr)
-
-specValArg (LitArg lit)
- = returnSM (LitArg lit, emptyUDs, id)
-
-specValArg (VarArg v)
+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))
-------------------
-specTyArg (TyArg ty)
+specArg (TyArg ty) thing_inside
= specTy ty `thenSM` \ new_ty ->
- returnSM (TyArg new_ty, new_ty)
+ thing_inside (TyArg new_ty)
---------------
-specOutArg :: CoreArg -> SpecM (CoreArg, UsageDetails,
- CoreExpr -> CoreExpr)
+specArg (LitArg lit)
+ = thing_inside (LitArg lit)
-specOutArg (TyArg ty) -- already speced; no action
- = returnSM (TyArg ty, emptyUDs, id)
+specArg (VarArg v)
-specOutArg other_arg -- unprocessed; spec the atom
- = specValArg other_arg
+
+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 "{",
- interppSP PprDebug new_ids,
- ppStr "}"])
- 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
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
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
-- "required" by one of the other Ids in the Rec
| top_lev && maybeToBool lookup_orig_spec
= (if opt_SpecialiseTrace
- then trace_nospec " Exists: " exists_id
+ then trace_nospec " Exists: " orig_id
else id) (
returnSM (Nothing, emptyUDs, Nothing)
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
+ 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),
- ppStr "==>", 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 [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
- ppBesides [ppStr "dicts: ", ppInterleave ppNil (map pp_dict dict_args)],
- ppBesides [ppStr "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)
\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
+ 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
- = let
- spec_overloading = opt_SpecialiseOverloaded
- spec_unboxed = opt_SpecialiseUnboxed
- spec_all = opt_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
-
- record = any (not . isTyVarTy) (catMaybes spec_tys)
+ = returnSM (singleCI new_id spec_tys dicts)
- lookup = lookupSpecEnv (getIdSpecialisation id) tys
- in
- if (not enough_args) then
- pprPanic "Specialise:recordCallInst: Unsaturated Type & Dict Application:\n\t"
- (ppCat (ppr PprDebug id : map (ppr_arg 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 ((TyArg ty,_,_):args)
- = case (take_type_args tyvars class_tyvar_pairs args) of
- Nothing -> Nothing
+ where
+ (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 = 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 (take_type_args tyvars 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) [] = Nothing
-take_type_args [] class_tyvar_pairs args
+ 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
+ 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)
-
-mkCall new_id args
- | 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),
- ppStr "==>",
- 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
+ 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 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}
\begin{code}
mkTyConInstance :: Id
case record_inst of
Nothing -- No TyCon instance
-> -- pprTrace "NoTyConInst:"
- -- (ppCat [ppr PprDebug tycon, ppStr "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, ppStr "at",
- -- ppr PprDebug con, ppCat (map (ppr PprDebug) tys),
- -- ppBesides [ppStr "(",
- -- ppCat [pprMaybeTy PprDebug ty | ty <- spec_tys],
- -- ppStr ")"]])
+ -- (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 [ppStr (if spec_exists then "True" else "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
newSpecIds new_ids maybe_tys dicts_to_ignore tvenv idenv us
= [ mkSpecId uniq id maybe_tys (spec_id_ty id) (selectIdInfoForSpecId id)
- | (id,uniq) <- zipEqual "newSpecIds" new_ids 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
-- 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
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}
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"
+ (hsep [ppr new_id,
+ hsep (map (pprParendGenType) ty_args),
+ ptext SLIT("==>"),
+ ppr 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"
+ (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"
+ (vcat [hsep [ppr check_id,
+ hsep (map (pprParendGenType) tys)],
+ hsep [ppr spec_id,
+ hsep (map (pprParendGenType) tys_left)]])
+ else id
+-}
\end{code}
projects / ghc-hetmet.git / blobdiff