Zubin pushed to branch wip/strict-level at Glasgow Haskell Compiler / GHC

Commits:

2 changed files:

Changes:

  • compiler/GHC/Core/Opt/SetLevels.hs
    ... ... @@ -109,7 +109,7 @@ import GHC.Types.Literal ( litIsTrivial )
    109 109 
     import GHC.Types.Demand       ( DmdSig, prependArgsDmdSig )
    110 110 
     import GHC.Types.Cpr          ( CprSig, prependArgsCprSig )
    111 111 
     import GHC.Types.Name         ( getOccName, mkSystemVarName )
    112 
    -import GHC.Types.Name.Occurrence ( occNameFS )
    112 
    +import GHC.Types.Name.Occurrence ( occNameFS, occNameString )
    113 113 
     import GHC.Types.Unique       ( hasKey )
    114 114 
     import GHC.Types.Tickish      ( tickishIsCode )
    115 115 
     import GHC.Types.Unique.Supply
    ... ... @@ -126,6 +126,7 @@ import GHC.Utils.Misc
    126 126 
     import GHC.Utils.Outputable
    127 127 
     import GHC.Utils.Panic
    128 128
    129 
    +import Data.List ( intercalate )
    129 130 
     import Data.Maybe
    130 131
    131 132 
     {-
    ... ... @@ -635,7 +636,7 @@ lvlMFE env strict_ctxt ann_expr
    635 636 
       = do { expr1 <- lvlFloatRhs abs_vars dest_lvl rhs_env NonRecursive
    636 637 
                                   is_bot_lam NotJoinPoint ann_expr
    637 638 
                       -- Treat the expr just like a right-hand side
    638 
    -       ; var <- newLvlVar expr1 NotJoinPoint is_mk_static
    639 
    +       ; var <- newLvlVar env expr1 NotJoinPoint is_mk_static
    639 640 
            ; let var2 = annotateBotStr var float_n_lams mb_bot_str
    640 641 
            ; return (Let (NonRec (TB var2 (FloatMe dest_lvl)) expr1)
    641 642 
                          (mkVarApps (Var var2) abs_vars)) }
    ... ... @@ -656,7 +657,7 @@ lvlMFE env strict_ctxt ann_expr
    656 657 
                              Case expr1 (stayPut l1r ubx_bndr) box_ty
    657 658 
                                  [Alt DEFAULT [] (App boxing_expr (Var ubx_bndr))]
    658 659
    659 
    -       ; var <- newLvlVar float_rhs NotJoinPoint is_mk_static
    660 
    +       ; var <- newLvlVar env float_rhs NotJoinPoint is_mk_static
    660 661 
            ; let l1u      = incMinorLvlFrom env
    661 662 
                  use_expr = Case (mkVarApps (Var var) abs_vars)
    662 663 
                                  (stayPut l1u bx_bndr) expr_ty
    ... ... @@ -1219,41 +1220,42 @@ lvlBind :: LevelEnv
    1219 1220 
             -> CoreBindWithFVs
    1220 1221 
             -> LvlM (LevelledBind, LevelEnv)
    1221 1222
    1222 
    -lvlBind env (AnnNonRec bndr rhs)
    1223 
    +lvlBind env0 (AnnNonRec bndr rhs)
    1223 1224 
       |  isTyVar bndr  -- Don't float TyVar binders (simplifier gets rid of them pronto)
    1224 1225 
       || isCoVar bndr  -- Don't float CoVars: difficult to fix up CoVar occurrences
    1225 1226 
                        --                     (see extendPolyLvlEnv)
    1226 
    -  || not (wantToFloat env NonRecursive dest_lvl is_join is_top_bindable)
    1227 
    +  || not (wantToFloat env0 NonRecursive dest_lvl is_join is_top_bindable)
    1227 1228 
       = -- No float
    1228 
    -    do { rhs' <- lvlRhs env NonRecursive is_bot_lam mb_join_arity rhs
    1229 
    -       ; let  bind_lvl        = incMinorLvl (le_ctxt_lvl env)
    1230 
    -              (env', [bndr']) = substAndLvlBndrs NonRecursive env bind_lvl [bndr]
    1231 
    -       ; return (NonRec bndr' rhs', env') }
    1229 
    +    do { rhs' <- lvlRhs env1 NonRecursive is_bot_lam mb_join_arity rhs
    1230 
    +       ; let  bind_lvl               = incMinorLvl (le_ctxt_lvl env1)
    1231 
    +              (env2, [bndr']) = substAndLvlBndrs NonRecursive env1 bind_lvl [bndr]
    1232 
    +       ; return (NonRec bndr' rhs', env2) }
    1232 1233
    1233 1234 
       -- Otherwise we are going to float
    1234 1235 
       | null abs_vars
    1235 1236 
       = do {  -- No type abstraction; clone existing binder
    1236 
    -         rhs' <- lvlFloatRhs [] dest_lvl env NonRecursive
    1237 
    +         rhs' <- lvlFloatRhs [] dest_lvl env1 NonRecursive
    1237 1238 
                                  is_bot_lam NotJoinPoint rhs
    1238 
    -       ; (env', [bndr']) <- cloneLetVars NonRecursive env dest_lvl [bndr]
    1239 
    +       ; (env2, [bndr']) <- cloneLetVars NonRecursive env1 dest_lvl [bndr]
    1239 1240 
            ; let bndr2 = annotateBotStr bndr' 0 mb_bot_str
    1240 
    -       ; return (NonRec (TB bndr2 (FloatMe dest_lvl)) rhs', env') }
    1241 
    +       ; return (NonRec (TB bndr2 (FloatMe dest_lvl)) rhs', env2) }
    1241 1242
    1242 1243 
       | otherwise
    1243 1244 
       = do {  -- Yes, type abstraction; create a new binder, extend substitution, etc
    1244 
    -         rhs' <- lvlFloatRhs abs_vars dest_lvl env NonRecursive
    1245 
    +         rhs' <- lvlFloatRhs abs_vars dest_lvl env1 NonRecursive
    1245 1246 
                                  is_bot_lam NotJoinPoint rhs
    1246 
    -       ; (env', [bndr']) <- newPolyBndrs dest_lvl env abs_vars [bndr]
    1247 
    +       ; (env2, [bndr']) <- newPolyBndrs dest_lvl env1 abs_vars [bndr]
    1247 1248 
            ; let bndr2 = annotateBotStr bndr' n_extra mb_bot_str
    1248 
    -       ; return (NonRec (TB bndr2 (FloatMe dest_lvl)) rhs', env') }
    1249 
    +       ; return (NonRec (TB bndr2 (FloatMe dest_lvl)) rhs', env2) }
    1249 1250
    1250 1251 
       where
    1252 
    +    env1       = pushBindContext env0 bndr
    1251 1253 
         bndr_ty    = idType bndr
    1252 1254 
         ty_fvs     = tyCoVarsOfType bndr_ty
    1253 1255 
         rhs_fvs    = freeVarsOf rhs
    1254 1256 
         bind_fvs   = rhs_fvs `unionDVarSet` dIdFreeVars bndr
    1255 
    -    abs_vars   = abstractVars dest_lvl env bind_fvs
    1256 
    -    dest_lvl   = destLevel env bind_fvs ty_fvs (isFunction rhs) is_bot_lam
    1257 
    +    abs_vars   = abstractVars dest_lvl env0 bind_fvs
    1258 
    +    dest_lvl   = destLevel env0 bind_fvs ty_fvs (isFunction rhs) is_bot_lam
    1257 1259
    1258 1260 
         deann_rhs  = deAnnotate rhs
    1259 1261 
         mb_bot_str = exprBotStrictness_maybe deann_rhs
    ... ... @@ -1273,7 +1275,8 @@ lvlBind env (AnnRec pairs)
    1273 1275 
       = -- No float
    1274 1276 
         do { let bind_lvl       = incMinorLvl (le_ctxt_lvl env)
    1275 1277 
                  (env', bndrs') = substAndLvlBndrs Recursive env bind_lvl bndrs
    1276 
    -             lvl_rhs (b,r)  = lvlRhs env' Recursive is_bot (idJoinPointHood b) r
    1278 
    +             lvl_rhs (b,r)  = lvlRhs env'' Recursive is_bot (idJoinPointHood b) r
    1279 
    +               where env'' = pushBindContext env' b
    1277 1280 
            ; rhss' <- mapM lvl_rhs pairs
    1278 1281 
            ; return (Rec (bndrs' `zip` rhss'), env') }
    1279 1282
    ... ... @@ -1298,8 +1301,9 @@ lvlBind env (AnnRec pairs)
    1298 1301 
             -- mutually recursive functions, but it's quite a bit more complicated
    1299 1302 
             --
    1300 1303 
             -- This all seems a bit ad hoc -- sigh
    1301 
    -    let (rhs_env, abs_vars_w_lvls) = lvlLamBndrs env dest_lvl abs_vars
    1304 
    +    let (rhs_env, abs_vars_w_lvls) = lvlLamBndrs env' dest_lvl abs_vars
    1302 1305 
             rhs_lvl = le_ctxt_lvl rhs_env
    1306 
    +        env' = pushBindContext env bndr
    1303 1307
    1304 1308 
         (rhs_env', [new_bndr]) <- cloneLetVars Recursive rhs_env rhs_lvl [bndr]
    1305 1309 
         let
    ... ... @@ -1307,7 +1311,7 @@ lvlBind env (AnnRec pairs)
    1307 1311 
             (body_env1, lam_bndrs1) = substBndrsSL NonRecursive rhs_env' lam_bndrs
    1308 1312 
             (body_env2, lam_bndrs2) = lvlLamBndrs body_env1 rhs_lvl lam_bndrs1
    1309 1313 
         new_rhs_body <- lvlRhs body_env2 Recursive is_bot NotJoinPoint rhs_body
    1310 
    -    (poly_env, [poly_bndr]) <- newPolyBndrs dest_lvl env abs_vars [bndr]
    1314 
    +    (poly_env, [poly_bndr]) <- newPolyBndrs dest_lvl env' abs_vars [bndr]
    1311 1315 
         return (Rec [(TB poly_bndr (FloatMe dest_lvl)
    1312 1316 
                      , mkLams abs_vars_w_lvls $
    1313 1317 
                        mkLams lam_bndrs2 $
    ... ... @@ -1332,9 +1336,10 @@ lvlBind env (AnnRec pairs)
    1332 1336 
                           -- function in a Rec, and we don't much care what
    1333 1337 
                           -- happens to it.  False is simple!
    1334 1338
    1335 
    -    do_rhs env (_,rhs) = lvlFloatRhs abs_vars dest_lvl env Recursive
    1336 
    -                                     is_bot NotJoinPoint
    1337 
    -                                     rhs
    1339 
    +    do_rhs env (b,rhs) =
    1340 
    +        lvlFloatRhs abs_vars dest_lvl env' Recursive
    1341 
    +                    is_bot NotJoinPoint rhs
    1342 
    +      where env' = pushBindContext env b
    1338 1343
    1339 1344 
             -- Finding the free vars of the binding group is annoying
    1340 1345 
         bind_fvs = ((unionDVarSets [ freeVarsOf rhs | (_, rhs) <- pairs])
    ... ... @@ -1632,16 +1637,17 @@ countFreeIds = nonDetStrictFoldUDFM add 0 . getUniqDSet
    1632 1637 
     -}
    1633 1638
    1634 1639 
     data LevelEnv
    1635 
    -  = LE { le_switches :: FloatOutSwitches
    1636 
    -       , le_ctxt_lvl :: !Level          -- The current level
    1637 
    -       , le_lvl_env  :: VarEnv Level    -- Domain is *post-cloned* TyVars and Ids
    1640 
    +  = LE { le_switches  :: FloatOutSwitches
    1641 
    +       , le_bind_ctxt :: [Id]
    1642 
    +       , le_ctxt_lvl  :: !Level          -- The current level
    1643 
    +       , le_lvl_env   :: VarEnv Level    -- Domain is *post-cloned* TyVars and Ids
    1638 1644
    1639 1645 
            -- See Note [le_subst and le_env]
    1640 
    -       , le_subst    :: Subst           -- Domain is pre-cloned TyVars and Ids
    1641 
    -                                        -- The Id -> CoreExpr in the Subst is ignored
    1642 
    -                                        -- (since we want to substitute a LevelledExpr for
    1643 
    -                                        -- an Id via le_env) but we do use the Co/TyVar substs
    1644 
    -       , le_env      :: IdEnv ([OutVar], LevelledExpr)  -- Domain is pre-cloned Ids
    1646 
    +       , le_subst     :: Subst           -- Domain is pre-cloned TyVars and Ids
    1647 
    +                                         -- The Id -> CoreExpr in the Subst is ignored
    1648 
    +                                         -- (since we want to substitute a LevelledExpr for
    1649 
    +                                         -- an Id via le_env) but we do use the Co/TyVar substs
    1650 
    +       , le_env       :: IdEnv ([OutVar], LevelledExpr)  -- Domain is pre-cloned Ids
    1645 1651 
         }
    1646 1652
    1647 1653 
     {- Note [le_subst and le_env]
    ... ... @@ -1678,6 +1684,7 @@ The domain of the le_lvl_env is the *post-cloned* Ids
    1678 1684 
     initialEnv :: FloatOutSwitches -> CoreProgram -> LevelEnv
    1679 1685 
     initialEnv float_lams binds
    1680 1686 
       = LE { le_switches  = float_lams
    1687 
    +       , le_bind_ctxt = []
    1681 1688 
            , le_ctxt_lvl  = tOP_LEVEL
    1682 1689 
            , le_lvl_env   = emptyVarEnv
    1683 1690 
            , le_subst     = mkEmptySubst in_scope_toplvl
    ... ... @@ -1690,6 +1697,9 @@ initialEnv float_lams binds
    1690 1697 
           -- to a later one.  So here we put all the top-level binders in scope before
    1691 1698 
           -- we start, to satisfy the lookupIdSubst invariants (#20200 and #20294)
    1692 1699
    1700 
    +pushBindContext :: LevelEnv -> Id -> LevelEnv
    1701 
    +pushBindContext env i = env { le_bind_ctxt = i : le_bind_ctxt env }
    1702 
    +
    1693 1703 
     addLvl :: Level -> VarEnv Level -> OutVar -> VarEnv Level
    1694 1704 
     addLvl dest_lvl env v' = extendVarEnv env v' dest_lvl
    1695 1705
    ... ... @@ -1829,11 +1839,12 @@ newPolyBndrs dest_lvl
    1829 1839 
           | otherwise
    1830 1840 
           = new_bndr
    1831 1841
    1832 
    -newLvlVar :: LevelledExpr        -- The RHS of the new binding
    1842 
    +newLvlVar :: LevelEnv
    1843 
    +          -> LevelledExpr        -- The RHS of the new binding
    1833 1844 
               -> JoinPointHood       -- Its join arity, if it is a join point
    1834 1845 
               -> Bool                -- True <=> the RHS looks like (makeStatic ...)
    1835 1846 
               -> LvlM Id
    1836 
    -newLvlVar lvld_rhs join_arity_maybe is_mk_static
    1847 
    +newLvlVar env lvld_rhs join_arity_maybe is_mk_static
    1837 1848 
       = do { uniq <- getUniqueM
    1838 1849 
            ; return (add_join_info (mk_id uniq rhs_ty))
    1839 1850 
            }
    ... ... @@ -1848,7 +1859,12 @@ newLvlVar lvld_rhs join_arity_maybe is_mk_static
    1848 1859 
           = mkExportedVanillaId (mkSystemVarName uniq (mkFastString "static_ptr"))
    1849 1860 
                                 rhs_ty
    1850 1861 
           | otherwise
    1851 
    -      = mkSysLocal (mkFastString "lvl") uniq ManyTy rhs_ty
    1862 
    +      = mkSysLocal stem uniq ManyTy rhs_ty
    1863 
    +
    1864 
    +    stem =
    1865 
    +      case le_bind_ctxt env of
    1866 
    +        []  -> mkFastString "lvl"
    1867 
    +        ctx -> mkFastString $ intercalate "_" ("lvl" : map (occNameString . getOccName) ctx)
    1852 1868
    1853 1869 
     -- | Clone the binders bound by a single-alternative case.
    1854 1870 
     cloneCaseBndrs :: LevelEnv -> Level -> [Var] -> LvlM (LevelEnv, [Var])

  • testsuite/tests/codeGen/should_compile/T25177.stderr
    ... ... @@ -7,9 +7,9 @@ foo = \ ds -> case ds of { D a ds1 -> W# a }
    7 7
    8 8 
     d = D 10## RUBBISH(IntRep)
    9 9
    10 
    -lvl = foo d
    10 
    +lvl_d = foo d
    11 11
    12 
    -bar1 = \ _ eta -> case lvl of { W# ipv -> (# eta, () #) }
    12 
    +bar1 = \ _ eta -> case lvl_d of { W# ipv -> (# eta, () #) }
    13 13
    14 14 
     bar = bar1 `cast` <Co:6> :: ...
    15 15

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help