+section: ghc-lib

+synopsis: Add ``oa_can_drop`` option to the occurrence analyser which selects

+          bindings to preserve.

+

+issues: #27240

+mrs: !16253

+

+description: {

+  This is only relevant to clients of the GHC API.

+

+  The ``oa_can_drop`` option of the occurrence analyser indicates whether a

+  binding is ok to drop. The option is also exposed in the simple optimiser as

+  ``so_can_drop``.

+

+  In addition, the function ``occurAnalysePgm`` earned a record parameter of

+  type ``OccurAnalOpts`` which aggregates former parameters of the function.

+  The record type ``OccEnv`` in turn, replaces its fields ``occ_unf_act`` and

+  ``occ_rule_act`` with a field ``occ_opts`` of type ``OccurAnalOpts``.

+}

+    OccurAnalOpts(..),

+-- | Options for occurrence analysis of a program

+data OccurAnalOpts = OccurAnalOpts

+  { oa_active_unf     :: Id -> Bool              -- ^ Active unfoldings

+  , oa_active_rule    :: ActivationGhc -> Bool   -- ^ Active rules

+  , oa_can_drop       :: Id -> Bool

+      -- ^ Can we drop this Id if it is dead?

+      -- See Note [Controlling elimination of dead bindings in occurrence analysis].

+  }

+

+                -> OccurAnalOpts

+                -> [CoreRule]     -- Local rules for imported Ids

+                -> CoreProgram

+                -> CoreProgram

+occurAnalysePgm this_mod opts imp_rules binds

+    init_env = initOccEnv { occ_opts = opts }

+

+Note [Controlling elimination of dead bindings in occurrence analysis]

+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

+Sometimes, plugins might want to retain dead bindings.

+

+For instance, Liquid Haskell might be the sole consumer of a binding that is

+providing a proof. Or it might provide a lemma that is needed to check other

+parts of the program. Or it might provide a value that is only referred from a

+refinement type, but not from the Haskell code itself. See #27240 for more

+details.

+

+For this reason, the occurrence analyser can be configured to retain

+some bindings even if they are dead. This is done by setting the `oa_can_drop`

+field of `OccAnalOpts` to a function that returns `False` for the bindings that

+should be retained. All calls to the occurrence analyser from within GHC itself

+use `const True` for this predicate; only calls from plugins might return

+`False` in some cases.

+

+Alternatively, the plugin could avoid running the occurrence analyser, but that

+would also disable other effects, such as the split of the program in strongly

+connected components.

+    if isDeadOcc occ && oa_can_drop (occ_opts env) bndr  -- Drop dead code; see Note [Dead code]

+  = if isDeadOcc occ && oa_can_drop (occ_opts env) bndr  -- Drop dead code; see Note [Dead code]

+occAnalRec !env lvl

+  | isDeadOcc occ && oa_can_drop (occ_opts env) bndr  -- Check for dead code: see Note [Dead code]

+*active* rules. That's the reason for the oa_active_rule field

+of occ_opts in OccEnv.

+    is_active     = oa_active_rule (occ_opts env) :: ActivationGhc -> Bool

+  | not (oa_active_unf (occ_opts env) old_bndr) -- A binder whose inlining is inactive (e.g. has

+  = (0, 0, True)                                -- a NOINLINE pragma) makes a great loop breaker

+           , occ_opts       :: !OccurAnalOpts

+           , occ_nested_lets = emptyVarSet

+             -- To be conservative, we say that all

+             -- inlines and rules are active

+           , occ_opts = OccurAnalOpts

+              { oa_active_rule  = \_ -> True

+              , oa_active_unf  = \_ -> True

+              , oa_can_drop = \_ -> True

+              }

+           }

+import GHC.Core.Opt.OccurAnal ( OccurAnalOpts(..), occurAnalysePgm, occurAnalyseExpr )

+                     occurAnalysePgm

+                       this_mod

+                       OccurAnalOpts

+                         { oa_active_unf = active_unf

+                         , oa_active_rule = active_rule

+                         , oa_can_drop = const True

+                         }

+                       local_rules

+                       binds

+import GHC.Core.Opt.OccurAnal( OccurAnalOpts(..), occurAnalyseExpr, occurAnalysePgm, zapLambdaBndrs )

+   , so_can_drop :: !(Var -> Bool)  -- ^ True <=> can drop the given binding if it is dead

+                                    -- See 'oa_can_drop' in 'OccurAnalOpts'.

+   , so_can_drop = const True

+    occ_anald_binds  = occurAnalysePgm

+                         this_mod

+                         OccurAnalOpts

+                           { oa_active_unf = \_ -> True  {- All unfoldings active -}

+                           , oa_active_rule = \_ -> False {- No rules active -}

+                           , oa_can_drop = so_can_drop opts

+                           }

+                         rules

+                         binds

+   , so_can_drop = const True

+

+-- This test checks that bindings are preserved when configuring the occurrence

+-- analyzer and the simple optimizer to not drop dead bindings with names

+-- selected by a predicate.

+--

+-- This feature is important for the LiquidHaskell plugin, which relies on the

+-- simple optimizer to make core programs easier to read, but needs to preserve

+-- bindings that are relevant for verification.

+--

+-- See https://gitlab.haskell.org/ghc/ghc/-/issues/27240 for the full discussion.

+--

+

+import           Control.Monad

+import           Data.List (find)

+import           Data.Time (getCurrentTime)

+import GHC

+import GHC.Core

+import GHC.Core.SimpleOpt

+import GHC.Data.StringBuffer

+import GHC.Driver.Config

+import GHC.Driver.DynFlags

+import GHC.Driver.Env.Types

+import GHC.Types.Name

+import GHC.Unit.Module.ModGuts

+import GHC.Unit.Types

+import GHC.Utils.Error

+import GHC.Utils.Outputable

+

+import System.Environment (getArgs)

+

+

+main :: IO ()

+main =

+  testLocalBindingsDesugaring

+

+testLocalBindingsDesugaring :: IO ()

+testLocalBindingsDesugaring = do

+    let inputSource = unlines

+          [ "module LocalDeadBindingsDesugaring where"

+          , "f :: ()"

+          , "f = ()"

+          , "  where"

+          , "    w = ()"

+          , "    z = ()"

+          ]

+

+        isExpectedDesugaring p = case findExpr "f" p of

+          Just (Let (NonRec b _) _)

+            -> isIdNamed "z" b

+          _ -> False

+

+        isIdNamed name v = occNameString (occName v) == name

+

+    coreProgram <-

+       compileToCore

+         (not . isIdNamed "z")

+         "LocalDeadBindingsDesugaring"

+         inputSource

+    unless (isExpectedDesugaring coreProgram) $

+      fail $ unlines $

+        "Unexpected desugaring: No local binding for `z` found in the Core program."

+        : map showPprQualified coreProgram

+

+-- | Find the Core expression bound to the given name.

+findExpr :: String -> CoreProgram -> Maybe CoreExpr

+findExpr _ [] =

+  Nothing

+findExpr name (p:ps) = case p of

+  NonRec b e

+    | occNameString (occName b) == name

+    -> Just e

+  Rec binds

+    | Just (_, e) <- find (\(b, _e) -> occNameString (occName b) == name) binds

+    -> Just e

+  _ -> findExpr name ps

+

+showPprQualified :: Outputable a => a -> String

+showPprQualified = showSDocQualified . ppr

+

+showSDocQualified :: SDoc -> String

+showSDocQualified = renderWithContext ctx

+  where

+    ctx = defaultSDocContext { sdocStyle = cmdlineParserStyle }

+

+

+

+compileToCore :: (Id -> Bool) -> String -> String -> IO [CoreBind]

+compileToCore canDrop modName inputSource = do

+    [libdir] <- getArgs

+    now <- getCurrentTime

+    runGhc (Just libdir) $ do

+      df1 <- getSessionDynFlags

+      GHC.setSessionDynFlags $ df1 { GHC.backend = GHC.bytecodeBackend }

+      let target = Target {

+                   targetId           = TargetFile (modName ++ ".hs") Nothing

+                 , targetUnitId       = homeUnitId_ df1

+                 , targetAllowObjCode = False

+                 , targetContents     = Just (stringToStringBuffer inputSource, now)

+                 }

+      setTargets [target]

+      void $ GHC.depanal [] False

+

+      dsMod <- getModSummary

+                 (mkModule mainUnit (mkModuleName modName))

+             >>= parseModule

+             >>= typecheckModule NoTcMPlugins

+             >>= desugarModule

+      hsc_env <- getSession

+      return $ mg_binds $ simpleOptimize canDrop hsc_env $ dm_core_module dsMod

+

+-- Run the simple optimizer

+simpleOptimize :: (Id -> Bool) -> GHC.HscEnv -> ModGuts -> ModGuts

+simpleOptimize canDrop hsc_env guts@(ModGuts

+                               { mg_module  = mgmod

+                               , mg_binds   = binds

+                               , mg_rules   = rules

+                               }) =

+    let dflags = hsc_dflags hsc_env

+        simpl_opts = (initSimpleOpts dflags)

+          { so_inline = canDrop

+          , so_can_drop = canDrop

+          }

+        (binds2, rules2, _occ_anald_binds) =

+          simpleOptPgm simpl_opts mgmod binds rules

+      in guts

+          { mg_binds = binds2

+          , mg_rules = rules2

+          }

+test('T27240', [extra_run_opts(f'"{config.libdir}"')], compile_and_run, ['-package ghc'])