#include "HsVersions.h"
-import CmdLineOpts ( opt_D_verbose_core2core, opt_D_dump_spec, opt_D_dump_rules )
-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 Var ( TyVar, mkSysTyVar, setVarUnique )
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
+ withUs, mapUs
)
import Name ( nameOccName, mkSpecOcc, getSrcLoc )
import FiniteMap
-import Maybes ( MaybeErr(..), catMaybes, maybeToBool )
-import ErrUtils ( dumpIfSet )
+import Maybes ( catMaybes, maybeToBool )
+import ErrUtils ( dumpIfSet_dyn )
import Bag
import List ( partition )
-import Util ( zipEqual, zipWithEqual, mapAccumL )
+import Util ( zipEqual, zipWithEqual )
import Outputable
%************************************************************************
\begin{code}
-specProgram :: UniqSupply -> [CoreBind] -> IO [CoreBind]
-specProgram us binds
+specProgram :: DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]
+specProgram dflags us binds
= do
- beginPass "Specialise"
+ showPass dflags "Specialise"
let binds' = initSM us (go binds `thenSM` \ (binds', uds') ->
returnSM (dumpAllDictBinds uds' binds'))
- endPass "Specialise" (opt_D_dump_spec || opt_D_verbose_core2core) binds'
+ endPass dflags "Specialise" Opt_D_dump_spec binds'
- dumpIfSet opt_D_dump_rules "Top-level specialisations"
+ dumpIfSet_dyn dflags Opt_D_dump_rules "Top-level specialisations"
(vcat (map dump_specs (concat (map bindersOf binds'))))
return binds'
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 ->
+ = withUs $ \ us ->
let
(subst', us', bndr') = substAndCloneId subst us bndr
in
- setUs us' `thenUs_`
- returnUs (subst, subst', NonRec bndr' rhs)
+ ((subst, subst', NonRec bndr' rhs), us')
cloneBindSM subst (Rec pairs)
- = getUs `thenUs` \ us ->
+ = withUs $ \ us ->
let
(subst', us', bndrs') = substAndCloneIds subst us (map fst pairs)
in
- setUs us' `thenUs_`
- returnUs (subst', subst', Rec (bndrs' `zip` map snd pairs))
+ ((subst', subst', Rec (bndrs' `zip` map snd pairs)), us')
cloneBinders subst bndrs
- = getUs `thenUs` \ us ->
+ = withUs $ \ us ->
let
(subst', us', bndrs') = substAndCloneIds subst us bndrs
in
- setUs us' `thenUs_`
- returnUs (subst', bndrs')
-
+ ((subst', bndrs'), us')
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}