diff options
author | Bartosz Nitka <niteria@gmail.com> | 2015-12-02 05:30:22 -0800 |
---|---|---|
committer | Bartosz Nitka <bnitka@fb.com> | 2015-12-02 05:35:26 -0800 |
commit | 741f837d652fd00671614d52a6cb16fbc3758480 (patch) | |
tree | a6c8ae1e554afdaddd66f39cb47107b02a9813ad /compiler | |
parent | 218fdf92370021b900af1e78323764cceb7ac609 (diff) | |
download | haskell-741f837d652fd00671614d52a6cb16fbc3758480.tar.gz |
Implement more deterministic operations and document them
I will need them for the future determinism fixes.
Test Plan: ./validate
Reviewers: simonpj, goldfire, bgamari, austin, hvr, simonmar
Reviewed By: simonpj, simonmar
Subscribers: osa1, thomie
Differential Revision: https://phabricator.haskell.org/D1537
GHC Trac Issues: #4012
Diffstat (limited to 'compiler')
-rw-r--r-- | compiler/basicTypes/VarSet.hs | 68 | ||||
-rw-r--r-- | compiler/coreSyn/CoreFVs.hs | 94 | ||||
-rw-r--r-- | compiler/ghci/ByteCodeGen.hs | 2 | ||||
-rw-r--r-- | compiler/simplCore/SetLevels.hs | 8 | ||||
-rw-r--r-- | compiler/specialise/Rules.hs | 6 | ||||
-rw-r--r-- | compiler/typecheck/Inst.hs | 47 | ||||
-rw-r--r-- | compiler/typecheck/TcType.hs | 5 | ||||
-rw-r--r-- | compiler/types/TypeRep.hs | 52 | ||||
-rw-r--r-- | compiler/utils/FV.hs | 135 | ||||
-rw-r--r-- | compiler/utils/UniqDFM.hs | 45 | ||||
-rw-r--r-- | compiler/utils/UniqDSet.hs | 8 |
11 files changed, 380 insertions, 90 deletions
diff --git a/compiler/basicTypes/VarSet.hs b/compiler/basicTypes/VarSet.hs index e340117893..ce6aea68ab 100644 --- a/compiler/basicTypes/VarSet.hs +++ b/compiler/basicTypes/VarSet.hs @@ -26,13 +26,15 @@ module VarSet ( -- ** Manipulating these sets emptyDVarSet, unitDVarSet, mkDVarSet, - extendDVarSet, + extendDVarSet, extendDVarSetList, elemDVarSet, dVarSetElems, subDVarSet, unionDVarSet, unionDVarSets, mapUnionDVarSet, - intersectDVarSet, - isEmptyDVarSet, delDVarSet, + intersectDVarSet, intersectsDVarSet, disjointDVarSet, + isEmptyDVarSet, delDVarSet, delDVarSetList, minusDVarSet, foldDVarSet, filterDVarSet, + transCloDVarSet, sizeDVarSet, seqDVarSet, + partitionDVarSet, ) where #include "HsVersions.h" @@ -42,15 +44,13 @@ import Unique import UniqSet import UniqDSet import UniqFM( disjointUFM ) +import UniqDFM( disjointUDFM ) -{- -************************************************************************ -* * -\subsection{@VarSet@s} -* * -************************************************************************ --} - +-- | A non-deterministic set of variables. +-- See Note [Deterministic UniqFM] in UniqDFM for explanation why it's not +-- deterministic and why it matters. Use DVarSet if the set eventually +-- gets converted into a list or folded over in a way where the order +-- changes the generated code, for example when abstracting variables. type VarSet = UniqSet Var type IdSet = UniqSet Id type TyVarSet = UniqSet TyVar @@ -206,6 +206,14 @@ mapUnionDVarSet get_set xs = foldr (unionDVarSet . get_set) emptyDVarSet xs intersectDVarSet :: DVarSet -> DVarSet -> DVarSet intersectDVarSet = intersectUniqDSets +-- | True if empty intersection +disjointDVarSet :: DVarSet -> DVarSet -> Bool +disjointDVarSet s1 s2 = disjointUDFM s1 s2 + +-- | True if non-empty intersection +intersectsDVarSet :: DVarSet -> DVarSet -> Bool +intersectsDVarSet s1 s2 = not (s1 `disjointDVarSet` s2) + isEmptyDVarSet :: DVarSet -> Bool isEmptyDVarSet = isEmptyUniqDSet @@ -224,5 +232,43 @@ filterDVarSet = filterUniqDSet sizeDVarSet :: DVarSet -> Int sizeDVarSet = sizeUniqDSet +-- | Partition DVarSet according to the predicate given +partitionDVarSet :: (Var -> Bool) -> DVarSet -> (DVarSet, DVarSet) +partitionDVarSet = partitionUniqDSet + +-- | Delete a list of variables from DVarSet +delDVarSetList :: DVarSet -> [Var] -> DVarSet +delDVarSetList = delListFromUniqDSet + seqDVarSet :: DVarSet -> () seqDVarSet s = sizeDVarSet s `seq` () + +-- | Add a list of variables to DVarSet +extendDVarSetList :: DVarSet -> [Var] -> DVarSet +extendDVarSetList = addListToUniqDSet + +-- | transCloVarSet for DVarSet +transCloDVarSet :: (DVarSet -> DVarSet) + -- Map some variables in the set to + -- extra variables that should be in it + -> DVarSet -> DVarSet +-- (transCloDVarSet f s) repeatedly applies f to new candidates, adding any +-- new variables to s that it finds thereby, until it reaches a fixed point. +-- +-- The function fn could be (Var -> DVarSet), but we use (DVarSet -> DVarSet) +-- for efficiency, so that the test can be batched up. +-- It's essential that fn will work fine if given new candidates +-- one at at time; ie fn {v1,v2} = fn v1 `union` fn v2 +transCloDVarSet fn seeds + = go seeds seeds + where + go :: DVarSet -- Accumulating result + -> DVarSet -- Work-list; un-processed subset of accumulating result + -> DVarSet + -- Specification: go acc vs = acc `union` transClo fn vs + + go acc candidates + | isEmptyDVarSet new_vs = acc + | otherwise = go (acc `unionDVarSet` new_vs) new_vs + where + new_vs = fn candidates `minusDVarSet` acc diff --git a/compiler/coreSyn/CoreFVs.hs b/compiler/coreSyn/CoreFVs.hs index 0533038d9f..398f6bee39 100644 --- a/compiler/coreSyn/CoreFVs.hs +++ b/compiler/coreSyn/CoreFVs.hs @@ -10,11 +10,12 @@ Taken quite directly from the Peyton Jones/Lester paper. -- | A module concerned with finding the free variables of an expression. module CoreFVs ( -- * Free variables of expressions and binding groups - exprFreeVars, -- CoreExpr -> VarSet -- Find all locally-defined free Ids or tyvars - exprFreeDVars, -- CoreExpr -> DVarSet -- Find all locally-defined free Ids or tyvars - exprFreeIds, -- CoreExpr -> IdSet -- Find all locally-defined free Ids - exprsFreeVars, -- [CoreExpr] -> VarSet - bindFreeVars, -- CoreBind -> VarSet + exprFreeVars, + exprFreeVarsDSet, + exprFreeIds, + exprsFreeVars, + exprsFreeVarsList, + bindFreeVars, -- * Selective free variables of expressions InterestingVarFun, @@ -27,7 +28,7 @@ module CoreFVs ( idFreeVarsAcc, idRuleVars, idRuleRhsVars, stableUnfoldingVars, ruleRhsFreeVars, ruleFreeVars, rulesFreeVars, - rulesFreeDVars, + rulesFreeVarsDSet, ruleLhsFreeIds, exprsOrphNames, vectsFreeVars, @@ -51,7 +52,6 @@ import Name import VarSet import Var import TcType -import TypeRep import Coercion import Maybes( orElse ) import Util @@ -76,27 +76,47 @@ but not those that are free in the type of variable occurrence. -} -- | Find all locally-defined free Ids or type variables in an expression +-- returning a non-deterministic set. exprFreeVars :: CoreExpr -> VarSet -exprFreeVars = runFVSet . filterFV isLocalVar . expr_fvs +exprFreeVars = runFVSet . exprFreeVarsAcc -exprFreeDVars :: CoreExpr -> DVarSet -exprFreeDVars = runFVDSet . filterFV isLocalVar . expr_fvs +-- | Find all locally-defined free Ids or type variables in an expression +-- returning a composable FV computation. See Note [FV naming coventions] in FV +-- for why export it. +exprFreeVarsAcc :: CoreExpr -> FV +exprFreeVarsAcc = filterFV isLocalVar . expr_fvs +-- | Find all locally-defined free Ids or type variables in an expression +-- returning a deterministic set. +exprFreeVarsDSet :: CoreExpr -> DVarSet +exprFreeVarsDSet = runFVDSet . exprFreeVarsAcc -- | Find all locally-defined free Ids in an expression exprFreeIds :: CoreExpr -> IdSet -- Find all locally-defined free Ids exprFreeIds = exprSomeFreeVars isLocalId -- | Find all locally-defined free Ids or type variables in several expressions +-- returning a non-deterministic set. exprsFreeVars :: [CoreExpr] -> VarSet -exprsFreeVars = mapUnionVarSet exprFreeVars +exprsFreeVars = runFVSet . exprsFreeVarsAcc + +-- | Find all locally-defined free Ids or type variables in several expressions +-- returning a composable FV computation. See Note [FV naming coventions] in FV +-- for why export it. +exprsFreeVarsAcc :: [CoreExpr] -> FV +exprsFreeVarsAcc exprs = mapUnionFV exprFreeVarsAcc exprs + +-- | Find all locally-defined free Ids or type variables in several expressions +-- returning a deterministically ordered list. +exprsFreeVarsList :: [CoreExpr] -> [Var] +exprsFreeVarsList = runFVList . exprsFreeVarsAcc -- | Find all locally defined free Ids in a binding group bindFreeVars :: CoreBind -> VarSet bindFreeVars (NonRec b r) = runFVSet $ filterFV isLocalVar $ rhs_fvs (b,r) bindFreeVars (Rec prs) = runFVSet $ filterFV isLocalVar $ addBndrs (map fst prs) - (foldr (unionFV . rhs_fvs) noVars prs) + (mapUnionFV rhs_fvs prs) -- | Finds free variables in an expression selected by a predicate exprSomeFreeVars :: InterestingVarFun -- ^ Says which 'Var's are interesting @@ -109,7 +129,7 @@ exprsSomeFreeVars :: InterestingVarFun -- Says which 'Var's are interesting -> [CoreExpr] -> VarSet exprsSomeFreeVars fv_cand es = - runFVSet $ filterFV fv_cand $ foldr (unionFV . expr_fvs) noVars es + runFVSet $ filterFV fv_cand $ mapUnionFV expr_fvs es -- Comment about obselete code -- We used to gather the free variables the RULES at a variable occurrence @@ -139,11 +159,6 @@ exprsSomeFreeVars fv_cand es = -- | otherwise = set -- SLPJ Feb06 --- XXX move to FV -someVars :: [Var] -> FV -someVars vars = foldr (unionFV . oneVar) noVars vars - - addBndr :: CoreBndr -> FV -> FV addBndr bndr fv fv_cand in_scope acc = (varTypeTyVarsAcc bndr `unionFV` @@ -155,7 +170,6 @@ addBndrs :: [CoreBndr] -> FV -> FV addBndrs bndrs fv = foldr addBndr fv bndrs expr_fvs :: CoreExpr -> FV - expr_fvs (Type ty) fv_cand in_scope acc = tyVarsOfTypeAcc ty fv_cand in_scope acc expr_fvs (Coercion co) fv_cand in_scope acc = @@ -173,7 +187,7 @@ expr_fvs (Cast expr co) fv_cand in_scope acc = expr_fvs (Case scrut bndr ty alts) fv_cand in_scope acc = (expr_fvs scrut `unionFV` tyVarsOfTypeAcc ty `unionFV` addBndr bndr - (foldr (unionFV . alt_fvs) noVars alts)) fv_cand in_scope acc + (mapUnionFV alt_fvs alts)) fv_cand in_scope acc where alt_fvs (_, bndrs, rhs) = addBndrs bndrs (expr_fvs rhs) @@ -183,18 +197,18 @@ expr_fvs (Let (NonRec bndr rhs) body) fv_cand in_scope acc expr_fvs (Let (Rec pairs) body) fv_cand in_scope acc = addBndrs (map fst pairs) - (foldr (unionFV . rhs_fvs) (expr_fvs body) pairs) + (mapUnionFV rhs_fvs pairs `unionFV` expr_fvs body) fv_cand in_scope acc --------- rhs_fvs :: (Id, CoreExpr) -> FV rhs_fvs (bndr, rhs) = expr_fvs rhs `unionFV` - bndrRuleAndUnfoldingVarsAcc bndr -- XXX: FIXME + bndrRuleAndUnfoldingVarsAcc bndr -- Treat any RULES as extra RHSs of the binding --------- exprs_fvs :: [CoreExpr] -> FV -exprs_fvs exprs = foldr (unionFV . expr_fvs) noVars exprs +exprs_fvs exprs = mapUnionFV expr_fvs exprs tickish_fvs :: Tickish Id -> FV tickish_fvs (Breakpoint _ ids) = someVars ids @@ -247,7 +261,8 @@ exprsOrphNames es = foldr (unionNameSet . exprOrphNames) emptyNameSet es ************************************************************************ -} --- | Those variables free in the right hand side of a rule +-- | Those variables free in the right hand side of a rule returned as a +-- non-deterministic set ruleRhsFreeVars :: CoreRule -> VarSet ruleRhsFreeVars (BuiltinRule {}) = noFVs ruleRhsFreeVars (Rule { ru_fn = _, ru_bndrs = bndrs, ru_rhs = rhs }) @@ -255,28 +270,29 @@ ruleRhsFreeVars (Rule { ru_fn = _, ru_bndrs = bndrs, ru_rhs = rhs }) -- See Note [Rule free var hack] -- | Those variables free in the both the left right hand sides of a rule +-- returned as a non-deterministic set ruleFreeVars :: CoreRule -> VarSet -ruleFreeVars (BuiltinRule {}) = noFVs -ruleFreeVars (Rule { ru_fn = _do_not_include -- See Note [Rule free var hack] - , ru_bndrs = bndrs - , ru_rhs = rhs, ru_args = args }) - = runFVSet $ filterFV isLocalVar $ addBndrs bndrs (exprs_fvs (rhs:args)) +ruleFreeVars = runFVSet . ruleFreeVarsAcc +-- | Those variables free in the both the left right hand sides of a rule +-- returned as FV computation ruleFreeVarsAcc :: CoreRule -> FV -ruleFreeVarsAcc (BuiltinRule {}) = - noVars -ruleFreeVarsAcc (Rule { ru_fn = _do_not_include -- See Note [Rule free var hack] +ruleFreeVarsAcc (BuiltinRule {}) = noVars +ruleFreeVarsAcc (Rule { ru_fn = _do_not_include + -- See Note [Rule free var hack] , ru_bndrs = bndrs , ru_rhs = rhs, ru_args = args }) - = addBndrs bndrs (exprs_fvs (rhs:args)) + = filterFV isLocalVar $ addBndrs bndrs (exprs_fvs (rhs:args)) +-- | Those variables free in the both the left right hand sides of rules +-- returned as FV computation rulesFreeVarsAcc :: [CoreRule] -> FV -rulesFreeVarsAcc (rule:rules) = ruleFreeVarsAcc rule `unionFV` rulesFreeVarsAcc rules -rulesFreeVarsAcc [] = noVars - -rulesFreeDVars :: [CoreRule] -> DVarSet -rulesFreeDVars rules = runFVDSet $ filterFV isLocalVar $ rulesFreeVarsAcc rules +rulesFreeVarsAcc = mapUnionFV ruleFreeVarsAcc +-- | Those variables free in the both the left right hand sides of rules +-- returned as a deterministic set +rulesFreeVarsDSet :: [CoreRule] -> DVarSet +rulesFreeVarsDSet rules = runFVDSet $ rulesFreeVarsAcc rules idRuleRhsVars :: (Activation -> Bool) -> Id -> VarSet -- Just the variables free on the *rhs* of a rule @@ -525,7 +541,7 @@ freeVars (Let (Rec binds) body) rhss2 = map freeVars rhss rhs_body_fvs = foldr (unionFVs . freeVarsOf) body_fvs rhss2 - binders_fvs = runFVDSet $ foldr (unionFV . idRuleAndUnfoldingVarsAcc) noVars binders + binders_fvs = runFVDSet $ mapUnionFV idRuleAndUnfoldingVarsAcc binders all_fvs = rhs_body_fvs `unionFVs` binders_fvs -- The "delBinderFV" happens after adding the idSpecVars, -- since the latter may add some of the binders as fvs diff --git a/compiler/ghci/ByteCodeGen.hs b/compiler/ghci/ByteCodeGen.hs index 83b8028c19..3091a453cd 100644 --- a/compiler/ghci/ByteCodeGen.hs +++ b/compiler/ghci/ByteCodeGen.hs @@ -479,7 +479,7 @@ schemeE d s p exp@(AnnTick (Breakpoint _id _fvs) _rhs) let letExp = AnnLet (AnnNonRec id (fvs, exp)) (emptyDVarSet, AnnVar id) schemeE d s p letExp where exp' = deAnnotate' exp - fvs = exprFreeDVars exp' + fvs = exprFreeVarsDSet exp' ty = exprType exp' -- ignore other kinds of tick diff --git a/compiler/simplCore/SetLevels.hs b/compiler/simplCore/SetLevels.hs index 2f98007fe7..65a36c3b46 100644 --- a/compiler/simplCore/SetLevels.hs +++ b/compiler/simplCore/SetLevels.hs @@ -771,10 +771,10 @@ lvlBind env (AnnRec pairs) -- Finding the free vars of the binding group is annoying bind_fvs = ((unionDVarSets [ rhs_fvs | (_, (rhs_fvs,_)) <- pairs]) `unionDVarSet` - (runFVDSet $ foldr unionFV noVars [ idFreeVarsAcc bndr - | (bndr, (_,_)) <- pairs])) - `minusDVarSet` - mkDVarSet bndrs -- XXX: it's a waste to create a set here + (runFVDSet $ unionsFV [ idFreeVarsAcc bndr + | (bndr, (_,_)) <- pairs])) + `delDVarSetList` + bndrs dest_lvl = destLevel env bind_fvs (all isFunction rhss) False abs_vars = abstractVars dest_lvl env bind_fvs diff --git a/compiler/specialise/Rules.hs b/compiler/specialise/Rules.hs index 1aa472b92a..f7a67ea8bd 100644 --- a/compiler/specialise/Rules.hs +++ b/compiler/specialise/Rules.hs @@ -33,7 +33,7 @@ import Module ( Module, ModuleSet, elemModuleSet ) import CoreSubst import OccurAnal ( occurAnalyseExpr ) import CoreFVs ( exprFreeVars, exprsFreeVars, bindFreeVars - , rulesFreeDVars, exprsOrphNames ) + , rulesFreeVarsDSet, exprsOrphNames ) import CoreUtils ( exprType, eqExpr, mkTick, mkTicks, stripTicksTopT, stripTicksTopE ) import PprCore ( pprRules ) @@ -275,11 +275,11 @@ pprRulesForUser rules -- | Make a 'RuleInfo' containing a number of 'CoreRule's, suitable -- for putting into an 'IdInfo' mkRuleInfo :: [CoreRule] -> RuleInfo -mkRuleInfo rules = RuleInfo rules (rulesFreeDVars rules) +mkRuleInfo rules = RuleInfo rules (rulesFreeVarsDSet rules) extendRuleInfo :: RuleInfo -> [CoreRule] -> RuleInfo extendRuleInfo (RuleInfo rs1 fvs1) rs2 - = RuleInfo (rs2 ++ rs1) (rulesFreeDVars rs2 `unionDVarSet` fvs1) + = RuleInfo (rs2 ++ rs1) (rulesFreeVarsDSet rs2 `unionDVarSet` fvs1) addRuleInfo :: RuleInfo -> RuleInfo -> RuleInfo addRuleInfo (RuleInfo rs1 fvs1) (RuleInfo rs2 fvs2) diff --git a/compiler/typecheck/Inst.hs b/compiler/typecheck/Inst.hs index 05a9208d92..6e918edf2f 100644 --- a/compiler/typecheck/Inst.hs +++ b/compiler/typecheck/Inst.hs @@ -9,7 +9,7 @@ The @Inst@ type: dictionaries or method instances {-# LANGUAGE CPP #-} module Inst ( - deeplySkolemise, deeplyInstantiate, + deeplySkolemise, deeplyInstantiate, instCall, instDFunType, instStupidTheta, newWanted, newWanteds, emitWanted, emitWanteds, @@ -25,6 +25,7 @@ module Inst ( -- Simple functions over evidence variables tyVarsOfWC, tyVarsOfBag, tyVarsOfCt, tyVarsOfCts, + tyVarsOfCtList, tyVarsOfCtsList, ) where #include "HsVersions.h" @@ -60,6 +61,7 @@ import Util import Outputable import Control.Monad( unless ) import Data.Maybe( isJust ) +import FV {- ************************************************************************ @@ -623,16 +625,43 @@ addClsInstsErr herald ispecs -} ---------------- Getting free tyvars ------------------------- -tyVarsOfCt :: Ct -> TcTyVarSet -tyVarsOfCt (CTyEqCan { cc_tyvar = tv, cc_rhs = xi }) = extendVarSet (tyVarsOfType xi) tv -tyVarsOfCt (CFunEqCan { cc_tyargs = tys, cc_fsk = fsk }) = extendVarSet (tyVarsOfTypes tys) fsk -tyVarsOfCt (CDictCan { cc_tyargs = tys }) = tyVarsOfTypes tys -tyVarsOfCt (CIrredEvCan { cc_ev = ev }) = tyVarsOfType (ctEvPred ev) -tyVarsOfCt (CHoleCan { cc_ev = ev }) = tyVarsOfType (ctEvPred ev) -tyVarsOfCt (CNonCanonical { cc_ev = ev }) = tyVarsOfType (ctEvPred ev) +-- | Returns free variables of constraints as a non-deterministic set +tyVarsOfCt :: Ct -> TcTyVarSet +tyVarsOfCt = runFVSet . tyVarsOfCtAcc + +-- | Returns free variables of constraints as a deterministically ordered. +-- list. See Note [Deterministic FV] in FV. +tyVarsOfCtList :: Ct -> [TcTyVar] +tyVarsOfCtList = runFVList . tyVarsOfCtAcc + +-- | Returns free variables of constraints as a composable FV computation. +-- See Note [Deterministic FV] in FV. +tyVarsOfCtAcc :: Ct -> FV +tyVarsOfCtAcc (CTyEqCan { cc_tyvar = tv, cc_rhs = xi }) + = tyVarsOfTypeAcc xi `unionFV` oneVar tv +tyVarsOfCtAcc (CFunEqCan { cc_tyargs = tys, cc_fsk = fsk }) + = tyVarsOfTypesAcc tys `unionFV` oneVar fsk +tyVarsOfCtAcc (CDictCan { cc_tyargs = tys }) = tyVarsOfTypesAcc tys +tyVarsOfCtAcc (CIrredEvCan { cc_ev = ev }) = tyVarsOfTypeAcc (ctEvPred ev) +tyVarsOfCtAcc (CHoleCan { cc_ev = ev }) = tyVarsOfTypeAcc (ctEvPred ev) +tyVarsOfCtAcc (CNonCanonical { cc_ev = ev }) = tyVarsOfTypeAcc (ctEvPred ev) + +-- | Returns free variables of a bag of constraints as a non-deterministic +-- set. See Note [Deterministic FV] in FV. tyVarsOfCts :: Cts -> TcTyVarSet -tyVarsOfCts = foldrBag (unionVarSet . tyVarsOfCt) emptyVarSet +tyVarsOfCts = runFVSet . tyVarsOfCtsAcc + +-- | Returns free variables of a bag of constraints as a deterministically +-- odered list. See Note [Deterministic FV] in FV. +tyVarsOfCtsList :: Cts -> [TcTyVar] +tyVarsOfCtsList = runFVList . tyVarsOfCtsAcc + +-- | Returns free variables of a bag of constraints as a composable FV +-- computation. See Note [Deterministic FV] in FV. +tyVarsOfCtsAcc :: Cts -> FV +tyVarsOfCtsAcc = foldrBag (unionFV . tyVarsOfCtAcc) noVars + tyVarsOfWC :: WantedConstraints -> TyVarSet -- Only called on *zonked* things, hence no need to worry about flatten-skolems diff --git a/compiler/typecheck/TcType.hs b/compiler/typecheck/TcType.hs index 48de69988a..4e48d9f65e 100644 --- a/compiler/typecheck/TcType.hs +++ b/compiler/typecheck/TcType.hs @@ -21,7 +21,7 @@ module TcType ( -------------------------------- -- Types TcType, TcSigmaType, TcRhoType, TcTauType, TcPredType, TcThetaType, - TcTyVar, TcTyVarSet, TcKind, TcCoVar, + TcTyVar, TcTyVarSet, TcDTyVarSet, TcKind, TcCoVar, -- TcLevel TcLevel(..), topTcLevel, pushTcLevel, @@ -144,6 +144,8 @@ module TcType ( tyVarsOfType, tyVarsOfTypes, closeOverKinds, tyVarsOfTypeList, tyVarsOfTypesList, + tyVarsOfTypeAcc, tyVarsOfTypesAcc, + tyVarsOfTypeDSet, tyVarsOfTypesDSet, closeOverKindsDSet, tcTyVarsOfType, tcTyVarsOfTypes, pprKind, pprParendKind, pprSigmaType, @@ -244,6 +246,7 @@ type TcRhoType = TcType -- Note [TcRhoType] type TcTauType = TcType type TcKind = Kind type TcTyVarSet = TyVarSet +type TcDTyVarSet = DTyVarSet {- Note [TcRhoType] diff --git a/compiler/types/TypeRep.hs b/compiler/types/TypeRep.hs index 3eac8b5e7a..384f1ef47a 100644 --- a/compiler/types/TypeRep.hs +++ b/compiler/types/TypeRep.hs @@ -44,6 +44,8 @@ module TypeRep ( -- Free variables tyVarsOfType, tyVarsOfTypes, closeOverKinds, varSetElemsKvsFirst, tyVarsOfTypeAcc, tyVarsOfTypeList, tyVarsOfTypesAcc, tyVarsOfTypesList, + tyVarsOfTypeDSet, tyVarsOfTypesDSet, + closeOverKindsDSet, closeOverKindsAcc, -- * Tidying type related things up for printing tidyType, tidyTypes, @@ -308,29 +310,49 @@ isKindVar v = isTKVar v && isSuperKind (varType v) ************************************************************************ -} +-- | Returns free variables of a type, including kind variables as +-- a non-deterministic set. For type synonyms it does /not/ expand the +-- synonym. tyVarsOfType :: Type -> VarSet --- ^ NB: for type synonyms tyVarsOfType does /not/ expand the synonym --- tyVarsOfType returns free variables of a type, including kind variables. tyVarsOfType ty = runFVSet $ tyVarsOfTypeAcc ty -- | `tyVarsOfType` that returns free variables of a type in deterministic -- order. For explanation of why using `VarSet` is not deterministic see --- Note [Deterministic UniqFM] in UniqDFM. -tyVarsOfTypeList :: Type -> [Var] +-- Note [Deterministic FV] in FV. +tyVarsOfTypeList :: Type -> [TyVar] tyVarsOfTypeList ty = runFVList $ tyVarsOfTypeAcc ty +-- | `tyVarsOfType` that returns free variables of a type in a deterministic +-- set. For explanation of why using `VarSet` is not deterministic see +-- Note [Deterministic FV] in FV. +tyVarsOfTypeDSet :: Type -> DTyVarSet +tyVarsOfTypeDSet ty = runFVDSet $ tyVarsOfTypeAcc ty + +-- | Returns free variables of types, including kind variables as +-- a non-deterministic set. For type synonyms it does /not/ expand the +-- synonym. tyVarsOfTypes :: [Type] -> TyVarSet tyVarsOfTypes tys = runFVSet $ tyVarsOfTypesAcc tys -tyVarsOfTypesList :: [Type] -> [Var] +-- | Returns free variables of types, including kind variables as +-- a deterministically ordered list. For type synonyms it does /not/ expand the +-- synonym. +tyVarsOfTypesList :: [Type] -> [TyVar] tyVarsOfTypesList tys = runFVList $ tyVarsOfTypesAcc tys +-- | Returns free variables of types, including kind variables as +-- a deterministic set. For type synonyms it does /not/ expand the +-- synonym. +tyVarsOfTypesDSet :: [Type] -> DTyVarSet +tyVarsOfTypesDSet tys = runFVDSet $ tyVarsOfTypesAcc tys + -- | The worker for `tyVarsOfType` and `tyVarsOfTypeList`. -- The previous implementation used `unionVarSet` which is O(n+m) and can -- make the function quadratic. -- It's exported, so that it can be composed with other functions that compute -- free variables. +-- See Note [FV naming conventions] in FV. tyVarsOfTypeAcc :: Type -> FV tyVarsOfTypeAcc (TyVarTy v) fv_cand in_scope acc = oneVar v fv_cand in_scope acc tyVarsOfTypeAcc (TyConApp _ tys) fv_cand in_scope acc = @@ -349,12 +371,22 @@ tyVarsOfTypesAcc (ty:tys) fv_cand in_scope acc = (tyVarsOfTypeAcc ty `unionFV` tyVarsOfTypesAcc tys) fv_cand in_scope acc tyVarsOfTypesAcc [] fv_cand in_scope acc = noVars fv_cand in_scope acc +-- | Add the kind variables free in the kinds of the tyvars in the given set. +-- Returns a non-deterministic set. closeOverKinds :: TyVarSet -> TyVarSet --- Add the kind variables free in the kinds --- of the tyvars in the given set -closeOverKinds tvs - = foldVarSet (\tv ktvs -> tyVarsOfType (tyVarKind tv) `unionVarSet` ktvs) - tvs tvs +closeOverKinds = runFVSet . closeOverKindsAcc . varSetElems + +-- | Given a list of tyvars returns a deterministic FV computation that +-- returns the given tyvars with the kind variables free in the kinds of the +-- given tyvars. +closeOverKindsAcc :: [TyVar] -> FV +closeOverKindsAcc tvs = + mapUnionFV (tyVarsOfTypeAcc . tyVarKind) tvs `unionFV` someVars tvs + +-- | Add the kind variables free in the kinds of the tyvars in the given set. +-- Returns a deterministic set. +closeOverKindsDSet :: DTyVarSet -> DTyVarSet +closeOverKindsDSet = runFVDSet . closeOverKindsAcc . dVarSetElems varSetElemsKvsFirst :: VarSet -> [TyVar] -- {k1,a,k2,b} --> [k1,k2,a,b] diff --git a/compiler/utils/FV.hs b/compiler/utils/FV.hs index 907a20f9ca..9ff273024c 100644 --- a/compiler/utils/FV.hs +++ b/compiler/utils/FV.hs @@ -17,10 +17,13 @@ module FV ( -- ** Manipulating those computations oneVar, noVars, + someVars, unionFV, + unionsFV, delFV, delFVs, filterFV, + mapUnionFV, ) where import Var @@ -30,7 +33,19 @@ import VarSet -- interesting type InterestingVarFun = Var -> Bool +-- Note [Deterministic FV] +-- ~~~~~~~~~~~~~~~~~~~~~~~ +-- When computing free variables, the order in which you get them affects +-- the results of floating and specialization. If you use UniqFM to collect +-- them and then turn that into a list, you get them in nondeterministic +-- order as described in Note [Deterministic UniqFM] in UniqDFM. + +-- A naive algorithm for free variables relies on merging sets of variables. +-- Merging costs O(n+m) for UniqFM and for UniqDFM there's an additional log +-- factor. It's cheaper to incrementally add to a list and use a set to check +-- for duplicates. type FV = InterestingVarFun + -- Used for filtering sets as we build them -> VarSet -- Locally bound variables -> ([Var], VarSet) @@ -40,48 +55,144 @@ type FV = InterestingVarFun -- Note [Deterministic UniqFM] in UniqDFM. -> ([Var], VarSet) +-- Note [FV naming conventions] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- To get the performance and determinism that FV provides, FV computations +-- need to built up from smaller FV computations and then evaluated with +-- one of `runFVList`, `runFVDSet`, `runFV`. That means the functions +-- returning FV need to be exported. +-- +-- The conventions are: +-- +-- a) non-deterministic functions: +-- * x - a function that returns VarSet +-- e.g. `tyVarsOfType` +-- b) deterministic functions: +-- * xAcc - a worker that returns FV +-- e.g. `tyVarsOfTypeAcc` +-- * xList - a function that returns [Var] +-- e.g. `tyVarsOfTypeList` +-- * xDSet - a function that returns DVarSet +-- e.g. `tyVarsOfTypeDSet` +-- +-- Where x, xList, xDSet are implemented in terms of the worker evaluated with +-- runFVSet, runFVList, runFVDSet respectively. + +-- | Run a free variable computation, returning a list of distinct free +-- variables in deterministic order and a non-deterministic set containing +-- those variables. runFV :: FV -> ([Var], VarSet) runFV fv = fv (const True) emptyVarSet ([], emptyVarSet) +-- | Run a free variable computation, returning a list of distinct free +-- variables in deterministic order. runFVList :: FV -> [Var] runFVList = fst . runFV +-- | Run a free variable computation, returning a deterministic set of free +-- variables. Note that this is just a wrapper around the version that +-- returns a deterministic list. If you need a list you should use +-- `runFVList`. runFVDSet :: FV -> DVarSet runFVDSet = mkDVarSet . fst . runFV +-- | Run a free variable computation, returning a non-deterministic set of +-- free variables. Don't use if the set will be later converted to a list +-- and the order of that list will impact the generated code. runFVSet :: FV -> VarSet runFVSet = snd . runFV -{-# INLINE oneVar #-} +-- Note [FV eta expansion] +-- ~~~~~~~~~~~~~~~~~~~~~~~ +-- Let's consider an eta-reduced implementation of freeVarsOf using FV: +-- +-- freeVarsOf (App a b) = freeVarsOf a `unionFV` freeVarsOf b +-- +-- If GHC doesn't eta-expand it, after inlining unionFV we end up with +-- +-- freeVarsOf = \x -> +-- case x of +-- App a b -> \fv_cand in_scope acc -> +-- freeVarsOf a fv_cand in_scope $! freeVarsOf b fv_cand in_scope $! acc +-- +-- which has to create a thunk, resulting in more allocations. +-- +-- On the other hand if it is eta-expanded: +-- +-- freeVarsOf (App a b) fv_cand in_scope acc = +-- (freeVarsOf a `unionFV` freeVarsOf b) fv_cand in_scope acc +-- +-- after inlining unionFV we have: +-- +-- freeVarsOf = \x fv_cand in_scope acc -> +-- case x of +-- App a b -> +-- freeVarsOf a fv_cand in_scope $! freeVarsOf b fv_cand in_scope $! acc +-- +-- which saves allocations. +-- +-- GHC when presented with knowledge about all the call sites, correctly +-- eta-expands in this case. Unfortunately due to the fact that freeVarsOf gets +-- exported to be composed with other functions, GHC doesn't have that +-- information and has to be more conservative here. +-- +-- Hence functions that get exported and return FV need to be manually +-- eta-expanded. See also #11146. + +-- | Add a variable - when free, to the returned free variables. +-- Ignores duplicates and respects the filtering function. oneVar :: Id -> FV oneVar var fv_cand in_scope acc@(have, haveSet) - = {- ASSERT( isId var ) probably not going to work -} fvs - where - fvs | var `elemVarSet` in_scope = acc - | var `elemVarSet` haveSet = acc - | fv_cand var = (var:have, extendVarSet haveSet var) - | otherwise = acc + | var `elemVarSet` in_scope = acc + | var `elemVarSet` haveSet = acc + | fv_cand var = (var:have, extendVarSet haveSet var) + | otherwise = acc +{-# INLINE oneVar #-} -{-# INLINE noVars #-} +-- | Return no free variables. noVars :: FV noVars _ _ acc = acc +{-# INLINE noVars #-} -{-# INLINE unionFV #-} +-- | Union two free variable computations. unionFV :: FV -> FV -> FV unionFV fv1 fv2 fv_cand in_scope acc = fv1 fv_cand in_scope $! fv2 fv_cand in_scope $! acc +{-# INLINE unionFV #-} -{-# INLINE delFV #-} +-- | Mark the variable as not free by putting it in scope. delFV :: Var -> FV -> FV delFV var fv fv_cand !in_scope acc = fv fv_cand (extendVarSet in_scope var) acc +{-# INLINE delFV #-} -{-# INLINE delFVs #-} +-- | Mark many free variables as not free. delFVs :: VarSet -> FV -> FV delFVs vars fv fv_cand !in_scope acc = fv fv_cand (in_scope `unionVarSet` vars) acc +{-# INLINE delFVs #-} -{-# INLINE filterFV #-} +-- | Filter a free variable computation. filterFV :: InterestingVarFun -> FV -> FV filterFV fv_cand2 fv fv_cand1 in_scope acc = fv (\v -> fv_cand1 v && fv_cand2 v) in_scope acc +{-# INLINE filterFV #-} + +-- | Map a free variable computation over a list and union the results. +mapUnionFV :: (a -> FV) -> [a] -> FV +mapUnionFV _f [] _fv_cand _in_scope acc = acc +mapUnionFV f (a:as) fv_cand in_scope acc = + mapUnionFV f as fv_cand in_scope $! f a fv_cand in_scope $! acc +{-# INLINE mapUnionFV #-} + +-- | Union many free variable computations. +unionsFV :: [FV] -> FV +unionsFV fvs fv_cand in_scope acc = mapUnionFV id fvs fv_cand in_scope acc +{-# INLINE unionsFV #-} + +-- | Add multiple variables - when free, to the returned free variables. +-- Ignores duplicates and respects the filtering function. +someVars :: [Var] -> FV +someVars vars fv_cand in_scope acc = + mapUnionFV oneVar vars fv_cand in_scope acc +{-# INLINE someVars #-} diff --git a/compiler/utils/UniqDFM.hs b/compiler/utils/UniqDFM.hs index 3f2830ab1f..aeb5b34116 100644 --- a/compiler/utils/UniqDFM.hs +++ b/compiler/utils/UniqDFM.hs @@ -28,6 +28,10 @@ module UniqDFM ( unitUDFM, addToUDFM, delFromUDFM, + delListFromUDFM, + adjustUDFM, + alterUDFM, + mapUDFM, plusUDFM, lookupUDFM, elemUDFM, @@ -37,7 +41,9 @@ module UniqDFM ( isNullUDFM, sizeUDFM, intersectUDFM, + disjointUDFM, minusUDFM, + partitionUDFM, udfmToList, udfmToUfm, @@ -222,11 +228,24 @@ intersectUDFM (UDFM x i) (UDFM y _j) = UDFM (M.intersection x y) i -- M.intersection is left biased, that means the result will only have -- a subset of elements from the left set, so `i` is a good upper bound. +disjointUDFM :: UniqDFM elt -> UniqDFM elt -> Bool +disjointUDFM (UDFM x _i) (UDFM y _j) = M.null (M.intersection x y) + minusUDFM :: UniqDFM elt1 -> UniqDFM elt2 -> UniqDFM elt1 minusUDFM (UDFM x i) (UDFM y _j) = UDFM (M.difference x y) i -- M.difference returns a subset of a left set, so `i` is a good upper -- bound. +-- | Partition UniqDFM into two UniqDFMs according to the predicate +partitionUDFM :: (elt -> Bool) -> UniqDFM elt -> (UniqDFM elt, UniqDFM elt) +partitionUDFM p (UDFM m i) = + case M.partition (p . taggedFst) m of + (left, right) -> (UDFM left i, UDFM right i) + +-- | Delete a list of elements from a UniqDFM +delListFromUDFM :: Uniquable key => UniqDFM elt -> [key] -> UniqDFM elt +delListFromUDFM = foldl delFromUDFM + -- | This allows for lossy conversion from UniqDFM to UniqFM udfmToUfm :: UniqDFM elt -> UniqFM elt udfmToUfm (UDFM m _i) = @@ -235,6 +254,32 @@ udfmToUfm (UDFM m _i) = listToUDFM_Directly :: [(Unique, elt)] -> UniqDFM elt listToUDFM_Directly = foldl (\m (u, v) -> addToUDFM_Directly m u v) emptyUDFM +-- | Apply a function to a particular element +adjustUDFM :: Uniquable key => (elt -> elt) -> UniqDFM elt -> key -> UniqDFM elt +adjustUDFM f (UDFM m i) k = UDFM (M.adjust (fmap f) (getKey $ getUnique k) m) i + +-- | The expression (alterUDFM f k map) alters value x at k, or absence +-- thereof. alterUDFM can be used to insert, delete, or update a value in +-- UniqDFM. Use addToUDFM, delFromUDFM or adjustUDFM when possible, they are +-- more efficient. +alterUDFM + :: Uniquable key + => (Maybe elt -> Maybe elt) -- How to adjust + -> UniqDFM elt -- old + -> key -- new + -> UniqDFM elt -- result +alterUDFM f (UDFM m i) k = + UDFM (M.alter alterf (getKey $ getUnique k) m) (i + 1) + where + alterf Nothing = inject $ f Nothing + alterf (Just (TaggedVal v _)) = inject $ f (Just v) + inject Nothing = Nothing + inject (Just v) = Just $ TaggedVal v i + +-- | Map a function over every value in a UniqDFM +mapUDFM :: (elt1 -> elt2) -> UniqDFM elt1 -> UniqDFM elt2 +mapUDFM f (UDFM m i) = UDFM (M.map (fmap f) m) i + -- This should not be used in commited code, provided for convenience to -- make ad-hoc conversions when developing alwaysUnsafeUfmToUdfm :: UniqFM elt -> UniqDFM elt diff --git a/compiler/utils/UniqDSet.hs b/compiler/utils/UniqDSet.hs index bf9f7a301c..85c5126e57 100644 --- a/compiler/utils/UniqDSet.hs +++ b/compiler/utils/UniqDSet.hs @@ -28,6 +28,8 @@ module UniqDSet ( isEmptyUniqDSet, lookupUniqDSet, uniqDSetToList, + partitionUniqDSet, + delListFromUniqDSet, ) where import UniqDFM @@ -86,3 +88,9 @@ lookupUniqDSet = lookupUDFM uniqDSetToList :: UniqDSet a -> [a] uniqDSetToList = eltsUDFM + +partitionUniqDSet :: (a -> Bool) -> UniqDSet a -> (UniqDSet a, UniqDSet a) +partitionUniqDSet = partitionUDFM + +delListFromUniqDSet :: Uniquable a => UniqDSet a -> [a] -> UniqDSet a +delListFromUniqDSet = delListFromUDFM |