+section: compiler

+issues: #27261

+mrs: !16084

+synopsis:

+  Avoid a crash in ``mkDupableContWithDmds`` when given empty demands

+description:

+  The case of an empty list of remaining argument demands is now explicitly

+  handled by trimming the simplifier continuation, to avoid a compiler crash

+  of the form ``Non-exhaustive patterns in dmd : cont_dmds`` or ``expectNonEmpty``

+  in ``mkDupableContWithDmds``.

+section: packaging

+synopsis: Fix Hadrian rules for system-cxx-std-lib package dependency

+issues: #25303

+mrs: !16013

+description: {

+  Hadrian's handling of the ``system-cxx-std-lib`` virtual package has been

+  fixed and made more uniform.

+

+  Previously, ``text`` had an ad-hoc rule outside of ``configurePackage`` to

+  declare a dependency on ``system-cxx-std-lib``, the dependency was not

+  discovered from cabal files, and the package database was not recached after

+  the ``.conf`` file was generated.

+

+  The dependency is now read from cabal files via a new

+  ``dependsOnSystemCxxStdLib`` field in ``PackageData``, and the ``.conf`` file

+  is needed inside ``configurePackage`` alongside all other package

+  dependencies, consistent with how every other package is handled.

+}

+import qualified GHC.Data.List.Infinite as Inf

+  -- When we run out of demands, it means that the call is definitely bottom.

+  -- See (TC2) in Note [Trimming the continuation for bottoming functions]

+  = rebuild env (argInfoExpr fun rev_args) (mkBottomCont cont)

+

+Note [Trimming the continuation for bottoming functions]

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

+Suppose

+   f :: Int -> Int -> Int

+   f x = error "urk"

+

+   foo = f 3 4

+

+f's demand signature say "after one arg I return bottom".  We can drop

+the remaining arguments, thus

+

+   foo = case f 3 of {}

+

+This trimming can also be done with other continuations:

+   * case (error "hello") of { ... }

+   * f (error "Hello") where f is strict

+   etc

+

+We implement the trimming in three parts:

+

+(TC1) In `mkArgInfo`, for a bottoming function, we make a list of `RemainingArgDmds`

+  with a finite list of elements (in the example above, just one).

+

+  For comparison, note that, for non-bottoming functions, the `RemainingArgDmds`

+  always finishes with an infinite list of `topDmd`.

+

+(TC2) In `rebuildCall`, when we run out of `RemainingArgDmds` we discard the

+  remaining continuation.

+

+  After discarding the continuation, the types might not match, in which case

+  we leave behind a (case <hole> of {}) wrapper.  See the call to `mkBottomCont`.

+

+(TC3) In `mkDupableContWithDmds`, we similarly discard the continuation when

+  we run out of `RemainingArgDmds`.

+   :: SimplEnvIS -> RemainingArgDmds

+mkDupableContWithDmds env remaining_dmds cont

+  -- No more demands => function is definitely bottom

+  --                 => simply trim the continuation

+  -- c.f. the null-demands case in `rebuildCall`

+  -- See (TC3) in Note [Trimming the continuation for bottoming functions]

+  | null remaining_dmds

+  = return (emptyFloats env, mkBottomCont cont)

+

+    do { let _ :| dmds = expectNonEmpty (ai_dmds fun)   -- See Invariant of StrictArg;

+                                                        -- ai_dmds is never empty

+    do  { let dmd:|cont_dmds =

+                -- We took care to handle an empty demand list at the start,

+                -- ensuring this call to 'expectNonEmpty' does not panic (#27261).

+                expectNonEmpty dmds

+                                , ai_discs = Inf.repeat 0 }

+        contIsTrivial, contArgs, contIsRhs, mkBottomCont,

+        ArgInfo(..), ArgSpec(..), RemainingArgDmds, mkArgInfo,

+import GHC.Core.TyCo.Compare ( eqTypeIgnoringMultiplicity )

+import GHC.Core.Make( mkWildValBinder )

+import GHC.Data.List.Infinite ( Infinite(..) )

+import qualified GHC.Data.List.Infinite as Inf

+      , sc_fun  :: ArgInfo     -- Specifies f, e1..en, whether f has rules, etc

+                               --     Invariant: ai_dmds and ai_discs are never empty

+        ai_fun   :: OutId,      -- ^ The function

+        ai_args  :: [ArgSpec],  -- ^ ...applied to these args (which are in *reverse* order)

+        ai_rules :: [CoreRule], -- ^ Rules for this function

+        ai_encl  :: Bool,

+          -- ^ Flag saying whether this function or an enclosing one has rules

+          -- (recursively)

+          --

+          -- @True@ means: be keener to inline in all args

+        ai_dmds :: RemainingArgDmds,

+          -- ^ Demands on remaining value arguments (beyond 'ai_args')

+        ai_discs :: Infinite Int

+          -- ^ Discounts for remaining value arguments (beyond 'ai_args')

+          --

+          -- A non-zero value means: be keener to inline

+-- | 'RemainingArgDmds' gives the demands on any remaining value arguments.

+--

+-- It is usually infinite (with 'topDmd's in the tail), but if it is finite it

+-- guarantees that the function diverges after being applied to that number

+-- of arguments.

+type RemainingArgDmds = [Demand]

+data ArgSpec

+  -- | A value argument

+  = ValArg { as_dmd  :: Demand        -- ^ Demand placed on this argument

+           , as_arg  :: OutExpr       -- ^ Apply to this (coercion or value); c.f. 'ApplyToVal'

+           , as_hole_ty :: OutType }  -- ^ Type of the function (presumably @t1 -> t2@ for 'ValArg' or @forall a. blah@ for 'TyArg')

+  -- | A type argument

+  | TyArg { as_arg_ty  :: OutType     -- ^ Apply to this type; c.f. 'ApplyToTy'

+          , as_hole_ty :: OutType }   -- ^ Type of the function (presumably @t1 -> t2@ for 'ValArg' or @forall a. blah@ for 'TyArg')

+  | ArgInfo { ai_dmds = dmd:dmds, ai_discs = Inf _ discs } <- ai

+contStop :: SimplCont -> SimplCont

+-- ^ Get the 'Stop' at the tail of the continuation

+--

+-- Always returns a continuation of form @(Stop ...)@.

+contStop stop@(Stop {})               = stop

+contStop (CastIt { sc_cont = k })     = contStop k

+contStop (StrictBind { sc_cont = k }) = contStop k

+contStop (StrictArg { sc_cont = k })  = contStop k

+contStop (Select { sc_cont = k })     = contStop k

+contStop (ApplyToTy  { sc_cont = k }) = contStop k

+contStop (ApplyToVal { sc_cont = k }) = contStop k

+contStop (TickIt _ k)                 = contStop k

+

+-------------------

+mkBottomCont ::SimplCont -> SimplCont

+-- ^ Given a continuation `cont`, return a `cont` /of the same type/,

+-- looking like @(case \<hole\> of {})@.

+--

+-- This is used when we are going to fill in the @<hole>@ with bottom.

+-- See (TC2,3) in Note [Trimming the continuation for bottoming functions]

+--

+-- Don't bother to trim, making a @case <hole> of {}@, if we have only

+-- an essentially-trivial continuation; e.g. @(<hole> \@ty |> co)@.

+mkBottomCont cont = go cont

+  where

+    go k@(Stop {})                    = k

+    go (TickIt t k')                  = TickIt t (go k')

+    go k@(CastIt    { sc_cont = k' }) = k { sc_cont = go k' }

+    go k@(ApplyToTy { sc_cont = k' }) = k { sc_cont = go k' }

+    go k@(Select { sc_alts = [], sc_cont = Stop {} }) = k  -- Optimisation only

+    go k | Stop res_ty _ _ <- stop_cont

+         , hole_ty `eqTypeIgnoringMultiplicity` res_ty

+         = stop_cont

+         | otherwise

+         = Select { sc_alts = []

+                  , sc_bndr = mkWildValBinder OneTy hole_ty

+                  , sc_env  = Simplified OkDup

+                  , sc_cont = stop_cont }

+         where

+           hole_ty   = contHoleType k

+           stop_cont = contStop k

+

+    vanilla_discounts, arg_discounts :: Infinite Int

+    vanilla_discounts = Inf.repeat 0

+                              -> discounts Inf.++ vanilla_discounts

+    vanilla_dmds :: RemainingArgDmds

+    arg_dmds :: RemainingArgDmds

+               | not (demands `lengthExceeds` n_val_args)

+               -> remaining_dmds     -- Enough args, use the strictness given.

+                where

+                  remaining_dmds :: RemainingArgDmds

+                  -- isDeadEndDiv: if remaining_dmds is finite, result is bottom

+                  -- See (TC1) in Note [Trimming the continuation for bottoming functions]

+                  remaining_dmds | isDeadEndDiv result_info = demands

+                                 | otherwise                = demands ++ vanilla_dmds

+

+    add_type_strictness :: Type -> RemainingArgDmds -> RemainingArgDmds

+    -- If the function arg /types/ are strict, record that in the RemainingArgDmds

+  | encl_rules                    = RuleArgCtxt

+  | Inf disc _ <- discs, disc > 0 = DiscArgCtxt  -- Be keener here

+  | otherwise                     = BoringCtxt   -- Nothing interesting

+  | encl_rules                    = RuleArgCtxt

+  | Inf disc _ <- discs, disc > 0 = DiscArgCtxt  -- Be keener here

+  | otherwise                     = RhsCtxt NonRecursive

+        cxxStdLib = elem "system-cxx-std-lib" deps

+                         depPkgs cxxStdLib gpd

+    pd <- readPackageData package

+    let depPkgs = packageDependencies pd

+        needSystemCxxStdLib = dependsOnSystemCxxStdLib pd

+    -- system-cxx-std-lib is magic.. it doesn't have a cabal file or source code, so we have

+    -- to treat it specially as `pkgConfFile` uses `readPackageData` to compute the version.

+    systemCxxStdLib <- sequence [ systemCxxStdLibConfPath (PackageDbLoc stage iplace) | needSystemCxxStdLib ]

+    need $ extraPreConfigureDeps

+            ++ deps

+            ++ systemCxxStdLib

+    , dependsOnSystemCxxStdLib  :: Bool

+            { -- Bump shakeVersion whenever a type stored in the Shake oracle

+              -- changes its Binary representation (e.g. fields added/removed

+              -- from PackageData or other oracle value types). This forces

+              -- Shake to wipe the stale database instead of crashing on

+              -- deserialisation.

+              shakeVersion  = "2"

+            , shakeChange   = ChangeModtimeAndDigest

+    -- Special rule for registering system-cxx-std-lib

+    root -/- relativePackageDbPath (PackageDbLoc stage iplace) -/- systemCxxStdLibConf %> \file -> do

+        copyFile ("mk" -/- "system-cxx-std-lib-1.0.conf") file

+        buildWithResources rs $

+            target (Context stage compiler vanilla iplace) (GhcPkg Recache stage) [] []

+

+module GHC.Data.ShortByteString

+  ( newCStringFromSBS

+  ) where

+

+import Prelude

+

+import qualified Data.ByteString.Short as SBS

+import Foreign

+import Foreign.C

+

+newCStringFromSBS :: SBS.ShortByteString -> IO CString

+newCStringFromSBS sbs =

+  SBS.useAsCStringLen sbs $ \(src, len) -> do

+    dst <- mallocBytes (len + 1)

+    copyBytes dst src len

+    pokeByteOff dst len (0 :: Word8)

+    pure dst

+            GHC.Data.ShortByteString

+import GHC.Data.ShortByteString

+  -- we need to find the reference to the ticks array.

+  lookupSymbol tickboxes >>= \ case

+    Nothing -> do

+      -- the symbol is not found, this is a bug!

+      throwIO $ ErrorCall $ "hpcAddModule: failed to find symbol " <> utf8DecodeShortByteString tickboxes

+    Just tickBoxRef -> do

+      -- hs_hpc_module stores the module name pointer in the RTS hash table

+      -- until exitHpc, so pass a malloced C string.

+      modlNameLiteral <- newCStringFromSBS modlName

+      -- Calling 'hs_hpc_module' multiple times is safe, it will add the module only once.

+      hpc_register_module modlNameLiteral (fromIntegral ticks) (fromIntegral hash) (castPtr tickBoxRef)

+      -- calling 'hpc_startup' multiple times is safe, it will only be initialised once.

+      hpc_startup

+#if defined(PROFILING)

+import GHC.Data.ShortByteString

+#endif

+      collect_compiler_runtime(2) # 1% tolerance was too small (#27289)

+{-# OPTIONS_GHC -fno-full-laziness #-}

+

+module T27261 (foo) where

+

+import T27261_aux (myError)

+

+foo :: [String] -> (() -> Int) -> Int

+foo cs =

+  \ k -> ( case bar of

+             Just str -> let cs2 = case cs of { [] -> cs; _ -> "stack entry" : cs }

+                         in myError cs2 str

+             Nothing -> \ c -> c () )

+         ( \ _ -> k () )

+

+bar :: Maybe String

+bar = Nothing

+{-# NOINLINE bar #-}

+{-# LANGUAGE BangPatterns #-}

+

+module T27261_aux (myError) where

+

+myError :: [String] -> String -> a

+myError !_ _ = undefined

+{-# NOINLINE myError #-}

+test('T27261', [extra_files(['T27261_aux.hs'])], multimod_compile, ['T27261', '-v0 -O'])