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