Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC

Commits:

6 changed files:

Changes:

  • compiler/GHC/Core/Opt/Pipeline.hs
    ... ... @@ -13,6 +13,7 @@ import GHC.Prelude
    13 13 
     import GHC.Driver.DynFlags
    14 14 
     import GHC.Driver.Plugins ( withPlugins, installCoreToDos )
    15 15 
     import GHC.Driver.Env
    16 
    +import GHC.Driver.Config (initSimpleOpts)
    16 17 
     import GHC.Driver.Config.Core.Lint ( endPass )
    17 18 
     import GHC.Driver.Config.Core.Opt.LiberateCase ( initLiberateCaseOpts )
    18 19 
     import GHC.Driver.Config.Core.Opt.Simplify ( initSimplifyOpts, initSimplMode, initGentleSimplMode )
    ... ... @@ -21,9 +22,10 @@ import GHC.Driver.Config.Core.Rules ( initRuleOpts )
    21 22 
     import GHC.Platform.Ways  ( hasWay, Way(WayProf) )
    22 23
    23 24 
     import GHC.Core
    25 
    +import GHC.Core.SimpleOpt (simpleOptPgm)
    24 26 
     import GHC.Core.Opt.CSE  ( cseProgram )
    25 27 
     import GHC.Core.Rules   ( RuleBase, ruleCheckProgram, getRules )
    26 
    -import GHC.Core.Ppr     ( pprCoreBindings )
    28 
    +import GHC.Core.Ppr     ( pprCoreBindings, pprRules )
    27 29 
     import GHC.Core.Utils   ( dumpIdInfoOfProgram )
    28 30 
     import GHC.Core.Lint    ( lintAnnots )
    29 31 
     import GHC.Core.Lint.Interactive ( interactiveInScope )
    ... ... @@ -202,10 +204,14 @@ getCoreToDo dflags hpt_rule_base extra_vars
    202 204
    203 205 
         core_todo =
    204 206 
          [
    205 
    -    -- We want to do the static argument transform before full laziness as it
    206 
    -    -- may expose extra opportunities to float things outwards. However, to fix
    207 
    -    -- up the output of the transformation we need at do at least one simplify
    208 
    -    -- after this before anything else
    207 
    +        -- We always perform a run of the simple optimizer after desugaring to
    208 
    +        -- remove really bad code
    209 
    +        CoreDesugarOpt,
    210 
    +
    211 
    +        -- We want to do the static argument transform before full laziness as it
    212 
    +        -- may expose extra opportunities to float things outwards. However, to fix
    213 
    +        -- up the output of the transformation we need at do at least one simplify
    214 
    +        -- after this before anything else
    209 215 
             runWhen static_args (CoreDoPasses [ simpl_gently, CoreDoStaticArgs ]),
    210 216
    211 217 
             -- initial simplify: mk specialiser happy: minimum effort please
    ... ... @@ -467,6 +473,7 @@ doCorePass pass guts = do
    467 473 
       let fam_envs = (p_fam_env, mg_fam_inst_env guts)
    468 474 
       let updateBinds  f = return $ guts { mg_binds = f (mg_binds guts) }
    469 475 
       let updateBindsM f = f (mg_binds guts) >>= \b' -> return $ guts { mg_binds = b' }
    476 
    +  let updateBindsAndRulesM f = f (mg_binds guts) (mg_rules guts) >>= \(b',r') -> return $ guts { mg_binds = b', mg_rules = r' }
    470 477 
       -- Important to force this now as name_ppr_ctx lives through an entire phase in
    471 478 
       -- the optimiser and if it's not forced then the entire previous `ModGuts` will
    472 479 
       -- be retained until the end of the phase. (See #24328 for more analysis)
    ... ... @@ -479,6 +486,9 @@ doCorePass pass guts = do
    479 486
    480 487
    481 488 
       case pass of
    489 
    +    CoreDesugarOpt            -> {-# SCC "DesugarOpt" #-}
    490 
    +                                 updateBindsAndRulesM (desugarOpt dflags logger (mg_module guts))
    491 
    +
    482 492 
         CoreDoSimplify opts       -> {-# SCC "Simplify" #-}
    483 493 
                                      liftIOWithCount $ simplifyPgm logger (hsc_unit_env hsc_env) name_ppr_ctx opts guts
    484 494
    ... ... @@ -537,7 +547,6 @@ doCorePass pass guts = do
    537 547 
         CoreDoPluginPass _ p      -> {-# SCC "Plugin" #-} p guts
    538 548
    539 549 
         CoreDesugar               -> pprPanic "doCorePass" (ppr pass)
    540 
    -    CoreDesugarOpt            -> pprPanic "doCorePass" (ppr pass)
    541 550 
         CoreTidy                  -> pprPanic "doCorePass" (ppr pass)
    542 551 
         CorePrep                  -> pprPanic "doCorePass" (ppr pass)
    543 552
    ... ... @@ -580,3 +589,22 @@ dmdAnal logger before_ww dflags fam_envs rules binds = do
    580 589 
         dumpIdInfoOfProgram (hasPprDebug dflags) (ppr . zapDmdEnvSig . dmdSigInfo) binds_plus_dmds
    581 590 
       -- See Note [Stamp out space leaks in demand analysis] in GHC.Core.Opt.DmdAnal
    582 591 
       seqBinds binds_plus_dmds `seq` return binds_plus_dmds
    592 
    +
    593 
    +
    594 
    +-- | Simple optimization after desugaring.
    595 
    +--
    596 
    +-- This performs some quick basic optimizations even with -O0.
    597 
    +-- See Note [The simple optimiser] for details.
    598 
    +--
    599 
    +-- We could call it directly in the desugarer but we implement it as the first
    600 
    +-- Core-to-Core pass to accomodate Core plugins that want to see Core even
    601 
    +-- before the first (simple) optimization took place. See #23337
    602 
    +desugarOpt :: DynFlags -> Logger -> Module -> CoreProgram -> [CoreRule] -> CoreM (CoreProgram,[CoreRule])
    603 
    +desugarOpt dflags logger mod binds rules = liftIO $ do
    604 
    +  let simpl_opts = initSimpleOpts dflags
    605 
    +  let !(ds_binds, ds_rules_for_imps, occ_anald_binds) = simpleOptPgm simpl_opts mod binds rules
    606 
    +
    607 
    +  putDumpFileMaybe logger Opt_D_dump_occur_anal "Occurrence analysis"
    608 
    +    FormatCore (pprCoreBindings occ_anald_binds $$ pprRules ds_rules_for_imps )
    609 
    +
    610 
    +  pure (ds_binds, ds_rules_for_imps)

  • compiler/GHC/Core/Opt/Pipeline/Types.hs
    ... ... @@ -58,8 +58,7 @@ data CoreToDo -- These are diff core-to-core passes,
    58 58 
       | CoreDoPasses [CoreToDo]      -- lists of these things
    59 59
    60 60 
       | CoreDesugar    -- Right after desugaring, no simple optimisation yet!
    61 
    -  | CoreDesugarOpt -- CoreDesugarXXX: Not strictly a core-to-core pass, but produces
    62 
    -                       --                 Core output, and hence useful to pass to endPass
    61 
    +  | CoreDesugarOpt -- Simple optimisation after desugaring
    63 62
    64 63 
       | CoreTidy
    65 64 
       | CorePrep

  • compiler/GHC/HsToCore.hs
    ... ... @@ -48,7 +48,7 @@ import GHC.Core.TyCo.Compare( eqType )
    48 48 
     import GHC.Core.TyCon       ( tyConDataCons )
    49 49 
     import GHC.Core
    50 50 
     import GHC.Core.FVs       ( exprsSomeFreeVarsList, exprFreeVars )
    51 
    -import GHC.Core.SimpleOpt ( simpleOptPgm, simpleOptExpr )
    51 
    +import GHC.Core.SimpleOpt ( simpleOptExpr )
    52 52 
     import GHC.Core.Utils
    53 53 
     import GHC.Core.Unfold.Make
    54 54 
     import GHC.Core.Coercion
    ... ... @@ -200,27 +200,18 @@ deSugar hsc_env
    200 200
    201 201 
          do {       -- Add export flags to bindings
    202 202 
               keep_alive <- readIORef keep_var
    203 
    -        ; let (rules_for_locals, rules_for_imps) = partition isLocalRule all_rules
    203 
    +        ; let (rules_for_locals, ds_rules_for_imps) = partition isLocalRule all_rules
    204 204 
                   final_prs = addExportFlagsAndRules bcknd export_set keep_alive
    205 205 
                                                      rules_for_locals (fromOL all_prs)
    206 206
    207 
    -              final_pgm = combineEvBinds ds_ev_binds final_prs
    207 
    +              ds_binds = combineEvBinds ds_ev_binds final_prs
    208 208 
             -- Notice that we put the whole lot in a big Rec, even the foreign binds
    209 209 
             -- When compiling PrelFloat, which defines data Float = F# Float#
    210 210 
             -- we want F# to be in scope in the foreign marshalling code!
    211 211 
             -- You might think it doesn't matter, but the simplifier brings all top-level
    212 212 
             -- things into the in-scope set before simplifying; so we get no unfolding for F#!
    213 213
    214 
    -        ; endPassHscEnvIO hsc_env name_ppr_ctx CoreDesugar final_pgm rules_for_imps
    215 
    -        ; let simpl_opts = initSimpleOpts dflags
    216 
    -        ; let (ds_binds, ds_rules_for_imps, occ_anald_binds)
    217 
    -                = simpleOptPgm simpl_opts mod final_pgm rules_for_imps
    218 
    -                         -- The simpleOptPgm gets rid of type
    219 
    -                         -- bindings plus any stupid dead code
    220 
    -        ; putDumpFileMaybe logger Opt_D_dump_occur_anal "Occurrence analysis"
    221 
    -            FormatCore (pprCoreBindings occ_anald_binds $$ pprRules ds_rules_for_imps )
    222 
    -
    223 
    -        ; endPassHscEnvIO hsc_env name_ppr_ctx CoreDesugarOpt ds_binds ds_rules_for_imps
    214 
    +        ; endPassHscEnvIO hsc_env name_ppr_ctx CoreDesugar ds_binds ds_rules_for_imps
    224 215
    225 216 
             ; let pluginModules = map lpModule (loadedPlugins (hsc_plugins hsc_env))
    226 217 
                   home_unit = hsc_home_unit hsc_env

  • testsuite/tests/plugins/annotation-plugin/SayAnnNames.hs
    ... ... @@ -19,13 +19,14 @@ pass :: ModGuts -> CoreM ModGuts
    19 19 
     pass g = do
    20 20 
               dflags <- getDynFlags
    21 21 
               mapM_ (printAnn dflags g) (mg_binds g) >> return g
    22 
    -  where printAnn :: DynFlags -> ModGuts -> CoreBind -> CoreM CoreBind
    23 
    -        printAnn dflags guts bndr@(NonRec b _) = do
    22 
    +  where printAnn :: DynFlags -> ModGuts -> CoreBind -> CoreM ()
    23 
    +        printAnn dflags guts (NonRec b _) = lookupAnn dflags guts b
    24 
    +        printAnn dflags guts (Rec ps) = mapM_ (lookupAnn dflags guts . fst) ps
    25 
    +
    26 
    +        lookupAnn dflags guts b = do
    24 27 
               anns <- annotationsOn guts b :: CoreM [SomeAnn]
    25 28 
               unless (null anns) $ putMsgS $
    26 29 
                 "Annotated binding found: " ++  showSDoc dflags (ppr b)
    27 
    -          return bndr
    28 
    -        printAnn _ _ bndr = return bndr
    29 30
    30 31 
     annotationsOn :: Data a => ModGuts -> CoreBndr -> CoreM [a]
    31 32 
     annotationsOn guts bndr = do

  • testsuite/tests/plugins/late-plugin/LatePlugin.hs
    ... ... @@ -43,8 +43,13 @@ editCoreBinding early modName pgm = do
    43 43 
         pure $ go pgm
    44 44 
       where
    45 45 
         go :: [CoreBind] -> [CoreBind]
    46 
    -    go (b@(NonRec v e) : bs)
    47 
    -      | occNameString (getOccName v) == "testBinding" && exprType e `eqType` intTy =
    48 
    -          NonRec v (mkUncheckedIntExpr $ bool 222222 111111 early) : bs
    49 
    -    go (b:bs) = b : go bs
    46 
    +    go (Rec ps : bs) = Rec (map (uncurry (go_bind (,))) ps) : go bs
    47 
    +    go (NonRec v e : bs) = go_bind NonRec v e : go bs
    50 48 
         go [] = []
    49 
    +
    50 
    +    go_bind c v e
    51 
    +      | occNameString (getOccName v) == "testBinding"
    52 
    +      , exprType e `eqType` intTy
    53 
    +      = c v (mkUncheckedIntExpr $ bool 222222 111111 early)
    54 
    +      | otherwise
    55 
    +      = c v e

  • testsuite/tests/plugins/simple-plugin/Simple/ReplacePlugin.hs
    ... ... @@ -51,5 +51,6 @@ fixGuts rep guts = pure $ guts { mg_binds = fmap fix_bind (mg_binds guts) }
    51 51 
           Tick t e      -> Tick t (fix_expr e)
    52 52 
           Type t        -> Type t
    53 53 
           Coercion c    -> Coercion c
    54 
    +      Let b body    -> Let (fix_bind b) (fix_expr body)
    54 55
    55 56 
         fix_alt (Alt c bs e) = Alt c bs (fix_expr e)

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