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

Commits:

6 changed files:

Changes:

  • compiler/GHC/Core/Opt/Exitify.hs
    ... ... @@ -224,16 +224,11 @@ exitifyRec in_scope pairs
    224 224
    225 225 
           -- We have something to float out!
    226 226 
           | otherwise
    227 
    -      = do { -- Assemble the RHS of the exit join point
    228 
    -             -- Reminder: see GHC.Core.Utils
    229 
    -             --           Note [Type-lets and abstracting over free variables]
    230 
    -             let rhs   = mkCoreAbsLams abs_vars e
    231 
    -                 avoid = in_scope `extendInScopeSetList` captured
    232 
    -                 join_arity = count (isNothing . tyVarUnfolding_maybe) abs_vars
    233 
    -             -- Remember this binding under a suitable name
    234 
    -           ; v <- addExit avoid join_arity rhs
    235 
    -             -- And jump to it from here
    236 
    -           ; return $ mkAbsVarApps (Var v) abs_vars }
    227 
    +      = do { let avoid = in_scope `extendInScopeSetList` captured
    228 
    +             -- Create the new join-point binding, recording it in the monad
    229 
    +           ; j <- addExitBinding avoid abs_vars e
    230 
    +             -- Return a call of that join point
    231 
    +           ; return $ mkAbsVarApps (Var j) abs_vars }
    237 232
    238 233 
           where
    239 234 
             -- Used to detect exit expressions that are already proper exit jumps
    ... ... @@ -263,24 +258,27 @@ exitifyRec in_scope pairs
    263 258 
             captures_join_points = any isJoinId abs_vars
    264 259
    265 260
    266 
    -addExit :: InScopeSet -> JoinArity -> CoreExpr -> ExitifyM JoinId
    267 
    -addExit in_scope join_arity rhs
    261 
    +addExitBinding :: InScopeSet -> AbsVars -> CoreExpr -> ExitifyM JoinId
    262 
    +addExitBinding avoid1 abs_vars join_body
    268 263 
       = do { fs <- S.get
    269 
    -       ; let ty = exprType rhs
    270 
    -             avoid = in_scope `extendInScopeSetList` (map fst fs)
    271 
    -                              `extendInScopeSet` exit_id1 -- just cosmetics
    272 
    -               -- avoid: pick a new unique, that is disjoint from
    273 
    -               --  * the free variables of the whole joinrec
    274 
    -               --  * any bound variables (captured)
    275 
    -               --  * any exit join points created so far (in `fs`)
    276 
    -
    277 
    -             exit_id1 = mkSysLocal (fsLit "exit") initExitJoinUnique ManyTy ty
    278 
    -             exit_id2 = uniqAway avoid exit_id1
    279 
    -
    280 
    -             bind_pr@(exit_id3,_) = mkNewJoinPointBinding exit_id2 join_arity rhs
    281 
    -               -- NB: mkNewJoinPointBinding does eta-expansion if needed,
    282 
    -               --     to make sure that the join-point binding has the
    283 
    -               --     right number of lambdas all lined up at the top
    264 
    +       ; let join_rhs = mkCoreAbsLams abs_vars join_body
    265 
    +             -- mkCoreAbsLams: see GHC.Core.Utils
    266 
    +             --     Note [Type-lets and abstracting over free variables]
    267 
    +             join_arity = count (isNothing . tyVarUnfolding_maybe) abs_vars
    268 
    +
    269 
    +             avoid2 = avoid1 `extendInScopeSetList` (map fst fs)
    270 
    +                             `extendInScopeSet` exit_id1 -- just cosmetics
    271 
    +               -- avoid2: pick a new unique, that is disjoint from
    272 
    +               --  * avoid1: the free variables of the whole joinrec
    273 
    +               --            plus any bound variables (captured)
    274 
    +               --  * adding exit join points created so far (in `fs`)
    275 
    +
    276 
    +             join_ty  = exprType join_rhs
    277 
    +             exit_id1 = mkSysLocal (fsLit "exit") initExitJoinUnique ManyTy join_ty
    278 
    +             exit_id2 = uniqAway avoid2 exit_id1
    279 
    +
    280 
    +             bind_pr@(exit_id3,_) = mkNewJoinPointBinding exit_id2 join_arity join_rhs
    281 
    +               -- NB: mkNewJoinPointBinding adds the JoinId tag
    284 282
    285 283 
            ; S.put (bind_pr : fs)
    286 284 
            ; return exit_id3 }

  • compiler/GHC/Core/Opt/Simplify/Env.hs
    ... ... @@ -1095,7 +1095,8 @@ simplBinder !env bndr
    1095 1095 
       | otherwise     = simplIdBndr    env bndr
    1096 1096
    1097 1097 
     ---------------
    1098 
    -simplTyVarBndr :: SimplEnv -> InTyVar -> SimplM (SimplEnv, OutTyVar)
    1098 
    +simplTyVarBndr :: HasDebugCallStack
    1099 
    +               => SimplEnv -> InTyVar -> SimplM (SimplEnv, OutTyVar)
    1099 1100 
     simplTyVarBndr env tv
    1100 1101 
       = do  { let (env', tv1) = substTyVarBndr env tv
    1101 1102 
             ; seqTyVar tv1 `seq` return (env', tv1) }
    ... ... @@ -1387,7 +1388,7 @@ substTy env ty = Type.substTy (getTCvSubst env) ty
    1387 1388 
     substTyVar :: SimplEnv -> TyVar -> Type
    1388 1389 
     substTyVar env tv = Type.substTyVar (getTCvSubst env) tv
    1389 1390
    1390 
    -substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar)
    1391 
    +substTyVarBndr :: HasDebugCallStack => SimplEnv -> TyVar -> (SimplEnv, TyVar)
    1391 1392 
     substTyVarBndr env tv
    1392 1393 
       = case Type.substTyVarBndr (getTCvSubst env) tv of
    1393 1394 
             (Subst in_scope' _ tv_env' cv_env', tv')

  • compiler/GHC/Core/Opt/SpecConstr.hs
    ... ... @@ -1312,6 +1312,7 @@ data ArgOcc = NoOcc -- Doesn't occur at all; or a type argument
    1312 1312 
                 | ScrutOcc  -- See Note [ScrutOcc]
    1313 1313 
                      (DataConEnv [ArgOcc])
    1314 1314 
                          -- [ArgOcc]: how the sub-components are used
    1315 
    +                     -- /including/ (existential) tyvar binders
    1315 1316
    1316 1317 
     deadArgOcc :: ArgOcc -> Bool
    1317 1318 
     deadArgOcc (ScrutOcc {}) = False
    ... ... @@ -2717,24 +2718,27 @@ argToPat1 env in_scope val_env arg arg_occ _arg_str
    2717 2718 
         -- Ignore `_wf` here; see Note [ConVal work-free-ness] (2)
    2718 2719 
       , not (ignoreDataCon env dc)        -- See Note [NoSpecConstr]
    2719 2720 
       , Just arg_occs <- mb_scrut dc
    2720 
    -  = do { let (ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) args
    2721 
    -             con_str, matched_str :: [StrictnessMark]
    2722 
    -             -- con_str corresponds 1-1 with the /value/ arguments
    2723 
    -             -- matched_str corresponds 1-1 with /all/ arguments
    2721 
    +  = do { let -- `con_str` corresponds 1-1 with the /value/ arguments
    2722 
    +             -- `all_str` corresponds 1-1 with /all/ arguments
    2723 
    +             con_str, all_str :: [StrictnessMark]
    2724 2724 
                  con_str = dataConRepStrictness dc
    2725 
    -             matched_str = match_vals con_str rest_args
    2726 
    -      --  ; pprTraceM "bangs" (ppr (length rest_args == length con_str) $$
    2727 
    -      --       ppr dc $$
    2728 
    -      --       ppr con_str $$
    2729 
    -      --       ppr rest_args $$
    2730 
    -      --       ppr (map isTypeArg rest_args))
    2731 
    -       ; prs <- zipWith3M (argToPat env in_scope val_env) rest_args arg_occs matched_str
    2732 
    -       ; let args' = map sndOf3 prs :: [CoreArg]
    2733 
    -       ; assertPpr (length con_str == length (filter isRuntimeArg rest_args))
    2734 
    -            ( ppr con_str $$ ppr rest_args $$
    2735 
    -              ppr (length con_str) $$ ppr (length rest_args)
    2736 
    -            ) $ return ()
    2737 
    -       ; return (True, mkConApp dc (ty_args ++ args'), concat (map thdOf3 prs)) }
    2725 
    +             all_str = match_vals con_str args
    2726 
    +
    2727 
    +             -- `arg_occs` corresponnds 1-1 with the binders of a data con
    2728 
    +             -- pattern, which omits the universal tyvars. We extend with
    2729 
    +             -- `UnkOcc` for the universals to get `all_arg_occs`
    2730 
    +             all_arg_occs :: [ArgOcc]
    2731 
    +             all_arg_occs = map (const UnkOcc) (dataConUnivTyVars dc) ++ arg_occs
    2732 
    +
    2733 
    +       ; triples :: [(Bool, CoreArg, [Id])] <- zipWith3M (argToPat env in_scope val_env)
    2734 
    +                                                         args all_arg_occs all_str
    2735 
    +
    2736 
    +       ; let args'   = map sndOf3 triples :: [CoreArg]
    2737 
    +             cbv_ids = concat (map thdOf3 triples) :: [Id]
    2738 
    +
    2739 
    +       ; assertPpr (length con_str == valArgCount args)
    2740 
    +                   (ppr dc $$ ppr args $$ ppr arg_occs) $
    2741 
    +         return (True, mkConApp dc args', cbv_ids) }
    2738 2742 
       where
    2739 2743 
         mb_scrut dc = case arg_occ of
    2740 2744 
                     ScrutOcc bs | Just occs <- lookupUFM bs dc
    ... ... @@ -2743,6 +2747,8 @@ argToPat1 env in_scope val_env arg arg_occ _arg_str
    2743 2747 
                                 -> Just (repeat UnkOcc)
    2744 2748 
                                 | otherwise
    2745 2749 
                                 -> Nothing
    2750 
    +
    2751 
    +    match_vals :: [StrictnessMark] -> [CoreExpr] -> [StrictnessMark]
    2746 2752 
         match_vals bangs (arg:args)
    2747 2753 
           | isTypeArg arg
    2748 2754 
           = NotMarkedStrict : match_vals bangs args
    ... ... @@ -2828,6 +2834,8 @@ mkTyPat :: InScopeSet -> Type -> Type
    2828 2834 
     -- The tyvars `a` and `b` might have been in scope at the call site,
    2829 2835 
     -- but not at the definition site.  We want a call pattern
    2830 2836 
     --            f @a @a (K @a) a
    2837 
    +-- Here we are silently relying on non-shadowing; it's no good if a
    2838 
    +-- /different/ `b` is in scope at the definition site!
    2831 2839 
     mkTyPat in_scope ty
    2832 2840 
       = expandSomeTyVarUnfoldings not_in_scope ty
    2833 2841 
       where

  • compiler/GHC/Core/Utils.hs
    ... ... @@ -3115,26 +3115,56 @@ type AbsVar = Var
    3115 3115 
     type AbsVars       = [AbsVar]
    3116 3116 
     type TaggedAbsVars t = [TaggedBndr t]
    3117 3117
    3118 
    -mkPolyAbsLams :: (b -> AbsVar, Var -> b -> b)
    3119 
    -              -> [b] -> Expr b -> Expr b
    3118 
    +mkPolyAbsLams :: forall b. (b -> AbsVar, Var -> b -> b)
    3119 
    +                        -> [b] -> Expr b -> Expr b
    3120 3120 
     -- `mkPolyAbsLams` is polymorphic in (get,set) so that we can
    3121 3121 
     -- use it for both CoreExpr and LevelledExpr
    3122 3122 
     {-# INLINE mkPolyAbsLams #-}
    3123 
    -mkPolyAbsLams (get,set) bndrs body
    3124 
    -  = go bndrs
    3123 
    +mkPolyAbsLams (getter,setter) bndrs body
    3124 
    +  = go emptyVarSet [] bndrs
    3125 3125 
       where
    3126 
    -    go [] = body
    3127 
    -    go (bndr:bndrs)
    3126 
    +    go :: TyVarSet   -- Earlier TyVar bndrs that have TyVarUnfoldings
    3127 
    +       -> [Bind b]   -- Accumulated impedence-matching bindings (reversed)
    3128 
    +       -> [b]        -- Binders, bs
    3129 
    +       -> Expr b     -- The resulting lambda
    3130 
    +    go _ binds [] = mkLets (reverse binds) body
    3131 
    +
    3132 
    +    go unf_tvs binds (bndr:bndrs)
    3133 
    +
    3128 3134 
           | Just ty <- tyVarUnfolding_maybe var
    3129 
    -      = Let (NonRec bndr (Type ty)) $
    3130 
    -        go bndrs
    3135 
    +      = go (unf_tvs `extendVarSet` var) (NonRec bndr (Type ty) : binds) bndrs
    3136 
    +
    3137 
    +      | isTyVar var, change_ty
    3138 
    +      , let binds' | isDeadBinder var = binds
    3139 
    +                   | otherwise        = NonRec bndr (Type (mkTyVarTy var1)) : binds
    3140 
    +      = Lam (setter var1 bndr) (go unf_tvs binds' bndrs)
    3141 
    +
    3142 
    +      | isId var, change_ty || change_unf
    3143 
    +      , let binds' | isDeadBinder var = binds
    3144 
    +                   | otherwise        = NonRec bndr (Var id2) : binds
    3145 
    +      = Lam (setter id2 bndr) (go unf_tvs binds' bndrs)
    3146 
    +
    3131 3147 
           | otherwise
    3132 
    -      = Lam bndr' (go bndrs)
    3148 
    +      = Lam bndr  (go unf_tvs binds bndrs)
    3133 3149 
           where
    3134 
    -        var = get bndr
    3135 
    -        -- zap: We are going to lambda-abstract, so nuke any IdInfo
    3136 
    -        bndr' | isId var  = set (setIdInfo var vanillaIdInfo) bndr
    3137 
    -              | otherwise = bndr
    3150 
    +        var    = getter bndr
    3151 
    +        var_ty = varType var
    3152 
    +
    3153 
    +        (change_ty, var1) = update_type var
    3154 
    +        (change_unf, id2) = zap_unfolding var1  -- Only used for Ids
    3155 
    +
    3156 
    +        -- zap_unfolding: We are going to lambda-abstract, so nuke any IdInfo
    3157 
    +        zap_unfolding var | isId var, hasSomeUnfolding (idUnfolding var)
    3158 
    +                          = (True, setIdInfo var vanillaIdInfo)
    3159 
    +                          | otherwise
    3160 
    +                          = (False, var)
    3161 
    +
    3162 
    +        -- update_type: expand unfoldings of any tyvars in `unf_tvs`
    3163 
    +        update_type var | not (isEmptyVarSet unf_tvs)
    3164 
    +                        , anyFreeVarsOfType (`elemVarSet` unf_tvs) var_ty
    3165 
    +                        = (True, setVarType var (expandTyVarUnfoldings unf_tvs var_ty))
    3166 
    +                        | otherwise
    3167 
    +                        = (False, var)
    3138 3168
    3139 3169 
     mkCoreAbsLams :: AbsVars -> CoreExpr -> CoreExpr
    3140 3170 
     -- Specialise for CoreExpr

  • compiler/GHC/Types/Basic.hs
    ... ... @@ -73,7 +73,7 @@ module GHC.Types.Basic (
    73 73 
             isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker, isManyOccs,
    74 74 
             isNoOccInfo, strongLoopBreaker, weakLoopBreaker,
    75 75
    76 
    -        TyCoOccInfo(..), plusTyCoOccInfo, isOneTyCoOcc,
    76 
    +        TyCoOccInfo(..), plusTyCoOccInfo, isOneTyCoOcc, isDeadTyCoOcc,
    77 77
    78 78 
             InsideLam(..),
    79 79 
             BranchCount, oneBranch,
    ... ... @@ -1395,6 +1395,10 @@ isOneTyCoOcc :: TyCoOccInfo -> Bool
    1395 1395 
     isOneTyCoOcc TyCoOne = True
    1396 1396 
     isOneTyCoOcc _       = False
    1397 1397
    1398 
    +isDeadTyCoOcc :: TyCoOccInfo -> Bool
    1399 
    +isDeadTyCoOcc TyCoDead = True
    1400 
    +isDeadTyCoOcc _        = False
    1401 
    +
    1398 1402 
     plusTyCoOccInfo :: TyCoOccInfo -> TyCoOccInfo -> TyCoOccInfo
    1399 1403 
     plusTyCoOccInfo TyCoDead occ = occ
    1400 1404 
     plusTyCoOccInfo occ TyCoDead = occ

  • compiler/GHC/Types/Id.hs
    ... ... @@ -133,12 +133,7 @@ import GHC.Types.Id.Info
    133 133 
     import GHC.Types.Basic
    134 134
    135 135 
     -- Imported and re-exported
    136 
    -import GHC.Types.Var( Id, CoVar, JoinId,
    137 
    -            InId,  InVar,
    138 
    -            OutId, OutVar,
    139 
    -            idInfo, idDetails, setIdDetails, globaliseId, idMult,
    140 
    -            isId, isLocalId, isGlobalId, isExportedId,
    141 
    -            setIdMult, updateIdTypeAndMult, updateIdTypeButNotMult, updateIdTypeAndMultM)
    136 
    +import GHC.Types.Var
    142 137 
     import qualified GHC.Types.Var as Var
    143 138
    144 139 
     import GHC.Core ( CoreExpr, CoreRule, Unfolding(..), IdUnfoldingFun
    ... ... @@ -233,12 +228,6 @@ setIdUnique = Var.setVarUnique
    233 228 
     setIdType :: Id -> Type -> Id
    234 229 
     setIdType id ty = seqType ty `seq` Var.setVarType id ty
    235 230
    236 
    -setIdExported :: Id -> Id
    237 
    -setIdExported = Var.setIdExported
    238 
    -
    239 
    -setIdNotExported :: Id -> Id
    240 
    -setIdNotExported = Var.setIdNotExported
    241 
    -
    242 231 
     localiseId :: Id -> Id
    243 232 
     -- Make an Id with the same unique and type as the
    244 233 
     -- incoming Id, but with an *Internal* Name and *LocalId* flavour
    ... ... @@ -250,9 +239,6 @@ localiseId id
    250 239 
       where
    251 240 
         name = idName id
    252 241
    253 
    -lazySetIdInfo :: Id -> IdInfo -> Id
    254 
    -lazySetIdInfo = Var.lazySetIdInfo
    255 
    -
    256 242 
     setIdInfo :: Id -> IdInfo -> Id
    257 243 
     setIdInfo id info = info `seq` (lazySetIdInfo id info)
    258 244 
             -- Try to avoid space leaks by seq'ing
    ... ... @@ -624,9 +610,12 @@ isImplicitId id
    624 610 
     idIsFrom :: Module -> Id -> Bool
    625 611 
     idIsFrom mod id = nameIsLocalOrFrom mod (idName id)
    626 612
    627 
    -isDeadBinder :: Id -> Bool
    628 
    -isDeadBinder bndr | isId bndr = isDeadOcc (idOccInfo bndr)
    629 
    -                  | otherwise = False   -- TyVars count as not dead
    613 
    +isDeadBinder :: Var -> Bool
    614 
    +-- This predicate works on any Var, not just Ids
    615 
    +-- So this module isn't the ideal place for it; but moving it
    616 
    +-- elsewhere just gives silly module loops
    617 
    +isDeadBinder bndr | isId bndr = isDeadOcc     (idOccInfo bndr)
    618 
    +                  | otherwise = isDeadTyCoOcc (tyVarOccInfo bndr)
    630 619
    631 620 
     {-
    632 621 
     ************************************************************************

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