#include "HsVersions.h"
-import CmdLineOpts ( DynFlags, DynFlag(..), dopt )
-import Id ( Id, idName, idType, mkTemplateLocals, mkUserLocal,
- idSpecialisation, setIdNoDiscard, isExportedId,
- modifyIdInfo, idUnfolding
+import CmdLineOpts ( DynFlags, DynFlag(..) )
+import Id ( Id, idName, idType, mkUserLocal,
+ idSpecialisation, modifyIdInfo
)
-import IdInfo ( zapSpecPragInfo )
-import VarSet
-import VarEnv
-
-import Type ( Type, mkTyVarTy, splitSigmaTy, splitFunTysN,
- tyVarsOfType, tyVarsOfTypes, tyVarsOfTheta, applyTys,
- mkForAllTys, boxedTypeKind
+import Type ( Type, mkTyVarTy, splitSigmaTy,
+ tyVarsOfTypes, tyVarsOfTheta,
+ mkForAllTys
)
-import Subst ( Subst, mkSubst, substTy, mkSubst, substBndrs, extendSubstList, mkInScopeSet,
- substId, substAndCloneId, substAndCloneIds, lookupIdSubst, substInScope
+import Subst ( Subst, mkSubst, substTy, mkSubst, extendSubstList, mkInScopeSet,
+ simplBndr, simplBndrs,
+ substAndCloneId, substAndCloneIds, substAndCloneRecIds,
+ lookupIdSubst, substInScope
)
-import Var ( TyVar, mkSysTyVar, setVarUnique )
+import Var ( zapSpecPragmaId )
import VarSet
import VarEnv
import CoreSyn
import CoreUtils ( applyTypeToArgs )
import CoreUnfold ( certainlyWillInline )
import CoreFVs ( exprFreeVars, exprsFreeVars )
-import CoreLint ( beginPass, endPass )
+import CoreLint ( showPass, endPass )
import PprCore ( pprCoreRules )
import Rules ( addIdSpecialisations, lookupRule )
import UniqSupply ( UniqSupply,
- UniqSM, initUs_, thenUs, thenUs_, returnUs, getUniqueUs,
- getUs, setUs, uniqFromSupply, splitUniqSupply, mapUs
+ UniqSM, initUs_, thenUs, returnUs, getUniqueUs,
+ getUs, mapUs
)
import Name ( nameOccName, mkSpecOcc, getSrcLoc )
import FiniteMap
-import Maybes ( MaybeErr(..), catMaybes, maybeToBool )
+import Maybes ( catMaybes, maybeToBool )
import ErrUtils ( dumpIfSet_dyn )
import Bag
import List ( partition )
-import Util ( zipEqual, zipWithEqual, mapAccumL )
+import Util ( zipEqual, zipWithEqual )
import Outputable
specProgram :: DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]
specProgram dflags us binds
= do
- beginPass dflags "Specialise"
+ showPass dflags "Specialise"
let binds' = initSM us (go binds `thenSM` \ (binds', uds') ->
returnSM (dumpAllDictBinds uds' binds'))
- endPass dflags "Specialise"
- (dopt Opt_D_dump_spec dflags
- || dopt Opt_D_verbose_core2core dflags) binds'
+ endPass dflags "Specialise" Opt_D_dump_spec binds'
dumpIfSet_dyn dflags Opt_D_dump_rules "Top-level specialisations"
(vcat (map dump_specs (concat (map bindersOf binds'))))
returnSM (mkLams bndrs' body'', filtered_uds)
where
(bndrs, body) = collectBinders e
- (subst', bndrs') = substBndrs subst bndrs
+ (subst', bndrs') = simplBndrs subst bndrs
-- More efficient to collect a group of binders together all at once
-- and we don't want to split a lambda group with dumped bindings
mapAndCombineSM spec_alt alts `thenSM` \ (alts', uds_alts) ->
returnSM (Case scrut' case_bndr' alts', uds_scrut `plusUDs` uds_alts)
where
- (subst_alt, case_bndr') = substId subst case_bndr
+ (subst_alt, case_bndr') = simplBndr subst case_bndr
-- No need to clone case binder; it can't float like a let(rec)
spec_alt (con, args, rhs)
in
returnSM ((con, args', rhs''), uds')
where
- (subst_rhs, args') = substBndrs subst_alt args
+ (subst_rhs, args') = simplBndrs subst_alt args
---------------- Finally, let is the interesting case --------------------
specExpr subst (Let bind body)
-- Make a specialised version for each call in calls_for_me
mapSM spec_call calls_for_me `thenSM` \ stuff ->
let
- (spec_defns, spec_uds, spec_env_stuff) = unzip3 stuff
+ (spec_defns, spec_uds, spec_rules) = unzip3 stuff
- fn' = addIdSpecialisations zapped_fn spec_env_stuff
+ fn' = addIdSpecialisations zapped_fn spec_rules
in
returnSM ((fn',rhs'),
spec_defns,
returnSM ((zapped_fn, rhs'), [], rhs_uds)
where
- zapped_fn = modifyIdInfo zapSpecPragInfo fn
+ zapped_fn = zapSpecPragmaId fn
-- If the fn is a SpecPragmaId, make it discardable
-- It's role as a holder for a call instance is o'er
-- But it might be alive for some other reason by now.
----------------------------------------------------------
-- Specialise to one particular call pattern
- spec_call :: ([Maybe Type], ([DictExpr], VarSet)) -- Call instance
- -> SpecM ((Id,CoreExpr), -- Specialised definition
- UsageDetails, -- Usage details from specialised body
- ([CoreBndr], [CoreExpr], CoreExpr)) -- Info for the Id's SpecEnv
+ spec_call :: ([Maybe Type], ([DictExpr], VarSet)) -- Call instance
+ -> SpecM ((Id,CoreExpr), -- Specialised definition
+ UsageDetails, -- Usage details from specialised body
+ CoreRule) -- Info for the Id's SpecEnv
spec_call (call_ts, (call_ds, call_fvs))
= ASSERT( length call_ts == n_tyvars && length call_ds == n_dicts )
-- Calls are only recorded for properly-saturated applications
let
-- The rule to put in the function's specialisation is:
-- forall b,d, d1',d2'. f t1 b t3 d d1' d2' = f1 b d
- spec_env_rule = (poly_tyvars ++ rhs_dicts',
- inst_args,
- mkTyApps (Var spec_f) (map mkTyVarTy poly_tyvars))
+ spec_env_rule = Rule (_PK_ ("SPEC " ++ showSDoc (ppr fn)))
+ (poly_tyvars ++ rhs_dicts')
+ inst_args
+ (mkTyApps (Var spec_f) (map mkTyVarTy poly_tyvars))
-- Add the { d1' = dx1; d2' = dx2 } usage stuff
final_uds = foldr addDictBind rhs_uds (my_zipEqual "spec_call" rhs_dicts' call_ds)
type SpecM a = UniqSM a
thenSM = thenUs
-thenSM_ = thenUs_
returnSM = returnUs
getUniqSM = getUniqueUs
-getUniqSupplySM = getUs
-setUniqSupplySM = setUs
mapSM = mapUs
initSM = initUs_
-- Clone the binders of the bind; return new bind with the cloned binders
-- Return the substitution to use for RHSs, and the one to use for the body
cloneBindSM subst (NonRec bndr rhs)
- = getUs `thenUs` \ us ->
+ = getUs `thenUs` \ us ->
let
- (subst', us', bndr') = substAndCloneId subst us bndr
+ (subst', bndr') = substAndCloneId subst us bndr
in
- setUs us' `thenUs_`
returnUs (subst, subst', NonRec bndr' rhs)
cloneBindSM subst (Rec pairs)
- = getUs `thenUs` \ us ->
+ = getUs `thenUs` \ us ->
let
- (subst', us', bndrs') = substAndCloneIds subst us (map fst pairs)
+ (subst', bndrs') = substAndCloneRecIds subst us (map fst pairs)
in
- setUs us' `thenUs_`
returnUs (subst', subst', Rec (bndrs' `zip` map snd pairs))
cloneBinders subst bndrs
- = getUs `thenUs` \ us ->
- let
- (subst', us', bndrs') = substAndCloneIds subst us bndrs
- in
- setUs us' `thenUs_`
- returnUs (subst', bndrs')
-
+ = getUs `thenUs` \ us ->
+ returnUs (substAndCloneIds subst us bndrs)
newIdSM old_id new_ty
= getUniqSM `thenSM` \ uniq ->
let
-- Give the new Id a similar occurrence name to the old one
- -- We used to add setIdNoDiscard if the old id was exported, to
- -- avoid it being dropped as dead code, but that's not necessary any more.
name = idName old_id
new_id = mkUserLocal (mkSpecOcc (nameOccName name)) uniq new_ty (getSrcLoc name)
in
returnSM new_id
-
-newTyVarSM
- = getUniqSM `thenSM` \ uniq ->
- returnSM (mkSysTyVar uniq boxedTypeKind)
\end{code}
projects / ghc-hetmet.git / blobdiff