Simon Peyton Jones pushed to branch wip/T26543b at Glasgow Haskell Compiler / GHC

Commits:

3 changed files:

Changes:

  • compiler/GHC/Core/FVs.hs
    ... ... @@ -223,11 +223,11 @@ addCoreBndrsFV bndrs fv = foldr addCoreBndrFV fv bndrs
    223 223 
     unitFV :: Var -> SelectiveDFV
    224 224 
     -- Deals with an occurrence
    225 225 
     -- Shallow: does not look at the kind
    226 
    -unitFV v = MkFV (\bvs -> EndoOS (do_it bvs))
    226 
    +unitFV v = MkFV (\env -> EndoOS (do_it env))
    227 227 
       where
    228 
    -    do_it (is_interesting,bvs) acc
    228 
    +    do_it (bvs, is_interesting) acc
    229 
    +      | v `elemVarSet` bvs     = acc  -- First exclude the bound vars
    229 230 
           | not (is_interesting v) = acc  -- The "selective" bit
    230 
    -      | v `elemVarSet` bvs     = acc
    231 231 
           | v `elemDVarSet` acc    = acc
    232 232 
           | otherwise              = acc `extendDVarSet` v
    233 233

  • compiler/GHC/Core/TyCo/FVs.hs
    ... ... @@ -443,11 +443,11 @@ selectiveTcvFolder
    443 443 
                    , tcf_hole  = do_hole
    444 444 
                    , tcf_tycobinder = addBndrSelectiveFV }
    445 445 
       where
    446 
    -    do_tcv v = MkFV (\bvs -> EndoOS (do_it bvs))
    446 
    +    do_tcv v = MkFV (\env -> EndoOS (do_it env))
    447 447 
           where
    448 
    -        do_it (is_interesting,bvs) acc
    448 
    +        do_it (bvs,is_interesting) acc
    449 
    +          | v `elemVarSet` bvs     = acc  -- First exclude bound variables
    449 450 
               | not (is_interesting v) = acc  -- The "selective" bit
    450 
    -          | v `elemVarSet` bvs     = acc
    451 451 
               | v `elemDVarSet` acc    = acc
    452 452 
               | otherwise              = acc `extendDVarSet` v
    453 453
    ... ... @@ -847,43 +847,67 @@ invisibleVarsOfTypes = foldr (unionVarSet . invisibleVarsOfType) emptyVarSet
    847 847 
     *                                                                      *
    848 848 
     ********************************************************************* -}
    849 849
    850 
    -{-# INLINE afvFolder #-}   -- so that specialization to (const True) works
    851 
    -afvFolder :: (TyCoVar -> Bool) -> TyCoFolder (FV TyCoVarSet DM.Any)
    850 
    +{- Note [Any-free-var folder]
    851 
    +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    852 
    +The "any-free-var" folders take a `check_fv` predicate (TyCoVar -> Bool) and
    853 
    +check if any free variable of the type/coercion satisfies it.  Our main folders
    854 
    +look like:
    855 
    +
    856 
    +   afv_type :: Type -> FV (BoundVars, TyVar -> Bool) Any
    857 
    +
    858 
    +where we cleverly pair the predicate with the forall-bound variables of the type
    859 
    +in the "env" field of (FV env Any).  This way we can build the /folder/ once and
    860 
    +for all (independent of the `check_fv` predicate), and the loop passes down
    861 
    +the pair.
    862 
    +
    863 
    +The same idiom is used in `exprFreeVarsDSet` and friends.
    864 
    +
    865 
    +However we are careful to inline `atvFolder` and `runAny` so that we get those
    866 
    +nice tight loops.
    867 
    +-}
    868 
    +
    869 
    +{-# INLINE afvFolder #-}   -- See Note [Inlining any-fvs]
    870 
    +afvFolder :: TyCoFolder (FV (BoundVars, TyCoVar -> Bool) DM.Any)
    852 871 
     -- 'afvFolder' is short for "any-free-var folder", good for checking
    853 
    --- if any shallow free var of a type satisfies a predicate `check_fv`
    854 
    -afvFolder check_fv = TyCoFolder { tcf_view = noView  -- See Note [Free vars and synonyms]
    855 
    -                                , tcf_tyvar = do_tcv, tcf_covar = do_tcv
    856 
    -                                , tcf_hole = do_hole
    857 
    -                                , tcf_tycobinder = addBndrFV }
    872 
    +--   if any shallow free var of a type satisfies a predicate `check_fv`
    873 
    +-- The "env" of the (FV env Any) is a pair (bvs,pred) of
    874 
    +--    the bound variables (which are definitely not free), and
    875 
    +--    an "interesting var" predicate which the client supplies
    876 
    +afvFolder = TyCoFolder { tcf_view = noView  -- See Note [Free vars and synonyms]
    877 
    +                       , tcf_tyvar = do_tcv, tcf_covar = do_tcv
    878 
    +                       , tcf_hole = do_hole
    879 
    +                       , tcf_tycobinder = addBndrSelectiveFV }
    858 880 
       where
    859 
    -    do_tcv tv    = MkFV $ \ bvs ->
    881 
    +    do_tcv tv    = MkFV $ \ (bvs,check_fv) ->
    860 882 
                        Any (not (tv `elemVarSet` bvs) && check_fv tv)
    861 883 
         do_hole hole = do_tcv (coHoleCoVar hole)
    862 884
    885 
    +afv_type  :: Type     -> FV (BoundVars, TyVar -> Bool) DM.Any
    886 
    +afv_types :: [Type]   -> FV (BoundVars, TyVar -> Bool) DM.Any
    887 
    +afv_co    :: Coercion -> FV (BoundVars, TyVar -> Bool) DM.Any
    888 
    +(afv_type, afv_types, afv_co, _) = foldTyCo afvFolder
    889 
    +
    890 
    +runAny :: (TyVar -> Bool) -> FV (BoundVars, TyCoVar -> Bool) DM.Any -> Bool
    891 
    +{-# INLINE runAny #-}
    892 
    +runAny check_fv fvs = DM.getAny $ runFV fvs (emptyVarSet, check_fv)
    893 
    +
    863 894 
     anyFreeVarsOfType :: (TyCoVar -> Bool) -> Type -> Bool
    864 
    -anyFreeVarsOfType check_fv ty = DM.getAny (runFVTop (f ty))
    865 
    -  where (f, _, _, _) = foldTyCo (afvFolder check_fv)
    895 
    +anyFreeVarsOfType check_fv ty = runAny check_fv (afv_type ty)
    866 896
    867 897 
     anyFreeVarsOfTypes :: (TyCoVar -> Bool) -> [Type] -> Bool
    868 
    -anyFreeVarsOfTypes check_fv tys = DM.getAny (runFVTop (f tys))
    869 
    -  where (_, f, _, _) = foldTyCo (afvFolder check_fv)
    898 
    +anyFreeVarsOfTypes check_fv tys = runAny check_fv (afv_types tys)
    870 899
    871 900 
     anyFreeVarsOfCo :: (TyCoVar -> Bool) -> Coercion -> Bool
    872 
    -anyFreeVarsOfCo check_fv co = DM.getAny (runFVTop (f co))
    873 
    -  where (_, _, f, _) = foldTyCo (afvFolder check_fv)
    901 
    +anyFreeVarsOfCo check_fv co = runAny check_fv (afv_co co)
    874 902
    875 903 
     noFreeVarsOfType :: Type -> Bool
    876 
    -noFreeVarsOfType ty = not $ DM.getAny (runFVTop (f ty))
    877 
    -  where (f, _, _, _) = foldTyCo (afvFolder (const True))
    904 
    +noFreeVarsOfType ty = not $ runAny (const True) (afv_type ty)
    878 905
    879 906 
     noFreeVarsOfTypes :: [Type] -> Bool
    880 
    -noFreeVarsOfTypes tys = not $ DM.getAny (runFVTop (f tys))
    881 
    -  where (_, f, _, _) = foldTyCo (afvFolder (const True))
    907 
    +noFreeVarsOfTypes tys = not $ runAny (const True) (afv_types tys)
    882 908
    883 909 
     noFreeVarsOfCo :: Coercion -> Bool
    884 
    -noFreeVarsOfCo co = not $ DM.getAny (runFVTop (f co))
    885 
    -  where (_, _, f, _) = foldTyCo (afvFolder (const True))
    886 
    -
    910 
    +noFreeVarsOfCo co = not $ runAny (const True) (afv_co co)
    887 911
    888 912 
     {-
    889 913 
     ************************************************************************

  • compiler/GHC/Types/Var/FV.hs
    ... ... @@ -9,7 +9,7 @@ module GHC.Types.Var.FV (
    9 9 
             runFVSelective, runFVSelectiveList, runFVSelectiveSet,
    10 10 
             InterestingVarFun,
    11 11
    12 
    -        addBndrFV, addBndrsFV, addBndrSelectiveFV, addBndrsSelectiveFV,
    12 
    +        updEnvFV, addBndrFV, addBndrsFV, addBndrSelectiveFV, addBndrsSelectiveFV,
    13 13 
             emptyFV,   -- or `mempty`
    14 14 
             unionFV,   -- or `mappend`
    15 15 
             mapUnionFV
    ... ... @@ -138,7 +138,7 @@ type BoundVars = TyCoVarSet
    138 138
    139 139 
     type VarSetFV     = FV BoundVars (EndoOS TyCoVarSet)
    140 140 
     type DVarSetFV    = FV BoundVars (EndoOS DTyCoVarSet)
    141 
    -type SelectiveDFV = FV (InterestingVarFun, BoundVars) (EndoOS DVarSet)
    141 
    +type SelectiveDFV = FV (BoundVars, InterestingVarFun) (EndoOS DVarSet)
    142 142 
     -- VarSetFV:     collects a VarSet
    143 143 
     -- DVarSetFV:    collects a DVarSet (deterministic)
    144 144 
     -- SelectiveDFV: selectively collects a DVarSet
    ... ... @@ -174,28 +174,28 @@ emptyFV = MkFV (\_ -> mempty)
    174 174 
     unionFV :: Semigroup a => FV env a -> FV env a -> FV env a
    175 175 
     unionFV (MkFV' f1) (MkFV' f2) = MkFV (\env -> f1 env <> f2 env)
    176 176
    177 
    -upd_bndrs_fv :: (env -> env) -> FV env a -> FV env a
    178 
    -{-# INLINE addBndrFV #-}
    179 
    -upd_bndrs_fv upd f = MkFV (\bvs -> runFV f $! upd bvs)
    177 
    +updEnvFV :: (env -> env) -> FV env a -> FV env a
    178 
    +updEnvFV upd f = MkFV (\bvs -> runFV f $! upd bvs)
    180 179 
         -- Strict application to avoid making a thunk
    181 180
    182 181 
     addBndrFV :: TyCoVar -> FV BoundVars a -> FV BoundVars a
    183 
    -addBndrFV tcv = upd_bndrs_fv (\bvs -> extendVarSet bvs tcv)
    182 
    +{-# INLINE addBndrFV #-}
    183 
    +addBndrFV tcv = updEnvFV (\bvs -> extendVarSet bvs tcv)
    184 184
    185 185 
     addBndrsFV :: [Var] -> FV BoundVars a -> FV BoundVars a
    186 
    -addBndrsFV tcvs = upd_bndrs_fv (\bvs -> extendVarSetList bvs tcvs)
    186 
    +addBndrsFV tcvs = updEnvFV (\bvs -> extendVarSetList bvs tcvs)
    187 187
    188 
    -addBndrSelectiveFV :: TyCoVar -> FV (f, BoundVars) a -> FV (f, BoundVars) a
    188 
    +addBndrSelectiveFV :: TyCoVar -> FV (BoundVars, f) a -> FV (BoundVars, f) a
    189 189 
     addBndrSelectiveFV tcv
    190 
    -  = upd_bndrs_fv (\(f,bvs) -> let !bvs' = extendVarSet bvs tcv
    190 
    +  = updEnvFV (\(bvs,f) -> let !bvs' = extendVarSet bvs tcv
    191 191 
                                       -- Strict let to avoid thunks
    192 
    -                              in (f,bvs'))
    192 
    +                          in (bvs',f))
    193 193
    194 
    -addBndrsSelectiveFV :: [Var] -> FV (f, BoundVars) a -> FV (f, BoundVars) a
    194 
    +addBndrsSelectiveFV :: [Var] -> FV (BoundVars, f) a -> FV (BoundVars, f) a
    195 195 
     addBndrsSelectiveFV bs
    196 
    -  = upd_bndrs_fv (\(f,bvs) -> let !bvs' = extendVarSetList bvs bs
    196 
    +  = updEnvFV (\(bvs,f) -> let !bvs' = extendVarSetList bvs bs
    197 197 
                                       -- Strict let to avoid thunks
    198 
    -                              in (f,bvs'))
    198 
    +                          in (bvs',f))
    199 199
    200 200 
     mapUnionFV :: (Foldable t, Monoid acc)
    201 201 
               => (a -> FV env acc) -> t a -> FV env acc
    ... ... @@ -221,7 +221,7 @@ runTyCoVarsDSet f = runFVAcc f emptyDVarSet
    221 221
    222 222 
     runFVSelective :: InterestingVarFun -> SelectiveDFV -> DVarSet
    223 223 
     runFVSelective interesting f
    224 
    -  = runEndoOS (runFV f (interesting, emptyVarSet)) emptyDVarSet
    224 
    +  = runEndoOS (runFV f (emptyVarSet, interesting)) emptyDVarSet
    225 225
    226 226 
     runFVSelectiveList :: InterestingVarFun -> SelectiveDFV -> [Var]
    227 227 
     runFVSelectiveList interesting f = dVarSetElems (runFVSelective interesting f)

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help Notification message regarding https://gitlab.haskell.org/ghc/ghc/-/commit/e2f4f707b4ea34b99a04a7611618562d0160f886 at 1788945027