Commit d0f325ce authored by simonpj's avatar simonpj

[project @ 1998-04-07 16:40:08 by simonpj]

Specialiser really nearly working!
parent 8b935dd5
...@@ -251,10 +251,10 @@ instantiated before use. ...@@ -251,10 +251,10 @@ instantiated before use.
\begin{code} \begin{code}
mkTemplateLocals :: [Type] -> [Id] mkTemplateLocals :: [Type] -> [Id]
mkTemplateLocals tys mkTemplateLocals tys
= zipWith mk (getBuiltinUniques (length tys)) tys = zipWith3 mk (getBuiltinUniques (length tys)) tys [1..]
where where
mk uniq ty = mkVanillaId (mkSysLocalName uniq SLIT("tpl") mkBuiltinSrcLoc) mk uniq ty n = mkVanillaId (mkSysLocalName uniq (_PK_ ("x"++show n)) mkBuiltinSrcLoc)
ty noIdInfo ty noIdInfo
\end{code} \end{code}
......
...@@ -53,6 +53,7 @@ import Id ( Id, idType, getIdArity, isBottomingId, isDataCon, ...@@ -53,6 +53,7 @@ import Id ( Id, idType, getIdArity, isBottomingId, isDataCon,
IdSet ) IdSet )
import PrimOp ( fragilePrimOp, primOpCanTriggerGC ) import PrimOp ( fragilePrimOp, primOpCanTriggerGC )
import IdInfo ( ArityInfo(..), InlinePragInfo(..) ) import IdInfo ( ArityInfo(..), InlinePragInfo(..) )
import Name ( isExported )
import Literal ( isNoRepLit ) import Literal ( isNoRepLit )
import TyCon ( tyConFamilySize ) import TyCon ( tyConFamilySize )
import Type ( splitAlgTyConApp_maybe ) import Type ( splitAlgTyConApp_maybe )
...@@ -513,7 +514,9 @@ rule this out. Since ManyOcc doesn't record FunOcc/ArgOcc ...@@ -513,7 +514,9 @@ rule this out. Since ManyOcc doesn't record FunOcc/ArgOcc
inlineUnconditionally :: (Id,BinderInfo) -> Bool inlineUnconditionally :: (Id,BinderInfo) -> Bool
inlineUnconditionally (id, occ_info) inlineUnconditionally (id, occ_info)
| idMustNotBeINLINEd id = False | idMustNotBeINLINEd id
|| isExported id
= False
| isOneSameSCCFunOcc occ_info | isOneSameSCCFunOcc occ_info
&& idWantsToBeINLINEd id = True && idWantsToBeINLINEd id = True
......
...@@ -315,10 +315,12 @@ ifaceId get_idinfo needed_ids is_rec id rhs ...@@ -315,10 +315,12 @@ ifaceId get_idinfo needed_ids is_rec id rhs
------------ Specialisations -------------- ------------ Specialisations --------------
spec_pretty = hsep (map pp_spec (specEnvToList (getIdSpecialisation id))) spec_pretty = hsep (map pp_spec (specEnvToList (getIdSpecialisation id)))
pp_spec (tyvars, tys, rhs) = hsep [ptext SLIT("_P_"), pp_spec (tyvars, tys, rhs) = hsep [ptext SLIT("_P_"),
brackets (interpp'SP tyvars), if null tyvars then ptext SLIT("[ ]")
else brackets (interpp'SP tyvars),
-- The lexer interprets "[]" as a CONID. Sigh.
hsep (map pprParendType tys), hsep (map pprParendType tys),
ptext SLIT("="), ptext SLIT("="),
ppr rhs pprIfaceUnfolding rhs
] ]
------------ Extra free Ids -------------- ------------ Extra free Ids --------------
......
...@@ -486,8 +486,13 @@ id_info_item : ARITY_PART arity_info { HsArity $2 } ...@@ -486,8 +486,13 @@ id_info_item : ARITY_PART arity_info { HsArity $2 }
| strict_info { HsStrictness $1 } | strict_info { HsStrictness $1 }
| BOTTOM { HsStrictness HsBottom } | BOTTOM { HsStrictness HsBottom }
| UNFOLD_PART core_expr { HsUnfold $1 $2 } | UNFOLD_PART core_expr { HsUnfold $1 $2 }
| SPECIALISE OBRACK tv_bndrs CBRACK | SPECIALISE spec_tvs
atypes EQUAL core_expr { HsSpecialise $3 $5 $7 } atypes EQUAL core_expr { HsSpecialise $2 $3 $5 }
spec_tvs :: { [HsTyVar RdrName] }
spec_tvs : OBRACK tv_bndrs CBRACK { $2 }
arity_info :: { ArityInfo } arity_info :: { ArityInfo }
arity_info : INTEGER { exactArity (fromInteger $1) } arity_info : INTEGER { exactArity (fromInteger $1) }
......
...@@ -25,7 +25,7 @@ import RdrHsSyn ...@@ -25,7 +25,7 @@ import RdrHsSyn
import RnHsSyn import RnHsSyn
import RnMonad import RnMonad
import RnExpr ( rnMatch, rnGRHSsAndBinds, rnPat, checkPrecMatch ) import RnExpr ( rnMatch, rnGRHSsAndBinds, rnPat, checkPrecMatch )
import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, lookupOccRn, import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, lookupOccRn, lookupGlobalOccRn,
newLocalNames, isUnboundName, warnUnusedBinds newLocalNames, isUnboundName, warnUnusedBinds
) )
import CmdLineOpts ( opt_SigsRequired ) import CmdLineOpts ( opt_SigsRequired )
...@@ -341,23 +341,21 @@ rnMethodBinds (AndMonoBinds mb1 mb2) ...@@ -341,23 +341,21 @@ rnMethodBinds (AndMonoBinds mb1 mb2)
= andRn AndMonoBinds (rnMethodBinds mb1) = andRn AndMonoBinds (rnMethodBinds mb1)
(rnMethodBinds mb2) (rnMethodBinds mb2)
rnMethodBinds (FunMonoBind occname inf matches locn) rnMethodBinds (FunMonoBind name inf matches locn)
= pushSrcLocRn locn $ = pushSrcLocRn locn $
mapRn (checkPrecMatch inf occname) matches `thenRn_` mapRn (checkPrecMatch inf name) matches `thenRn_`
newLocalNames [(occname, locn)] `thenRn` \ [op_name] -> lookupGlobalOccRn name `thenRn` \ sel_name ->
-- Make a fresh local for the bound variable; it must be different -- We use the selector name as the binder
-- to occurrences of the same thing on the LHS, which refer to the global
-- selectors.
mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, _) -> mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, _) ->
returnRn (FunMonoBind op_name inf new_matches locn) returnRn (FunMonoBind sel_name inf new_matches locn)
rnMethodBinds (PatMonoBind (VarPatIn occname) grhss_and_binds locn) rnMethodBinds (PatMonoBind (VarPatIn name) grhss_and_binds locn)
= pushSrcLocRn locn $ = pushSrcLocRn locn $
newLocalNames [(occname, locn)] `thenRn` \ [op_name] -> lookupGlobalOccRn name `thenRn` \ sel_name ->
rnGRHSsAndBinds grhss_and_binds `thenRn` \ (grhss_and_binds', _) -> rnGRHSsAndBinds grhss_and_binds `thenRn` \ (grhss_and_binds', _) ->
returnRn (PatMonoBind (VarPatIn op_name) grhss_and_binds' locn) returnRn (PatMonoBind (VarPatIn sel_name) grhss_and_binds' locn)
-- Can't handle method pattern-bindings which bind multiple methods. -- Can't handle method pattern-bindings which bind multiple methods.
rnMethodBinds mbind@(PatMonoBind other_pat _ locn) rnMethodBinds mbind@(PatMonoBind other_pat _ locn)
......
...@@ -276,37 +276,61 @@ ifaceFlavour name = case getNameProvenance name of ...@@ -276,37 +276,61 @@ ifaceFlavour name = case getNameProvenance name of
Looking up a name in the RnEnv. Looking up a name in the RnEnv.
\begin{code} \begin{code}
lookupRn :: NameEnv -> RdrName -> RnMS s Name checkUnboundRn :: RdrName -> Maybe Name -> RnMS s Name
lookupRn name_env rdr_name checkUnboundRn rdr_name (Just name)
= case lookupFM name_env rdr_name of = -- Found it!
returnRn name
-- Found it!
Just name -> returnRn name checkUnboundRn rdr_name Nothing
= -- Not found by lookup
-- Not found getModeRn `thenRn` \ mode ->
Nothing -> getModeRn `thenRn` \ mode -> case mode of
case mode of -- Not found when processing source code; so fail
-- Not found when processing source code; so fail SourceMode -> failWithRn (mkUnboundName rdr_name)
SourceMode -> failWithRn (mkUnboundName rdr_name) (unknownNameErr rdr_name)
(unknownNameErr rdr_name)
-- Not found when processing an imported declaration, -- Not found when processing an imported declaration,
-- so we create a new name for the purpose -- so we create a new name for the purpose
InterfaceMode _ -> InterfaceMode _ _ ->
case rdr_name of case rdr_name of
Qual mod_name occ hif -> newImportedGlobalName mod_name occ hif
Qual mod_name occ hif -> newGlobalName mod_name occ hif -- An Unqual is allowed; interface files contain
-- unqualified names for locally-defined things, such as
-- An Unqual is allowed; interface files contain -- constructors of a data type.
-- unqualified names for locally-defined things, such as Unqual occ -> getModuleRn `thenRn ` \ mod_name ->
-- constructors of a data type. newImportedGlobalName mod_name occ HiFile
Unqual occ -> getModuleRn `thenRn ` \ mod_name ->
newGlobalName mod_name occ HiFile
lookupBndrRn rdr_name lookupBndrRn rdr_name
= getNameEnv `thenRn` \ name_env -> = lookupNameRn rdr_name `thenRn` \ maybe_name ->
lookupRn name_env rdr_name checkUnboundRn rdr_name maybe_name `thenRn` \ name ->
if isLocalName name then
returnRn name
else
----------------------------------------------------
-- OK, so we're at the binding site of a top-level defn
-- Check to see whether its an imported decl
getModeRn `thenRn` \ mode ->
case mode of {
SourceMode -> returnRn name ;
InterfaceMode _ print_unqual_fn ->
----------------------------------------------------
-- OK, the binding site of an *imported* defn
-- so we can make the provenance more informative
getSrcLocRn `thenRn` \ src_loc ->
let
name' = case getNameProvenance name of
NonLocalDef _ hif _ -> setNameProvenance name
(NonLocalDef src_loc hif (print_unqual_fn name'))
other -> name
in
returnRn name'
}
-- Just like lookupRn except that we record the occurrence too -- Just like lookupRn except that we record the occurrence too
-- Perhaps surprisingly, even wired-in names are recorded. -- Perhaps surprisingly, even wired-in names are recorded.
...@@ -314,17 +338,25 @@ lookupBndrRn rdr_name ...@@ -314,17 +338,25 @@ lookupBndrRn rdr_name
-- deciding which instance declarations to import. -- deciding which instance declarations to import.
lookupOccRn :: RdrName -> RnMS s Name lookupOccRn :: RdrName -> RnMS s Name
lookupOccRn rdr_name lookupOccRn rdr_name
= getNameEnv `thenRn` \ name_env -> = lookupNameRn rdr_name `thenRn` \ maybe_name ->
lookupRn name_env rdr_name `thenRn` \ name -> checkUnboundRn rdr_name maybe_name `thenRn` \ name ->
addOccurrenceName name let
name' = mungePrintUnqual rdr_name name
in
addOccurrenceName name'
-- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global -- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global
-- environment. It's used for record field names only. -- environment. It's used only for
-- record field names
-- class op names in class and instance decls
lookupGlobalOccRn :: RdrName -> RnMS s Name lookupGlobalOccRn :: RdrName -> RnMS s Name
lookupGlobalOccRn rdr_name lookupGlobalOccRn rdr_name
= getGlobalNameEnv `thenRn` \ name_env -> = lookupGlobalNameRn rdr_name `thenRn` \ maybe_name ->
lookupRn name_env rdr_name `thenRn` \ name -> checkUnboundRn rdr_name maybe_name `thenRn` \ name ->
addOccurrenceName name let
name' = mungePrintUnqual rdr_name name
in
addOccurrenceName name'
-- mungePrintUnqual is used to make *imported* *occurrences* print unqualified -- mungePrintUnqual is used to make *imported* *occurrences* print unqualified
......
...@@ -39,6 +39,7 @@ import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon, ...@@ -39,6 +39,7 @@ import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon,
import Name import Name
import UniqFM ( isNullUFM ) import UniqFM ( isNullUFM )
import UniqSet ( emptyUniqSet, unionManyUniqSets, UniqSet ) import UniqSet ( emptyUniqSet, unionManyUniqSets, UniqSet )
import Unique ( assertIdKey )
import Util ( removeDups ) import Util ( removeDups )
import Outputable import Outputable
\end{code} \end{code}
...@@ -249,23 +250,15 @@ rnExpr :: RdrNameHsExpr -> RnMS s (RenamedHsExpr, FreeVars) ...@@ -249,23 +250,15 @@ rnExpr :: RdrNameHsExpr -> RnMS s (RenamedHsExpr, FreeVars)
rnExpr (HsVar v) rnExpr (HsVar v)
= lookupOccRn v `thenRn` \ name -> = lookupOccRn v `thenRn` \ name ->
case res of if nameUnique name == assertIdKey then
Left (nm,err) -- We expand it to (GHCerr.assert__ location)
| opt_GlasgowExts && v == assertRdrName -> mkAssertExpr `thenRn` \ expr ->
-- if `assert' is not in scope, returnRn (expr, emptyUniqSet)
-- we expand it to (GHCerr.assert__ location) else
mkAssertExpr `thenRn` \ (expr, assert_name) -> -- The normal case
returnRn (expr, unitNameSet assert_name) returnRn (HsVar name, if isLocallyDefined name
then unitNameSet name
| otherwise -> -- a failure after all. else emptyUniqSet)
failWithRn nm err `thenRn_`
returnRn (HsVar nm, if isLocallyDefined nm
then unitNameSet nm
else emptyUniqSet)
Right vname ->
returnRn (HsVar vname, if isLocallyDefined vname
then unitNameSet vname
else emptyUniqSet)
rnExpr (HsLit lit) rnExpr (HsLit lit)
= litOccurrence lit `thenRn_` = litOccurrence lit `thenRn_`
...@@ -732,7 +725,7 @@ litOccurrence (HsLitLit _) ...@@ -732,7 +725,7 @@ litOccurrence (HsLitLit _)
%************************************************************************ %************************************************************************
\begin{code} \begin{code}
mkAssertExpr :: RnMS s (RenamedHsExpr, Name) mkAssertExpr :: RnMS s RenamedHsExpr
mkAssertExpr = mkAssertExpr =
newImportedGlobalName mod occ HiFile `thenRn` \ name -> newImportedGlobalName mod occ HiFile `thenRn` \ name ->
addOccurrenceName name `thenRn_` addOccurrenceName name `thenRn_`
...@@ -741,7 +734,7 @@ mkAssertExpr = ...@@ -741,7 +734,7 @@ mkAssertExpr =
expr = HsApp (HsVar name) expr = HsApp (HsVar name)
(HsLit (HsString (_PK_ (showSDoc (ppr sloc))))) (HsLit (HsString (_PK_ (showSDoc (ppr sloc)))))
in in
returnRn (expr, name) returnRn expr
where where
mod = rdrNameModule assertErr_RDR mod = rdrNameModule assertErr_RDR
......
...@@ -34,7 +34,7 @@ import FloatIn ( floatInwards ) ...@@ -34,7 +34,7 @@ import FloatIn ( floatInwards )
import FloatOut ( floatOutwards ) import FloatOut ( floatOutwards )
import FoldrBuildWW ( mkFoldrBuildWW ) import FoldrBuildWW ( mkFoldrBuildWW )
import MkId ( mkSysLocal, mkUserId ) import MkId ( mkSysLocal, mkUserId )
import Id ( setIdVisibility, import Id ( setIdVisibility, getIdSpecialisation, setIdSpecialisation,
getIdDemandInfo, idType, getIdDemandInfo, idType,
nullIdEnv, addOneToIdEnv, delOneFromIdEnv, nullIdEnv, addOneToIdEnv, delOneFromIdEnv,
lookupIdEnv, IdEnv, lookupIdEnv, IdEnv,
...@@ -62,8 +62,9 @@ import SAT ( doStaticArgs ) ...@@ -62,8 +62,9 @@ import SAT ( doStaticArgs )
import SimplMonad ( zeroSimplCount, showSimplCount, SimplCount ) import SimplMonad ( zeroSimplCount, showSimplCount, SimplCount )
import SimplPgm ( simplifyPgm ) import SimplPgm ( simplifyPgm )
import Specialise import Specialise
import SpecEnv ( substSpecEnv, isEmptySpecEnv )
import StrictAnal ( saWwTopBinds ) import StrictAnal ( saWwTopBinds )
import TyVar ( TyVar, nameTyVar ) import TyVar ( TyVar, nameTyVar, emptyTyVarEnv )
import Unique ( Unique{-instance Eq-}, Uniquable(..), import Unique ( Unique{-instance Eq-}, Uniquable(..),
integerTyConKey, ratioTyConKey, integerTyConKey, ratioTyConKey,
mkUnique, incrUnique, mkUnique, incrUnique,
...@@ -72,7 +73,7 @@ import Unique ( Unique{-instance Eq-}, Uniquable(..), ...@@ -72,7 +73,7 @@ import Unique ( Unique{-instance Eq-}, Uniquable(..),
import UniqSupply ( UniqSupply, mkSplitUniqSupply, import UniqSupply ( UniqSupply, mkSplitUniqSupply,
splitUniqSupply, getUnique splitUniqSupply, getUnique
) )
import UniqFM ( UniqFM, lookupUFM, addToUFM ) import UniqFM ( UniqFM, lookupUFM, addToUFM, delFromUFM )
import Util ( mapAccumL ) import Util ( mapAccumL )
import SrcLoc ( noSrcLoc ) import SrcLoc ( noSrcLoc )
import Constants ( tARGET_MIN_INT, tARGET_MAX_INT ) import Constants ( tARGET_MIN_INT, tARGET_MAX_INT )
...@@ -608,19 +609,49 @@ mapTM f (x:xs) = f x `thenTM` \ r -> ...@@ -608,19 +609,49 @@ mapTM f (x:xs) = f x `thenTM` \ r ->
\begin{code} \begin{code}
-- Need to extend the environment when we munge a binder, so that occurrences -- Need to extend the environment when we munge a binder, so that occurrences
-- of the binder will print the correct way (i.e. as a global not a local) -- of the binder will print the correct way (e.g. as a global not a local)
mungeTopBinder :: Id -> (Id -> TopTidyM a) -> TopTidyM a mungeTopBinder :: Id -> (Id -> TopTidyM a) -> TopTidyM a
mungeTopBinder id thing_inside mod env us mungeTopBinder id thing_inside mod env us
= -- Give it a new print-name unless it's an exported thing = -- Give it a new print-name unless it's an exported thing
-- setNameVisibility also does the local/global thing -- setNameVisibility also does the local/global thing
let let
(id', us') | isExported id = (id, us) (id1, us') | isExported id = (id, us)
| otherwise | otherwise
= (setIdVisibility (Just mod) us id, = (setIdVisibility (Just mod) us id,
incrUnique us) incrUnique us)
new_env = addToUFM env id (ValBinder id')
-- Tidy the Id's SpecEnv
spec_env = getIdSpecialisation id
id2 | isEmptySpecEnv spec_env = id1
| otherwise = setIdSpecialisation id1 (tidySpecEnv env spec_env)
new_env = addToUFM env id (ValBinder id2)
in in
thing_inside id' mod new_env us' thing_inside id2 mod new_env us'
tidySpecEnv env spec_env
= substSpecEnv
emptyTyVarEnv -- Top level only
(tidy_spec_rhs env)
spec_env
where
-- tidy_spec_rhs is another horrid little hacked-up function for
-- the RHS of specialisation templates.
-- It assumes there is no type substitution.
--
-- See also SimplVar.substSpecEnvRhs Urgh
tidy_spec_rhs env (Var v) = case lookupUFM env v of
Just (ValBinder v') -> Var v'
Nothing -> Var v
tidy_spec_rhs env (App f (VarArg v)) = App (tidy_spec_rhs env f) (case lookupUFM env v of
Just (ValBinder v') -> VarArg v'
Nothing -> VarArg v)
tidy_spec_rhs env (App f arg) = App (tidy_spec_rhs env f) arg
tidy_spec_rhs env (Lam b e) = Lam b (tidy_spec_rhs env' e)
where
env' = case b of
ValBinder id -> delFromUFM env id
TyBinder _ -> env
mungeTopBinders [] k = k [] mungeTopBinders [] k = k []
mungeTopBinders (b:bs) k = mungeTopBinder b $ \ b' -> mungeTopBinders (b:bs) k = mungeTopBinder b $ \ b' ->
......
...@@ -198,7 +198,7 @@ simplBinder env (id, occ_info) ...@@ -198,7 +198,7 @@ simplBinder env (id, occ_info)
-- id2 has its SpecEnv zapped -- id2 has its SpecEnv zapped
id2 | isEmptySpecEnv spec_env = id1 id2 | isEmptySpecEnv spec_env = id1
| otherwise = setIdSpecialisation id spec_env' | otherwise = setIdSpecialisation id1 spec_env'
in in
if not_in_scope then if not_in_scope then
-- No need to clone, but we *must* zap any current substitution -- No need to clone, but we *must* zap any current substitution
......
...@@ -12,7 +12,7 @@ module Specialise ( ...@@ -12,7 +12,7 @@ module Specialise (
#include "HsVersions.h" #include "HsVersions.h"
import MkId ( mkUserLocal ) import MkId ( mkUserLocal )
import Id ( Id, DictVar, idType, import Id ( Id, DictVar, idType, mkTemplateLocals,
getIdSpecialisation, setIdSpecialisation, isSpecPragmaId, getIdSpecialisation, setIdSpecialisation, isSpecPragmaId,
...@@ -26,7 +26,7 @@ import Type ( Type, mkTyVarTy, splitSigmaTy, instantiateTy, isDictTy, ...@@ -26,7 +26,7 @@ import Type ( Type, mkTyVarTy, splitSigmaTy, instantiateTy, isDictTy,
tyVarsOfType, tyVarsOfTypes, applyTys, mkForAllTys tyVarsOfType, tyVarsOfTypes, applyTys, mkForAllTys
) )
import TyCon ( TyCon ) import TyCon ( TyCon )
import TyVar ( TyVar, import TyVar ( TyVar, alphaTyVars,
TyVarSet, mkTyVarSet, isEmptyTyVarSet, intersectTyVarSets, TyVarSet, mkTyVarSet, isEmptyTyVarSet, intersectTyVarSets,
elementOfTyVarSet, unionTyVarSets, emptyTyVarSet, elementOfTyVarSet, unionTyVarSets, emptyTyVarSet,
TyVarEnv, mkTyVarEnv, delFromTyVarEnv TyVarEnv, mkTyVarEnv, delFromTyVarEnv
...@@ -710,7 +710,7 @@ specBind (NonRec bndr rhs) body_uds ...@@ -710,7 +710,7 @@ specBind (NonRec bndr rhs) body_uds
| isSpecPragmaId bndr | isSpecPragmaId bndr
= specExpr rhs `thenSM` \ (rhs', rhs_uds) -> = specExpr rhs `thenSM` \ (rhs', rhs_uds) ->
returnSM ([], rhs_uds) returnSM ([], rhs_uds `plusUDs` body_uds)
| otherwise | otherwise
= -- Deal with the RHS, specialising it according = -- Deal with the RHS, specialising it according
...@@ -779,7 +779,7 @@ specDefn calls (fn, rhs) ...@@ -779,7 +779,7 @@ specDefn calls (fn, rhs)
(tyvars, theta, tau) = splitSigmaTy fn_type (tyvars, theta, tau) = splitSigmaTy fn_type
n_tyvars = length tyvars n_tyvars = length tyvars
n_dicts = length theta n_dicts = length theta
mk_spec_tys call_ts = zipWith mk_spec_ty call_ts tyvars mk_spec_tys call_ts = zipWith mk_spec_ty call_ts alphaTyVars
where where
mk_spec_ty (Just ty) _ = ty mk_spec_ty (Just ty) _ = ty
mk_spec_ty Nothing tyvar = mkTyVarTy tyvar mk_spec_ty Nothing tyvar = mkTyVarTy tyvar
...@@ -794,11 +794,6 @@ specDefn calls (fn, rhs) ...@@ -794,11 +794,6 @@ specDefn calls (fn, rhs)
Nothing -> [] Nothing -> []
Just cs -> fmToList cs Just cs -> fmToList cs
-- Filter out calls for which we already have a specialisation
calls_to_spec = filter spec_me calls_for_me
spec_me (call_ts, _) = not (maybeToBool (lookupSpecEnv id_spec_env (mk_spec_tys call_ts)))
id_spec_env = getIdSpecialisation fn
---------------------------------------------------------- ----------------------------------------------------------
-- Specialise to one particular call pattern -- Specialise to one particular call pattern
spec_call :: ProtoUsageDetails -- From the original body, captured by spec_call :: ProtoUsageDetails -- From the original body, captured by
...@@ -817,13 +812,14 @@ specDefn calls (fn, rhs) ...@@ -817,13 +812,14 @@ specDefn calls (fn, rhs)
-- f1 = /\ b d -> (..rhs of f..) t1 b t3 d d1 d2 -- f1 = /\ b d -> (..rhs of f..) t1 b t3 d d1 d2
-- and the type of this binder -- and the type of this binder
let let
spec_tyvars = [tyvar | (tyvar, Nothing) <- tyvars `zip` call_ts] spec_tyvars = [tyvar | (tyvar, Nothing) <- alphaTyVars `zip` call_ts]
spec_tys = mk_spec_tys call_ts spec_tys = mk_spec_tys call_ts
spec_rhs = mkTyLam spec_tyvars $ spec_rhs = mkTyLam spec_tyvars $
mkGenApp rhs (map TyArg spec_tys ++ map VarArg call_ds) mkGenApp rhs (map TyArg spec_tys ++ map VarArg call_ds)
spec_id_ty = mkForAllTys spec_tyvars (instantiateTy ty_env tau) spec_id_ty = mkForAllTys spec_tyvars (instantiateTy ty_env tau)
ty_env = mkTyVarEnv (zipEqual "spec_call" tyvars spec_tys) ty_env = mkTyVarEnv (zipEqual "spec_call" tyvars spec_tys)
in in
newIdSM fn spec_id_ty `thenSM` \ spec_f -> newIdSM fn spec_id_ty `thenSM` \ spec_f ->
...@@ -833,8 +829,11 @@ specDefn calls (fn, rhs) ...@@ -833,8 +829,11 @@ specDefn calls (fn, rhs)
-- dictionaries, so it's tidier to make new local variables -- dictionaries, so it's tidier to make new local variables
-- for the lambdas in the RHS, rather than lambda-bind the -- for the lambdas in the RHS, rather than lambda-bind the
-- dictionaries themselves. -- dictionaries themselves.
mapSM (\d -> newIdSM d (idType d)) call_ds `thenSM` \ arg_ds -> --
-- In fact we use the standard template locals, so that the
-- they don't need to be "tidied" before putting in interface files
let let
arg_ds = mkTemplateLocals (map idType call_ds)
spec_env_rhs = mkValLam arg_ds $ spec_env_rhs = mkValLam arg_ds $
mkTyApp (Var spec_f) $ mkTyApp (Var spec_f) $
map mkTyVarTy spec_tyvars map mkTyVarTy spec_tyvars
...@@ -1074,6 +1073,7 @@ dictRhsFVs e ...@@ -1074,6 +1073,7 @@ dictRhsFVs e
= go e = go e
where where
go (App e1 (VarArg a)) = go e1 `addOneToIdSet` a go (App e1 (VarArg a)) = go e1 `addOneToIdSet` a
go (App e1 (LitArg l)) = go e1
go (App e1 (TyArg t)) = go e1 go (App e1 (TyArg t)) = go e1
go (Var v) = unitIdSet v go (Var v) = unitIdSet v
go (Lit l) = emptyIdSet go (Lit l) = emptyIdSet
......
...@@ -15,7 +15,7 @@ import CmdLineOpts ( opt_UnfoldingCreationThreshold ) ...@@ -15,7 +15,7 @@ import CmdLineOpts ( opt_UnfoldingCreationThreshold )
import CoreUtils ( coreExprType ) import CoreUtils ( coreExprType )
import MkId ( mkWorkerId ) import MkId ( mkWorkerId )
import Id ( getInlinePragma, getIdStrictness, import Id ( getInlinePragma, getIdStrictness,
addIdStrictness, addInlinePragma, addIdStrictness, addInlinePragma, idWantsToBeINLINEd,
IdSet, emptyIdSet, addOneToIdSet, IdSet, emptyIdSet, addOneToIdSet,
GenId, Id GenId, Id
) )
...@@ -179,9 +179,10 @@ tryWW :: Id -- The fn binder ...@@ -179,9 +179,10 @@ tryWW :: Id -- The fn binder
-- if two, then a worker and a -- if two, then a worker and a
-- wrapper. -- wrapper.
tryWW fn_id rhs tryWW fn_id rhs
| (certainlySmallEnoughToInline fn_id $ | idWantsToBeINLINEd fn_id
calcUnfoldingGuidance opt_UnfoldingCreationThreshold rhs || (certainlySmallEnoughToInline fn_id $
) calcUnfoldingGuidance opt_UnfoldingCreationThreshold rhs
)
-- No point in worker/wrappering something that is going to be -- No point in worker/wrappering something that is going to be
-- INLINEd wholesale anyway. If the strictness analyser is run -- INLINEd wholesale anyway. If the strictness analyser is run
-- twice, this test also prevents wrappers (which are INLINEd) -- twice, this test also prevents wrappers (which are INLINEd)
......
...@@ -40,7 +40,7 @@ import MkId ( mkDataCon, mkSuperDictSelId, ...@@ -40,7 +40,7 @@ import MkId ( mkDataCon, mkSuperDictSelId,
mkMethodSelId, mkDefaultMethodId mkMethodSelId, mkDefaultMethodId
) )