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

Commits:

1 changed file:

Changes:

  • compiler/GHC/Core/Opt/Simplify/Iteration.hs
    ... ... @@ -2265,19 +2265,6 @@ Some programs have a /lot/ of data constructors in the source program
    2265 2265 
     valuable.
    2266 2266 
     -}
    2267 2267
    2268 
    -simplInVar :: SimplEnv -> InVar -> SimplM OutExpr
    2269 
    --- Look up an InVar in the environment
    2270 
    -simplInVar env var
    2271 
    -  -- Why $! ? See Note [Bangs in the Simplifier]
    2272 
    -  | isTyVar var = return $! Type $! (substTyVar env var)
    2273 
    -  | isCoVar var = return $! Coercion $! (substCoVar env var)
    2274 
    -  | otherwise
    2275 
    -  = case substId env var of
    2276 
    -        ContEx tvs cvs ids e -> let env' = setSubstEnv env tvs cvs ids
    2277 
    -                                in simplExpr env' e
    2278 
    -        DoneId var1          -> return (Var var1)
    2279 
    -        DoneEx e _           -> return e
    2280 
    -
    2281 2268 
     simplInId :: SimplEnv -> InId -> SimplCont -> SimplM (SimplFloats, OutExpr)
    2282 2269 
     simplInId env var cont
    2283 2270 
       | Just dc <- isDataConWorkId_maybe var
    ... ... @@ -3066,25 +3053,6 @@ may be a result of 'seq' so we *definitely* don't want to drop those.
    3066 3053 
     I don't really know how to improve this situation.
    3067 3054
    3068 3055
    3069 
    -Note [FloatBinds from constructor wrappers]
    3070 
    -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    3071 
    -If we have FloatBinds coming from the constructor wrapper
    3072 
    -(as in Note [exprIsConApp_maybe on data constructors with wrappers]),
    3073 
    -we cannot float past them. We'd need to float the FloatBind
    3074 
    -together with the simplify floats, unfortunately the
    3075 
    -simplifier doesn't have case-floats. The simplest thing we can
    3076 
    -do is to wrap all the floats here. The next iteration of the
    3077 
    -simplifier will take care of all these cases and lets.
    3078 
    -
    3079 
    -Given data T = MkT !Bool, this allows us to simplify
    3080 
    -case $WMkT b of { MkT x -> f x }
    3081 
    -to
    3082 
    -case b of { b' -> f b' }.
    3083 
    -
    3084 
    -We could try and be more clever (like maybe wfloats only contain
    3085 
    -let binders, so we could float them). But the need for the
    3086 
    -extra complication is not clear.
    3087 
    -
    3088 3056 
     Note [Do not duplicate constructor applications]
    3089 3057 
     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    3090 3058 
     Consider this (#20125)
    ... ... @@ -3129,7 +3097,7 @@ rebuildCase env scrut case_bndr alts cont
    3129 3097 
       = do  { tick (KnownBranch case_bndr)
    3130 3098 
             ; case findAlt (LitAlt lit) alts of
    3131 3099 
                 Nothing             -> missingAlt env case_bndr alts cont
    3132 
    -            Just (Alt _ bs rhs) -> simple_rhs env [] scrut bs rhs }
    3100 
    +            Just (Alt _ bs rhs) -> simple_rhs env scrut bs rhs }
    3133 3101
    3134 3102 
       | Just (in_scope', wfloats, con, ty_args, other_args)
    3135 3103 
           <- exprIsConApp_maybe (getUnfoldingInRuleMatch env) scrut
    ... ... @@ -3137,58 +3105,26 @@ rebuildCase env scrut case_bndr alts cont
    3137 3105 
             -- as well as when it's an explicit constructor application
    3138 3106 
       , let env0 = setInScopeSet env in_scope'
    3139 3107 
       = do  { tick (KnownBranch case_bndr)
    3140 
    -        ; let scaled_wfloats = map scale_float wfloats
    3141 
    -              -- case_bndr_unf: see Note [Do not duplicate constructor applications]
    3108 
    +        ; let -- case_bndr_unf: see Note [Do not duplicate constructor applications]
    3142 3109 
                   case_bndr_rhs | exprIsTrivial scrut = scrut
    3143 3110 
                                 | otherwise           = con_app
    3144 3111 
                   con_app = Var (dataConWorkId con) `mkTyApps` ty_args
    3145 3112 
                                                     `mkApps`   other_args
    3146 
    -        ; case findAlt (DataAlt con) alts of
    3113 
    +        ; wrapDataConFloats env wfloats case_bndr cont $
    3114 
    +          case findAlt (DataAlt con) alts of
    3147 3115 
                 Nothing                   -> missingAlt env0 case_bndr alts cont
    3148 
    -            Just (Alt DEFAULT bs rhs) -> simple_rhs env0 scaled_wfloats case_bndr_rhs bs rhs
    3149 
    -            Just (Alt _       bs rhs) -> knownCon env0 scrut scaled_wfloats con ty_args
    3116 
    +            Just (Alt DEFAULT bs rhs) -> simple_rhs env0 case_bndr_rhs bs rhs
    3117 
    +            Just (Alt _       bs rhs) -> knownCon env0 scrut con
    3150 3118 
                                                       other_args case_bndr bs rhs cont
    3151 3119 
             }
    3152 3120 
       where
    3153 
    -    simple_rhs env wfloats case_bndr_rhs bs rhs =
    3121 
    +    simple_rhs env case_bndr_rhs bs rhs =
    3154 3122 
           assert (null bs) $
    3155 3123 
           do { (floats1, env') <- simplAuxBind "rebuildCase" env case_bndr case_bndr_rhs
    3156 3124 
                  -- scrut is a constructor application,
    3157 3125 
                  -- hence satisfies let-can-float invariant
    3158 3126 
              ; (floats2, expr') <- simplExprF env' rhs cont
    3159 
    -         ; case wfloats of
    3160 
    -             [] -> return (floats1 `addFloats` floats2, expr')
    3161 
    -             _ -> return
    3162 
    -               -- See Note [FloatBinds from constructor wrappers]
    3163 
    -                   ( emptyFloats env,
    3164 
    -                     GHC.Core.Make.wrapFloats wfloats $
    3165 
    -                     wrapFloats (floats1 `addFloats` floats2) expr' )}
    3166 
    -
    3167 
    -    -- This scales case floats by the multiplicity of the continuation hole (see
    3168 
    -    -- Note [Scaling in case-of-case]).  Let floats are _not_ scaled, because
    3169 
    -    -- they are aliases anyway.
    3170 
    -    scale_float (GHC.Core.Make.FloatCase scrut case_bndr con vars) =
    3171 
    -      let
    3172 
    -        scale_id id = scaleVarBy holeScaling id
    3173 
    -      in
    3174 
    -      GHC.Core.Make.FloatCase scrut (scale_id case_bndr) con (map scale_id vars)
    3175 
    -    scale_float f = f
    3176 
    -
    3177 
    -    holeScaling = contHoleScaling cont `mkMultMul` idMult case_bndr
    3178 
    -     -- We are in the following situation
    3179 
    -     --   case[p] case[q] u of { D x -> C v } of { C x -> w }
    3180 
    -     -- And we are producing case[??] u of { D x -> w[x\v]}
    3181 
    -     --
    3182 
    -     -- What should the multiplicity `??` be? In order to preserve the usage of
    3183 
    -     -- variables in `u`, it needs to be `pq`.
    3184 
    -     --
    3185 
    -     -- As an illustration, consider the following
    3186 
    -     --   case[Many] case[1] of { C x -> C x } of { C x -> (x, x) }
    3187 
    -     -- Where C :: A %1 -> T is linear
    3188 
    -     -- If we were to produce a case[1], like the inner case, we would get
    3189 
    -     --   case[1] of { C x -> (x, x) }
    3190 
    -     -- Which is ill-typed with respect to linearity. So it needs to be a
    3191 
    -     -- case[Many].
    3127 
    +         ; return (floats1 `addFloats` floats2, expr') }
    3192 3128
    3193 3129 
     --------------------------------------------------
    3194 3130 
     --      2. Eliminate the case if scrutinee is evaluated
    ... ... @@ -3736,29 +3672,81 @@ and then
    3736 3672 
             f (h v)
    3737 3673
    3738 3674 
     All this should happen in one sweep.
    3675 
    +
    3676 
    +Note [FloatBinds from constructor wrappers]
    3677 
    +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    3678 
    +If we have FloatBinds coming from the constructor wrapper
    3679 
    +(as in Note [exprIsConApp_maybe on data constructors with wrappers]),
    3680 
    +we cannot float past them. We'd need to float the FloatBind
    3681 
    +together with the simplify floats, unfortunately the
    3682 
    +simplifier doesn't have case-floats. The simplest thing we can
    3683 
    +do is to wrap all the floats here. The next iteration of the
    3684 
    +simplifier will take care of all these cases and lets.
    3685 
    +
    3686 
    +Given data T = MkT !Bool, this allows us to simplify
    3687 
    +case $WMkT b of { MkT x -> f x }
    3688 
    +to
    3689 
    +case b of { b' -> f b' }.
    3690 
    +
    3691 
    +We could try and be more clever (like maybe wfloats only contain
    3692 
    +let binders, so we could float them). But the need for the
    3693 
    +extra complication is not clear.
    3739 3694 
     -}
    3740 3695
    3696 
    +wrapDataConFloats :: SimplEnv -> [FloatBind] -> InId -> SimplCont
    3697 
    +                 -> SimplM (SimplFloats, OutExpr)
    3698 
    +                 -> SimplM (SimplFloats, OutExpr)
    3699 
    +-- See Note [FloatBinds from constructor wrappers]
    3700 
    +wrapDataConFloats env wfloats case_bndr cont thing_inside
    3701 
    +  | null wfloats
    3702 
    +  = thing_inside
    3703 
    +  | otherwise
    3704 
    +  = do { (floats, expr) <- thing_inside
    3705 
    +       ; return ( emptyFloats env
    3706 
    +                , GHC.Core.Make.wrapFloats (map scale_float wfloats) $
    3707 
    +                  wrapFloats floats expr ) }
    3708 
    +  where
    3709 
    +    -- scale_float scales case-floats by the multiplicity of the continuation hole
    3710 
    +    -- (see Note [Scaling in case-of-case]).
    3711 
    +    -- Let floats are _not_ scaled, because they are aliases anyway.
    3712 
    +    scale_float (GHC.Core.Make.FloatCase scrut case_bndr con vars)
    3713 
    +      = GHC.Core.Make.FloatCase scrut (scale_id case_bndr) con (map scale_id vars)
    3714 
    +    scale_float flt@(GHC.Core.Make.FloatLet {})
    3715 
    +      = flt
    3716 
    +
    3717 
    +    scale_id id = scaleVarBy holeScaling id
    3718 
    +
    3719 
    +    holeScaling = contHoleScaling cont `mkMultMul` idMult case_bndr
    3720 
    +     -- We are in the following situation
    3721 
    +     --   case[p] case[q] u of { D x -> C v } of { C x -> w }
    3722 
    +     -- And we are producing case[??] u of { D x -> w[x\v]}
    3723 
    +     --
    3724 
    +     -- What should the multiplicity `??` be? In order to preserve the usage of
    3725 
    +     -- variables in `u`, it needs to be `pq`.
    3726 
    +     --
    3727 
    +     -- As an illustration, consider the following
    3728 
    +     --   case[Many] case[1] of { C x -> C x } of { C x -> (x, x) }
    3729 
    +     -- Where C :: A %1 -> T is linear
    3730 
    +     -- If we were to produce a case[1], like the inner case, we would get
    3731 
    +     --   case[1] of { C x -> (x, x) }
    3732 
    +     -- Which is ill-typed with respect to linearity. So it needs to be a
    3733 
    +     -- case[Many].
    3734 
    +
    3735 
    +
    3741 3736 
     knownCon :: SimplEnv
    3742 
    -         -> OutExpr                                           -- The scrutinee
    3743 
    -         -> [FloatBind] -> DataCon -> [OutType] -> [OutExpr]  -- The scrutinee (in pieces)
    3744 
    -         -> InId -> [InBndr] -> InExpr                        -- The alternative
    3737 
    +         -> OutExpr                            -- The scrutinee
    3738 
    +         -> DataCon -> [OutExpr]               -- The scrutinee (in pieces)
    3739 
    +         -> InId -> [InBndr] -> InExpr         -- The alternative
    3745 3740 
              -> SimplCont
    3746 3741 
              -> SimplM (SimplFloats, OutExpr)
    3747 3742
    3748 
    -knownCon env scrut dc_floats dc dc_ty_args dc_args bndr bs rhs cont
    3749 
    -  = do  { (floats1, env1)  <- bind_args env bs dc_args
    3743 
    +knownCon env scrut dc dc_args case_bndr alt_bndrs rhs cont
    3744 
    +  = do  { (floats1, env1)  <- bind_args env alt_bndrs dc_args
    3750 3745 
             ; (floats2, env2)  <- bind_case_bndr env1
    3751 3746 
             ; (floats3, expr') <- simplExprF env2 rhs cont
    3752 
    -        ; case dc_floats of
    3753 
    -            [] ->
    3754 
    -              return (floats1 `addFloats` floats2 `addFloats` floats3, expr')
    3755 
    -            _ ->
    3756 
    -              return ( emptyFloats env
    3757 
    -               -- See Note [FloatBinds from constructor wrappers]
    3758 
    -                     , GHC.Core.Make.wrapFloats dc_floats $
    3759 
    -                       wrapFloats (floats1 `addFloats` floats2 `addFloats` floats3) expr') }
    3747 
    +        ; return (floats1 `addFloats` floats2 `addFloats` floats3, expr') }
    3760 3748 
       where
    3761 
    -    zap_occ = zapBndrOccInfo (isDeadBinder bndr)    -- bndr is an InId
    3749 
    +    zap_occ = zapBndrOccInfo (isDeadBinder case_bndr)    -- case_bndr is an InId
    3762 3750
    3763 3751 
                       -- Ugh!
    3764 3752 
         bind_args env' [] _  = return (emptyFloats env', env')
    ... ... @@ -3783,28 +3771,32 @@ knownCon env scrut dc_floats dc dc_ty_args dc_args bndr bs rhs cont
    3783 3771 
                ; return (floats1 `addFloats` floats2, env3) }
    3784 3772
    3785 3773 
         bind_args _ _ _ =
    3786 
    -      pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr dc_args $$
    3774 
    +      pprPanic "bind_args" $ ppr dc $$ ppr alt_bndrs $$ ppr dc_args $$
    3787 3775 
                                  text "scrut:" <+> ppr scrut
    3788 3776
    3789 
    -       -- It's useful to bind bndr to scrut, rather than to a fresh
    3777 
    +       -- It's useful to bind case_bndr to scrut, rather than to a fresh
    3790 3778 
            -- binding      x = Con arg1 .. argn
    3791 3779 
            -- because very often the scrut is a variable, so we avoid
    3792 3780 
            -- creating, and then subsequently eliminating, a let-binding
    3793 3781 
            -- BUT, if scrut is a not a variable, we must be careful
    3794 3782 
            -- about duplicating the arg redexes; in that case, make
    3795 3783 
            -- a new con-app from the args
    3784 
    +    con_app :: InExpr
    3785 
    +    con_app = mkConApp2 dc (tyConAppArgs (idType case_bndr)) alt_bndrs
    3786 
    +
    3796 3787 
         bind_case_bndr env
    3797 
    -      | isDeadBinder bndr   = return (emptyFloats env, env)
    3798 
    -      | exprIsTrivial scrut = return (emptyFloats env
    3799 
    -                                     , extendIdSubst env bndr (DoneEx scrut NotJoinPoint))
    3800 
    -                              -- See Note [Do not duplicate constructor applications]
    3801 
    -      | otherwise           = do { dc_args <- mapM (simplInVar env) bs
    3802 
    -                                         -- dc_ty_args are already OutTypes,
    3803 
    -                                         -- but bs are InBndrs
    3804 
    -                                 ; let con_app = Var (dataConWorkId dc)
    3805 
    -                                                 `mkTyApps` dc_ty_args
    3806 
    -                                                 `mkApps`   dc_args
    3807 
    -                                 ; simplAuxBind "case-bndr" env bndr con_app }
    3788 
    +      | exprIsTrivial scrut
    3789 
    +      = -- See Note [Do not duplicate constructor applications]
    3790 
    +        return ( emptyFloats env
    3791 
    +               , extendIdSubst env case_bndr (DoneEx scrut NotJoinPoint))
    3792 
    +
    3793 
    +      | Just env' <- preInlineUnconditionally env NotTopLevel case_bndr con_app env
    3794 
    +      = return (emptyFloats env', env')
    3795 
    +
    3796 
    +      | otherwise
    3797 
    +      = do { (env1, case_bndr1)    <- simplNonRecBndr env case_bndr
    3798 
    +           ; simplLazyBind NotTopLevel NonRecursive
    3799 
    +                           (case_bndr,env) (case_bndr1,env1) (con_app,env) }
    3808 3800
    3809 3801 
     -------------------
    3810 3802 
     missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont

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