+section: compiler

+issues: #27831

+mrs: !16719

+synopsis:

+  Fix a segfault that could occur when a bottoming function was stored in a strict field.

+description:

+  This was happening when a function that always diverges (e.g. ``\_ -> error "..."``) was stored in a strict field, and the constructor was pattern matched on

+  in "nearby" code where the structure of the constructor application was still visible to GHC.

+section: bytecode

+issues: #27842

+mrs: !16719

+synopsis:

+  Fix a segfault caused by reusing interface files generated with

+  ``-fbyte-code-and-object-code`` for interpreter sessions using ``-fprefer-byte-code``.

+   The bytecode generator gives fewer guarantees about what it tags.

+   So we simply assume it fails to tag binders, even in the cases where it does.

+

+   This is handled in GHC.Stg.EnforceEpt.Types.argTagInfo

+

+ Eventually we will want to update the Analysis and bco code gen to uphold and

+ take advantage of tag inference at least to some degree. But for now it's

+ not a perf benefit for interpreted code, and essentially only run to uphold

+ the "strict field invariant"/EPT Invariant described in EPT enforcement.

+    let rewritten_binds = {-# SCC "StgEptRewrite" #-} rewriteTopBinds for_bytecode this_mod us_t stg_binds_w_tags :: [TgStgTopBinding]

+         | not (isJoinId fun) -- zero arity join ids behave like functions NOT thunks.

+         , fun_arity == 0 -- Unknown arity => Thunk or unknown call

+         , not (te_bytecode env) -- #27842

+If we have a function with two branches with one branch

+The true branch obviously returns tagged components. The other branch is bottom.

+We want to treat the components in the *result* returned by foo as tagged.

+Because at a call site like:

+

+    case foo e of

+        (# x, y #) ->

+            case x of

+                ...

+

+Either `foo` will have evaluated undefined or blown up. Or we will bind x and y

+to tagged pointers. A fact we take advantage of to optimize `case x of`.

+

+The rule is then simple. A combination of the alternatives of the same case has

+tagged components if all non-bottom branches have tagged components.

+

+To represent the bottoming alternatives we use TagBottoming. Which says all it's

+components are tagged. Now the same is true if we have:

+

+foo :: Bool -> (# Bool, Bool #)

+foo x = case x of

+    True -> (# True,True #)

+    False -> willCrash x

+

+Where we want to check:

+* Is `willCrash x` bottom?

+* If it is not are the returned components tagged?

+For the first question we have to be careful about the notion of bottom we use.

+I've got this wrong in the past, because a underapplied bottoming function will

+return a *function* as result. Rather than being bottom.

+If the function *is* bottom then we treat it the same we do undefined above. And

+use TagBottoming as the tagInfo of the expression. Hence the title of the Note.

+{-# LANGUAGE UnboxedTuples              #-}

+import GHC.Types.Name ( nameIsLocalOrFrom )

+import GHC.Core.Type       ( definitelyLiftedType )

+import GHC.Exts (oneShot)

+

+data RmContext = RmContext { rm_mod :: !Module, rm_interpreter :: !Bool }

+

+data RmState = RmState { rm_us :: !UniqSupply, rm_fvs :: IdSet, rm_sig_env :: !(UniqFM Id TagSig)}

+newtype RM a = RM { unRM :: RmContext -> RmState -> (# RmState, a #) }

+

+instance Functor RM where

+    fmap f (RM x) = RM $ oneShot $ \env -> oneShot $ \state ->

+        case x env state of

+            (# !s1, !x' #) ->

+                let !r = f x'

+                in (# s1, r #)

+

+instance Applicative RM where

+    (RM f) <*> (RM x) = RM $ oneShot $ \env -> oneShot $ \state ->

+        case f env state of

+            (# !s1,!f' #) -> case x env s1 of

+                (# !s2, !x' #) ->

+                    let !r = f' x'

+                    in (# s2, r #)

+    pure !x = RM $ \_ !s -> (# s, x #)

+

+-- See Note [The one-shot state monad trick] in GHC.Utils.Monad

+instance Monad RM where

+    RM x >>= f = RM $ oneShot $ \env -> oneShot $ \state ->

+        case x env state of

+            (# !s1, !x' #) -> case (f x') of RM r -> r env s1

+

+-- | runRM this_mod for_bytecode us

+runRM :: Module -> Bool -> UniqSupply -> RM a -> a

+runRM mod for_bytecode us act  =

+    case (unRM act)

+            (RmContext { rm_mod = mod, rm_interpreter = for_bytecode })

+            (RmState { rm_us = us, rm_fvs = emptyVarSet, rm_sig_env = emptyUFM })

+        of

+    (# _, r #) -> r

+    getUniqueSupplyM = RM $ \_ s ->

+        case splitUniqSupply (rm_us s) of

+            (us1, us2) -> (# s { rm_us = us2 }, us1 #)

+getMap = RM $ \_ s -> (# s, rm_sig_env s #)

+setMap !m = RM $ \_ s -> (# s { rm_sig_env = m }, () #)

+getFVs = RM $ \_ s -> (# s, rm_fvs s #)

+setFVs !fvs = RM $ \_ s -> (# s { rm_fvs = fvs }, () #)

+

+getMod :: RM Module

+getMod = RM $ \env s -> (# s, rm_mod env #)

+

+-- | When generating bytecode certain bindings might be untagged. So we have to

+-- have a way to check for that.

+getForBytecode :: RM Bool

+getForBytecode = RM $ \env s -> (# s, rm_interpreter env #)

+isTagged v = do

+    for_bytecode <- getForBytecode

+    s <- getMap

+    let get_env_sig = lookupUFM s

+    massertPpr

+        -- Assert the env is complete for local lifted binders, which means either

+        -- - The binder is present in the env

+        -- - The binder is not a local lifted binder *or* comes from a ghci context

+        (isJust (get_env_sig v)

+            -- See Note [Tag inference for interactive contexts]

+            || isInteractiveModule this_mod

+            || not (nameIsLocalOrFrom this_mod (idName v))

+            || not (definitelyLiftedType (idType v)))

+               (text "unknown Id:" <> ppr this_mod <+> ppr v)

+    -- TODO: We could refactor the whole pass such that we also set id_tagSig

+    -- for every imported id. But this likely comes with a heavy allocation

+    -- overhead so for now we just ensure to use the same logic across analysis

+    -- and rewriter.

+    pure $! isTaggedInfo $ argTagInfo for_bytecode (get_env_sig v) (StgVarArg v)

+rewriteTopBinds :: Bool -- ^ Generating bytecode?

+                -> Module -> UniqSupply -> [GenStgTopBinding 'InferTaggedBinders] -> [TgStgTopBinding]

+rewriteTopBinds for_bytecode mod us binds =

+    runRM mod for_bytecode us (mapM rewriteTop binds)

+-- specially by the rewriter. See Note [Constructor TagSigs]

+import GHC.Core.Type (isUnliftedType, definitelyUnliftedType)

+import GHC.StgToCmm.Closure (importedIdLFInfo)

+-- | Look up a value-level tag.

+--

+-- If the tag info is completely determined by Id info we use that tag.

+-- If the tag info is dependent on the analysis/call site use the passed TagSig.

+-- If the passed TagSig is Nothing we fall back to safe tag info based on id properties.

+argTagInfo :: Bool -> (Maybe TagSig) -> StgArg -> TagInfo

+{-# INLINE argTagInfo #-} -- Specialize for the call site.

+argTagInfo _for_bytecode _env_sig (StgLitArg{}) = TagEPT

+argTagInfo for_bytecode env_sig (StgVarArg var)

+  -- NB: v might be the Id of a representation-polymorphic join point,

+  -- so we shouldn't use isUnliftedType here. See T22212.

+  | definitelyUnliftedType (idType var)

+  | Just sig <- env_sig

+-- Always save defaults.

+  | lf_info <- importedIdLFInfo var -- will make up LFInfo if not present.

+  = if for_bytecode

+    then TagDunno -- See Note [EPT enforcement for interpreted code] in GHC.Stg.EnforceEpt

+    else

+        case lf_info of

+-- | Get tag info using the environment.

+lookupInfo :: TagEnv p -> StgArg -> TagInfo

+lookupInfo env arg@(StgVarArg var) =

+    let env_sig = (lookupVarEnv (te_env env) var)

+    in  argTagInfo (te_bytecode env) env_sig arg

+lookupInfo _env (StgLitArg{}) = TagEPT

+{-# LANGUAGE UnboxedTuples #-}

+{-# OPTIONS_GHC -fno-worker-wrapper -fno-cpr-anal #-}

+-- Regression test for #27842.

+--

+-- The basic rundown is this:

+-- We produce one interface file, however we store information dependent on the

+-- code generation method in the interface file.

+--

+-- We happen to pick the native code information to store in the interface file.

+--

+-- When we compile a module M this way, and then generate byte code for code

+-- depending on M based on M.hi we will assume certain exported definitions are EPT

+-- tagged, despite the interpreter doing no such thing.

+--

+-- This then led to crashes in the interpreter.

+--

+-- We test three kinds of imported definitions:

+-- * mk uses fun, a function whose TagSig says its result is tagged.

+-- * bar uses just_con, a value whose LFInfo says it is a constructor.

+-- * baz uses gt_con, the same for a nullary constructor.

+module Main where

+

+import T27842A (fun, just_con, gt_con)

+import T27842N (S(..), use_S, M(..), use_M, N(..), use_N)

+

+mk :: Int -> S

+mk x = case fun x of (# xs, _ #) -> S xs

+{-# NOINLINE mk #-}

+

+bar :: M

+bar = M just_con

+{-# NOINLINE bar #-}

+

+baz :: N

+baz = N gt_con

+{-# NOINLINE baz #-}

+

+main :: IO ()

+main = do

+  print (use_S (mk 42))

+  print (use_M bar)

+  print (use_N baz)

+42

+42

+3

+{-# LANGUAGE UnboxedTuples #-}

+{-# OPTIONS_GHC -fno-worker-wrapper -fno-cpr-anal #-}

+module T27842A (fun, just_con, gt_con) where

+

+-- The native EPT run gives fun the TagSig TagFun[TagTuple[TagEPT, TagDunno]]:

+fun :: Int -> (# [Int], Int #)

+fun x = let xs = x : xs in (# xs, x #)

+{-# NOINLINE fun #-}

+

+-- In native code a static constructor, in bytecode an unevaluated closure.

+just_con :: Maybe Int

+just_con = Just 42

+{-# NOINLINE just_con #-}

+

+-- The same for a nullary constructor. Without its pointer tag, the object code

+-- in T27842N would take the LT alternative, so GT shows the difference.

+gt_con :: Ordering

+gt_con = GT

+{-# NOINLINE gt_con #-}

+{-# OPTIONS_GHC -fno-byte-code-and-object-code #-}

+-- We compile this module as native code, depending on A's interface file.

+-- A itself is loaded into GHCi, despite it's interface file being generated based

+-- on native code generation.

+module T27842N (S(..), use_S, M(..), use_M, N(..), use_N) where

+

+data S = S ![Int]

+

+-- We take apart the strict constructor value and branch on the value in its field.

+-- If the field content is not EPT this causes undefined behaviour.

+

+use_S :: S -> Int

+use_S (S xs) = case xs of { (y:_) -> y; [] -> -1 }

+{-# NOINLINE use_S #-}

+

+data M = M !(Maybe Int)

+

+use_M :: M -> Int

+use_M (M m) = case m of { Just x -> x; Nothing -> -1 }

+{-# NOINLINE use_M #-}

+

+data N = N !Ordering

+

+use_N :: N -> Int

+use_N (N o) = case o of { LT -> 1; EQ -> 2; GT -> 3 }

+{-# NOINLINE use_N #-}

+

+# Bytecode must not trust tag information from imported interfaces, which

+# comes from native code (#27842): neither the TagSig of an imported function

+# nor the LFInfo of an imported value (with and without constructor fields).

+test('T27842', [extra_files(['T27842A.hs', 'T27842N.hs']), req_interp],

+     run_command,

+     ['{compiler} -e main -O -fno-unoptimized-core-for-interpreter '

+      '-fobject-code -fbyte-code-and-object-code -fwrite-byte-code -fprefer-byte-code '

+      'T27842.hs'])

+# Both f and the join point j should have a signature TagTuple[TagEPT, TagEPT]

+test('inferTags005',

+     grep_errmsg(r'(TagTuple\[TagEPT, TagEPT\])', [1]),

+     compile,

+     ['-O -fno-worker-wrapper -fno-cpr-anal -ddump-stg-tags '

+      '-dno-typeable-binds -dsuppress-uniques'])

+# The function needs to have a signature TagTuple[TagEPT, TagEPT]

+test('inferTags006',

+     grep_errmsg(r'(TagTuple\[TagEPT, TagEPT\])', [1]),

+     compile,

+     ['-O -fno-worker-wrapper -fno-cpr-anal -fno-full-laziness -ddump-stg-tags '

+      '-dno-typeable-binds -dsuppress-uniques'])

+{-# LANGUAGE UnboxedTuples #-}

+module EnforceEpt005 where

+

+-- If we have

+-- f x y =

+--   join j =

+--       <rhs> -- <TagTuple[TagEPT, TagEPT]]>

+--   in case x of

+--       1 -> j

+--       2 -> j

+--       _ ->

+--         <something> -- <TagTuple[TagEPT, TagEPT]]>

+

+-- Consider the case where rhs and something both represent a tag value of <TagTuple[TagEPT, TagEPT]]>

+-- In this case we want `f` to also give rise to TagFun [TagTuple[TagEPT, TagEPT]]]

+

+-- To achieve this we have to recognize j as a zero-arity function equivalent

+-- which is what this test checks.

+

+-- The payoff is in `g` `r` is then known to be tagged, so `S r` needs no eval.

+-- Only an unboxed tuple result exposes this.

+

+-- We disable worker/wrapper and CPR so `f` matches more closely the tests source.

+

+data T = A Int Int Int Int Int Int | B

+

+f :: Int -> Int -> (# T, T #)

+f x y = case x of

+  0 -> j

+  1 -> j

+  _ -> (# B, B #)

+  where

+    j = (# A (y+1) (y*2) (y-3) (y*y) (y+x) (y*x), B #)

+{-# NOINLINE f #-}

+

+data S = S !T

+

+g :: Int -> Int -> S

+g x y = case f x y of (# r, _ #) -> S r

+TagTuple[TagEPT, TagEPT]

+TagTuple[TagEPT, TagEPT]

+{-# LANGUAGE UnboxedTuples #-}

+module EnforceEpt006 where

+

+-- If we have

+-- f x y =

+--   join j =

+--       <rhs> -- TagBottoming

+--   in case x of

+--       1 -> j

+--       2 -> j

+--       _ ->

+--         <something> -- <TagTuple[TagEPT, TagEPT]]>

+

+-- Similar to inferTage005 we want to give `f` the signature: TagFun <TagTuple[TagEPT, TagEPT]]>

+-- This requires us to give `j` a `TagFun[TagBottoming]` signature, which is safe because

+-- either its execution will diverge, or the resulting tuple *will* have two

+-- tagged values.

+

+data T = A Int Int Int Int Int Int | B

+

+f :: Int -> Int -> (# T, T #)

+-- This case-of-case is just here to be optimized into a nullary join point.

+f x y = case (case x of { 0 -> False; 1 -> False; _ -> True }) of

+  False -> error ("f: bad input " ++ show x ++ " " ++ show y ++ " " ++ show (x*y))

+  True  -> (# A (y+1) (y*2) (y-3) (y*y) (y+x) (y*x), B #)

+{-# NOINLINE f #-}

+

+data S = S !T

+

+g :: Int -> Int -> S

+g x y = case f x y of (# r, _ #) -> S r

+TagTuple[TagEPT, TagEPT]

+-- We suppress arity and LfInfo with the option.

+{-# OPTIONS_GHC -fomit-interface-pragmas #-}

+module InferTags007_A (fun, caf, bot, con) where

+

+fun :: Int -> Int

+fun x = x + 1

+{-# NOINLINE fun #-}

+

+-- A CAF/thunk

+caf :: [Int]

+caf = map (* 2) [1 .. 10]

+{-# NOINLINE caf #-}

+

+bot :: Int -> Int

+bot _ = error "bot called"

+{-# NOINLINE bot #-}

+

+con :: Maybe Int

+con = Just 42

+{-# NOINLINE con #-}

+-- Regression test for #27831: a bottoming function stored in a strict

+-- constructor field.

+--

+-- Different parts of the tag inference machinery didn't agree on weither or not

+-- a bottoming function should be treated as a EPT value, leading to a segfault.

+module Main (main) where

+

+import Control.Exception

+import GHC.Exts.Heap (GenClosure(..), getClosureData)

+import System.Exit

+

+data T = MkT Int !(Int -> Int)

+

+t :: T

+t = MkT 1 (\_ -> error "T27831")

+{-# NOINLINE t #-}

+

+f :: () -> T

+f _ = t

+{-# OPAQUE f #-}

+

+main :: IO ()

+main = do

+    c <- getClosureData t

+    case c of

+        ThunkClosure{} -> putStrLn "FAIL: ThunkClosure" >> exitFailure

+        APClosure{}    -> putStrLn "FAIL: APClosure" >> exitFailure

+        _              -> putStrLn "OK: not a thunk"

+

+    case f () of MkT n _ -> print n

+

+    r <- try (evaluate (case t of MkT _ g -> g 1))

+    case r of

+        Left (ErrorCall msg) -> putStrLn ("OK: " ++ msg)

+        Right v              -> putStrLn ("FAIL: got " ++ show v) >> exitFailure

+OK: not a thunk

+1

+OK: T27831

+{-# LANGUAGE StrictData #-}

+-- Regression test from #27857: We store a function that loops indefinitely

+-- in a strict field.

+module Main (main) where

+import Control.Monad

+

+data Body

+    = BNone

+    | BStream ((Int -> IO ()) -> IO () -> IO ())

+    | BIface (Int -> IO ())

+    | BBuilder String

+    | BFile Int

+

+data Obj = Obj [String] Body Int

+

+newtype Resp = Resp Obj

+

+stream :: Int -> [String] -> ((Int -> IO ()) -> IO () -> IO ()) -> Resp

+stream st hdr b = Resp $ Obj (show st : hdr) (BStream b) 0

+

+noBody :: Int -> [String] -> Resp

+noBody st hdr = Resp $ Obj (show st : hdr) BNone 0

+

+infinite :: Resp

+infinite = stream 200 ["text/plain"] body

+  where

+    body :: (Int -> IO ()) -> IO () -> IO ()

+    body write flush = do

+        let go n = write n *> flush *> go (succ n)

+        go (0 :: Int)

+

+other :: Resp

+other = noBody 404 []

+

+name :: Body -> String

+name b = case b of

+    BNone -> "None"

+    BStream _ -> "Stream"

+    BIface _ -> "Iface"

+    BBuilder _ -> "Builder"

+    BFile _ -> "File"

+

+main :: IO ()

+main = forM_ [("infinite", infinite), ("other", other)] $ \(n, Resp (Obj _ b _)) ->

+    putStrLn $ n ++ "=" ++ name b

+infinite=Stream

+other=None

+# Only run optimised code, native and interpreted:

+# We now generate bytecode from STG so we should test native and bytecode.

+  opts.only_ways = ['optasm', 'ghci-opt']

+# Breakpoint ticks would break CSE which this tests.

+test('T9291', [omit_ways(['ghci']), extra_hc_opts('-fno-break-points')], compile_and_run, [''])

+

+# Depends on tag inference being similarly effective for bytecode which it is not yet.

+test('T23783', omit_ghci, multimod_compile_and_run, ['T23783', '-O -v0'])

+

+# Requires UNPACK which needs -O

+test('unpack_enum', omit_ways(['ghci']), compile_and_run, [''])

+

+# Tests that tag inference optimizes well, which is not the case for bytecode or

+# when we insert profiling ticks.

+test('T27005a', omit_ways(ghci_ways + prof_ways), compile_and_run, [''])

+test('T27831', omit_ways(ghci_ways + prof_ways), compile_and_run, [''])

+test('inferTags007', [extra_files(['InferTags007_A.hs'])], multimod_compile_and_run, ['inferTags007', '-O -v0'])

+test('T27857', normal, compile_and_run, [''])

+{-# LANGUAGE MagicHash #-}

+-- This test sanity checks the tag info we generate for imported binders which

+-- have no real info in the .hi file.

+--

+-- This is important to avoid running into cases where we optimistically

+-- generated better information based on things like type than the

+-- compiled code actually provided. For example GHCi doesn't ensure tagging

+-- of constructors.

+module Main (main) where

+

+import Control.Exception

+import Control.Monad