+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.

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

+         , not (te_bytecode env) -- #27842

+NB: We now distinguish functions from values. Allowing us to treat bottom functions

+as tagged, while still doing the right thing for bottom values in code like:

+import GHC.Types.Name ( nameIsLocalOrFrom )

+import GHC.Core.Type       ( definitelyLiftedType )

+newtype RM a = RM { unRM :: (State (UniqFM Id TagSig, UniqSupply, Module, IdSet, Bool) a) }

+        (m, us, mod,lcls,for_bytecode) <- get

+        (put) (m,us2,mod,lcls,for_bytecode)

+getMap = RM $ ((\(fst,_,_,_,_) -> fst) <$> get)

+    (_,us,mod,lcls,for_bytecode) <- get

+    put (m, us,mod,lcls,for_bytecode)

+getFVs = RM $ ((\(_,_,_,lcls,_) -> lcls) <$> get)

+    (tag_map,us,mod,_lcls,for_bytecode) <- get

+    put (tag_map, us,mod,fvs,for_bytecode)

+

+getMod :: RM Module

+getMod = RM $ ( (\(_,_,c,_,_) -> c) <$> get)

+

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

+-- have a way to check for that.

+getForBytecode :: RM Bool

+getForBytecode = RM $ ((\(_,_,_,_,for_bytecode) -> for_bytecode) <$> get)

+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 =

+    in evalState (unRM doBinds) (mempty, us, mod, mempty, for_bytecode)

+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

+    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

+import GHC.Exts (Addr#)

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

+import GHC.Internal.Control.Exception.Base (patError)

+import System.Exit

+

+import qualified InferTags007_A as A

+

+data S a = S !a

+

+data P = MkP !(Addr# -> Int)

+

+-- Put the imported values into a strict field of a top level Con

+con_top_fun :: S (Int -> Int)

+con_top_fun = S A.fun

+{-# NOINLINE con_top_fun #-}

+

+con_top_caf :: S [Int]

+con_top_caf = S A.caf

+{-# NOINLINE con_top_caf #-}

+

+con_top_bot :: S (Int -> Int)

+con_top_bot = S A.bot

+{-# NOINLINE con_top_bot #-}

+

+con_top_con :: S (Maybe Int)

+con_top_con = S A.con

+{-# NOINLINE con_top_con #-}

+

+con_top_pat :: P

+con_top_pat = MkP patError

+{-# NOINLINE con_top_pat #-}

+

+-- Put the imported values into a strict field of a Con inside a rhs

+expr_fun :: () -> S (Int -> Int)

+expr_fun _ = S A.fun

+{-# OPAQUE expr_fun #-}

+

+expr_caf :: () -> S [Int]

+expr_caf _ = S A.caf

+{-# OPAQUE expr_caf #-}

+

+expr_bot :: () -> S (Int -> Int)

+expr_bot _ = S A.bot

+{-# OPAQUE expr_bot #-}

+

+expr_con :: () -> S (Maybe Int)

+expr_con _ = S A.con

+{-# OPAQUE expr_con #-}

+

+-- Actually use the field.

+use_S_head :: S [Int] -> Int

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

+{-# NOINLINE use_S_head #-}

+

+use_S_fromJust :: S (Maybe Int) -> Int

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

+{-# NOINLINE use_S_fromJust #-}

+

+use_S_apply :: S (Int -> Int) -> Int

+use_S_apply (S f) = f 1

+{-# NOINLINE use_S_apply #-}

+

+checkNotThunk :: String -> a -> IO ()

+checkNotThunk name x = do

+    c <- getClosureData x

+    case c of

+        ThunkClosure{} -> putStrLn ("FAIL: " ++ name ++ " is a thunk") >> exitFailure

+        APClosure{}    -> putStrLn ("FAIL: " ++ name ++ " is an AP") >> exitFailure

+        _              -> pure ()

+

+-- Pattern matching binds the field itself, so no selector thunk is involved.

+checkField :: String -> S a -> IO ()

+checkField name (S x) = checkNotThunk name x

+{-# NOINLINE checkField #-}

+

+main :: IO ()

+main = do

+    -- Check if the pointer in the strict field is a thunk.

+    checkField "con_top_caf" con_top_caf

+    checkField "con_top_fun" con_top_fun

+    checkField "con_top_bot" con_top_bot

+    checkField "con_top_con" con_top_con

+    case con_top_pat of MkP f -> checkNotThunk "con_top_pat" f

+    checkField "expr_caf" (expr_caf ())

+    checkField "expr_fun" (expr_fun ())

+    checkField "expr_bot" (expr_bot ())

+    checkField "expr_con" (expr_con ())

+

+    -- Actually execute a case on the contents of the field.

+    print (use_S_head con_top_caf, use_S_head (expr_caf ()))

+    print (use_S_fromJust con_top_con, use_S_fromJust (expr_con ()))

+    print (use_S_apply con_top_fun, use_S_apply (expr_fun ()))

+    forM_ [con_top_bot, expr_bot ()] $ \s -> do

+        r <- try (evaluate (use_S_apply s))

+        case r of

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

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

+(2,2)

+(42,42)