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

Commits:

1 changed file:

Changes:

  • compiler/GHC/Core/Opt/Simplify/Iteration.hs
    ... ... @@ -57,7 +57,7 @@ import GHC.Types.Var ( isTyCoVar )
    57 57 
     import GHC.Builtin.Types.Prim( realWorldStatePrimTy )
    58 58 
     import GHC.Builtin.Names( runRWKey, seqHashKey )
    59 59
    60 
    -import GHC.Data.Maybe   ( isJust, orElse, mapMaybe )
    60 
    +import GHC.Data.Maybe   ( isNothing, orElse, mapMaybe )
    61 61 
     import GHC.Data.FastString
    62 62 
     import GHC.Unit.Module ( moduleName )
    63 63 
     import GHC.Utils.Outputable
    ... ... @@ -3860,19 +3860,23 @@ altsWouldDup (alt:alts)
    3860 3860 
         is_bot_alt (Alt _ _ rhs) = exprIsDeadEnd rhs
    3861 3861
    3862 3862 
     -------------------------
    3863 
    +data DupContFlag = DupAppsOnly
    3864 
    +                 | DupSelectToo
    3865 
    +
    3863 3866 
     mkDupableCont :: SimplEnv
    3864 3867 
                   -> SimplCont
    3865 3868 
                   -> SimplM ( SimplFloats  -- Incoming SimplEnv augmented with
    3866 3869 
                                            --   extra let/join-floats and in-scope variables
    3867 3870 
                             , SimplCont)   -- dup_cont: duplicable continuation
    3868 3871 
     mkDupableCont env cont
    3869 
    -  = mkDupableContWithDmds (zapSubstEnv env) (repeat topDmd) cont
    3872 
    +  = mkDupableContWithDmds (zapSubstEnv env) DupSelectToo (repeat topDmd) cont
    3870 3873
    3871 3874 
     mkDupableContWithDmds
    3872 
    -   :: SimplEnvIS  -> [Demand]  -- Demands on arguments; always infinite
    3875 
    +   :: SimplEnvIS -> DupContFlag
    3876 
    +   -> [Demand]  -- Demands on arguments; always infinite
    3873 3877 
        -> SimplCont -> SimplM ( SimplFloats, SimplCont)
    3874 3878
    3875 
    -mkDupableContWithDmds env _ cont
    3879 
    +mkDupableContWithDmds env _ _ cont
    3876 3880 
       -- Check the invariant
    3877 3881 
       | assertPpr (checkSimplEnvIS env) (pprBadSimplEnvIS env) False
    3878 3882 
       = pprPanic "mkDupableContWithDmds" empty
    ... ... @@ -3880,20 +3884,63 @@ mkDupableContWithDmds env _ cont
    3880 3884 
       | contIsDupable cont
    3881 3885 
       = return (emptyFloats env, cont)
    3882 3886
    3883 
    -mkDupableContWithDmds _ _ (Stop {}) = panic "mkDupableCont"     -- Handled by previous eqn
    3887 
    +mkDupableContWithDmds _ _ _ (Stop {})
    3888 
    +  = panic "mkDupableCont"     -- Handled by previous contIsDupable eqn
    3884 3889
    3885 
    -mkDupableContWithDmds env dmds (CastIt { sc_co = co, sc_opt = opt, sc_cont = cont })
    3886 
    -  = do  { (floats, cont') <- mkDupableContWithDmds env dmds cont
    3890 
    +mkDupableContWithDmds env df dmds
    3891 
    +    (CastIt { sc_co = co, sc_opt = opt, sc_cont = cont })
    3892 
    +  = do  { (floats, cont') <- mkDupableContWithDmds env df dmds cont
    3887 3893 
             ; return (floats, CastIt { sc_co = optOutCoercion env co opt
    3888 3894 
                                      , sc_opt = True, sc_cont = cont' }) }
    3889 3895 
                      -- optOutCoercion: see Note [Avoid re-simplifying coercions]
    3890 3896
    3891 3897 
     -- Duplicating ticks for now, not sure if this is good or not
    3892 
    -mkDupableContWithDmds env dmds (TickIt t cont)
    3893 
    -  = do  { (floats, cont') <- mkDupableContWithDmds env dmds cont
    3898 
    +mkDupableContWithDmds env df dmds
    3899 
    +    (TickIt t cont)
    3900 
    +  = do  { (floats, cont') <- mkDupableContWithDmds env df dmds cont
    3894 3901 
             ; return (floats, TickIt t cont') }
    3895 3902
    3896 
    -mkDupableContWithDmds env _
    3903 
    +mkDupableContWithDmds env df dmds
    3904 
    +    (ApplyToTy { sc_cont = cont, sc_arg_ty = arg_ty, sc_hole_ty = hole_ty })
    3905 
    +  = do  { (floats, cont') <- mkDupableContWithDmds env df dmds cont
    3906 
    +        ; return (floats, ApplyToTy { sc_cont = cont'
    3907 
    +                                    , sc_arg_ty = arg_ty, sc_hole_ty = hole_ty }) }
    3908 
    +
    3909 
    +mkDupableContWithDmds env df dmds
    3910 
    +    (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_env = se
    3911 
    +                , sc_cont = cont, sc_hole_ty = hole_ty })
    3912 
    +  =     -- e.g.         [...hole...] (...arg...)
    3913 
    +        --      ==>
    3914 
    +        --              let a = ...arg...
    3915 
    +        --              in [...hole...] a
    3916 
    +        -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable
    3917 
    +    do  { let dmd:|cont_dmds = expectNonEmpty dmds
    3918 
    +        ; (floats1, cont') <- mkDupableContWithDmds env df cont_dmds cont
    3919 
    +        ; let env' = env `setInScopeFromF` floats1
    3920 
    +        ; (_, se', arg') <- simplLazyArg env' dup hole_ty Nothing se arg
    3921 
    +
    3922 
    +        -- Make the argument duplicable. Danger: if arg is small and we let-bind
    3923 
    +        -- it, then postInlineUnconditionally will just inline it again, perhaps
    3924 
    +        -- taking an extra Simplifier iteration (e.g. in test T21839c). So make
    3925 
    +        -- a `let` only if `couldBeSmallEnoughToInline` says that it is big enough
    3926 
    +        ; let uf_opts = seUnfoldingOpts env
    3927 
    +        ; (let_floats2, arg'')
    3928 
    +              <- if couldBeSmallEnoughToInline uf_opts (unfoldingUseThreshold uf_opts) arg'
    3929 
    +                 then return (emptyLetFloats, arg')
    3930 
    +                 else makeTrivial env NotTopLevel dmd (fsLit "karg") arg'
    3931 
    +
    3932 
    +        ; let all_floats = floats1 `addLetFloats` let_floats2
    3933 
    +        ; return ( all_floats
    3934 
    +                 , ApplyToVal { sc_arg = arg''
    3935 
    +                              , sc_env = se' `setInScopeFromF` all_floats
    3936 
    +                                         -- Ensure that sc_env includes the free vars of
    3937 
    +                                         -- arg'' in its in-scope set, even if makeTrivial
    3938 
    +                                         -- has turned arg'' into a fresh variable
    3939 
    +                                         -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils
    3940 
    +                              , sc_dup = OkToDup, sc_cont = cont'
    3941 
    +                              , sc_hole_ty = hole_ty }) }
    3942 
    +
    3943 
    +mkDupableContWithDmds env _ _
    3897 3944 
          (StrictBind { sc_bndr = bndr, sc_body = body, sc_from = from_what
    3898 3945 
                      , sc_env = se, sc_cont = cont})
    3899 3946 
     -- See Note [Duplicating StrictBind]
    ... ... @@ -3910,42 +3957,30 @@ mkDupableContWithDmds env _
    3910 3957
    3911 3958 
            ; mkDupableStrictBind env bndr' join_body res_ty }
    3912 3959
    3913 
    -mkDupableContWithDmds env _
    3960 
    +mkDupableContWithDmds env DupSelectToo _
    3914 3961 
         (StrictArg { sc_fun = fun, sc_cont = cont, sc_fun_ty = fun_ty })
    3915 3962 
       -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable
    3916 
    -  | isJust (isDataConId_maybe (ai_fun fun))
    3963 
    +  | isNothing (isDataConId_maybe (ai_fun fun))
    3917 3964 
              -- isDataConId: see point (DJ4) of Note [Duplicating join points]
    3918 
    -  = -- Use Plan B of Note [Duplicating StrictArg]
    3919 
    -    --   K[ f a b <> ]   -->   join j x = K[ f a b x ]
    3920 
    -    --                         j <>
    3921 
    -    do { let rhs_ty       = contResultType cont
    3922 
    -             (m,arg_ty,_) = splitFunTy fun_ty
    3923 
    -       ; arg_bndr <- newId (fsLit "arg") m arg_ty
    3924 
    -       ; let env' = env `addNewInScopeIds` [arg_bndr]
    3925 
    -       ; (floats, join_rhs) <- rebuildCall env' (addValArgTo fun (Var arg_bndr) fun_ty) cont
    3926 
    -       ; mkDupableStrictBind env' arg_bndr (wrapFloats floats join_rhs) rhs_ty }
    3927 
    -
    3928 
    -  | otherwise
    3929 3965 
       = -- Use Plan C of Note [Duplicating StrictArg]
    3930 
    -    --   K[ f a b <> ]   -->   join j x = K[ x ]
    3931 
    -    --                         K1[ f a b <> ]
    3966 
    +    --   StrictArg (f a b <>) : ApplyTo e1 : ApplyTo e2: K
    3967 
    +    --    -->   join j x = rebuild x K
    3968 
    +    --          let x1 = e2; x2 = e2
    3969 
    +    --          StrictArg (f a b <>) : ApplyTo x1 : ApplyTo x2 : StrictArg (j <>) : Stop
    3932 3970 
         --  where K1 = j <>
    3933 
    -    do { let rhs_ty       = contResultType cont
    3934 
    -             (m,_,res_ty) = splitFunTy fun_ty
    3935 
    -       ; (floats, cont') <-
    3936 
    -           if contIsTrivial cont
    3937 
    -           then return (emptyFloats env, cont)
    3938 
    -           else do { arg_bndr <- newId (fsLit "arg") m res_ty
    3939 
    -                   ; let env' = env `addNewInScopeIds` [arg_bndr]
    3940 
    -                   ; rhs' <- simplExprC env' (Var arg_bndr) cont
    3941 
    -                   ; mkDupableStrictBind env' arg_bndr rhs' rhs_ty }
    3971 
    +    do { let _ :| dmds = expectNonEmpty $ ai_dmds fun
    3942 3972
    3943 3973 
            ; (floats_s, args') <- mapAndUnzipM (makeTrivialArg env) (ai_args fun)
    3944 3974
    3975 
    +       ; (floats, cont') <- mkDupableContWithDmds env DupAppsOnly dmds cont
    3976 
    +                 -- Use the demands from the function to add the right
    3977 
    +                 -- demand info on any bindings we make for further args
    3978 
    +
    3945 3979 
            ; return ( foldl' addLetFloats floats floats_s
    3946 3980 
                     , StrictArg { sc_fun = fun { ai_args = args' }
    3947 3981 
                                 , sc_cont = cont', sc_dup = OkToDup, sc_fun_ty = fun_ty }) }
    3948 3982
    3983 
    +
    3949 3984 
     {-
    3950 3985 
       -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable
    3951 3986 
       | isNothing (isDataConId_maybe (ai_fun fun))
    ... ... @@ -3991,47 +4026,7 @@ mkDupableContWithDmds env _
    3991 4026 
         -}
    3992 4027 
     -}
    3993 4028
    3994 
    -mkDupableContWithDmds env dmds
    3995 
    -    (ApplyToTy { sc_cont = cont, sc_arg_ty = arg_ty, sc_hole_ty = hole_ty })
    3996 
    -  = do  { (floats, cont') <- mkDupableContWithDmds env dmds cont
    3997 
    -        ; return (floats, ApplyToTy { sc_cont = cont'
    3998 
    -                                    , sc_arg_ty = arg_ty, sc_hole_ty = hole_ty }) }
    3999 
    -
    4000 
    -mkDupableContWithDmds env dmds
    4001 
    -    (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_env = se
    4002 
    -                , sc_cont = cont, sc_hole_ty = hole_ty })
    4003 
    -  =     -- e.g.         [...hole...] (...arg...)
    4004 
    -        --      ==>
    4005 
    -        --              let a = ...arg...
    4006 
    -        --              in [...hole...] a
    4007 
    -        -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable
    4008 
    -    do  { let dmd:|cont_dmds = expectNonEmpty dmds
    4009 
    -        ; (floats1, cont') <- mkDupableContWithDmds env cont_dmds cont
    4010 
    -        ; let env' = env `setInScopeFromF` floats1
    4011 
    -        ; (_, se', arg') <- simplLazyArg env' dup hole_ty Nothing se arg
    4012 
    -
    4013 
    -        -- Make the argument duplicable. Danger: if arg is small and we let-bind
    4014 
    -        -- it, then postInlineUnconditionally will just inline it again, perhaps
    4015 
    -        -- taking an extra Simplifier iteration (e.g. in test T21839c). So make
    4016 
    -        -- a `let` only if `couldBeSmallEnoughToInline` says that it is big enough
    4017 
    -        ; let uf_opts = seUnfoldingOpts env
    4018 
    -        ; (let_floats2, arg'')
    4019 
    -              <- if couldBeSmallEnoughToInline uf_opts (unfoldingUseThreshold uf_opts) arg'
    4020 
    -                 then return (emptyLetFloats, arg')
    4021 
    -                 else makeTrivial env NotTopLevel dmd (fsLit "karg") arg'
    4022 
    -
    4023 
    -        ; let all_floats = floats1 `addLetFloats` let_floats2
    4024 
    -        ; return ( all_floats
    4025 
    -                 , ApplyToVal { sc_arg = arg''
    4026 
    -                              , sc_env = se' `setInScopeFromF` all_floats
    4027 
    -                                         -- Ensure that sc_env includes the free vars of
    4028 
    -                                         -- arg'' in its in-scope set, even if makeTrivial
    4029 
    -                                         -- has turned arg'' into a fresh variable
    4030 
    -                                         -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils
    4031 
    -                              , sc_dup = OkToDup, sc_cont = cont'
    4032 
    -                              , sc_hole_ty = hole_ty }) }
    4033 
    -
    4034 
    -mkDupableContWithDmds env _
    4029 
    +mkDupableContWithDmds env _ _
    4035 4030 
         (Select { sc_bndr = case_bndr, sc_alts = alts, sc_env = se, sc_cont = cont })
    4036 4031 
       =     -- e.g.         (case [...hole...] of { pi -> ei })
    4037 4032 
             --      ===>
    ... ... @@ -4074,6 +4069,17 @@ mkDupableContWithDmds env _
    4074 4069 
                                           -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils
    4075 4070 
                               , sc_cont = mkBoringStop (contResultType cont) } ) }
    4076 4071
    4072 
    +mkDupableContWithDmds env _ _ cont
    4073 
    +  = -- Use Plan B of Note [Duplicating StrictArg]
    4074 
    +    --   K  -->   join j x = K[ x ]
    4075 
    +    --            j <>
    4076 
    +    do { let arg_ty = contHoleType cont
    4077 
    +             rhs_ty = contResultType cont
    4078 
    +       ; arg_bndr <- newId (fsLit "arg") ManyTy arg_ty
    4079 
    +       ; let env' = env `addNewInScopeIds` [arg_bndr]
    4080 
    +       ; (floats, join_rhs) <- simplOutId env' arg_bndr cont
    4081 
    +       ; mkDupableStrictBind env' arg_bndr (wrapFloats floats join_rhs) rhs_ty }
    4082 
    +
    4077 4083 
     mkDupableStrictBind :: SimplEnv -> OutId -> OutExpr -> OutType
    4078 4084 
                         -> SimplM (SimplFloats, SimplCont)
    4079 4085 
     -- mkDupableStrictBind env arg body rhs_ty

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