Skip to content
GitLab
Projects Groups Topics Snippets
  • /
  • Help
    • Help
    • Support
    • Community forum
    • Submit feedback
  • Register
  • Sign in
  • GHC GHC
  • Project information
    • Project information
    • Activity
    • Labels
    • Members
  • Repository
    • Repository
    • Files
    • Commits
    • Branches
    • Tags
    • Contributor statistics
    • Graph
    • Compare revisions
    • Locked files
  • Issues 5.6k
    • Issues 5.6k
    • List
    • Boards
    • Service Desk
    • Milestones
    • Iterations
  • Merge requests 644
    • Merge requests 644
  • CI/CD
    • CI/CD
    • Pipelines
    • Jobs
    • Artifacts
    • Schedules
    • Test cases
  • Deployments
    • Deployments
    • Releases
  • Packages and registries
    • Packages and registries
    • Model experiments
  • Analytics
    • Analytics
    • CI/CD
    • Code review
    • Insights
    • Issue
    • Repository
  • Wiki
    • Wiki
  • Snippets
    • Snippets
  • Activity
  • Graph
  • Create a new issue
  • Jobs
  • Commits
  • Issue Boards
Collapse sidebar
  • Glasgow Haskell CompilerGlasgow Haskell Compiler
  • GHCGHC
  • Issues
  • #5453

Floating a non-exhaustive case can cause seg-faults

Consider

{-# LANGUAGE MagicHash #-}
module Main where

import GHC.Exts

data Var = TyVar !Int Bool Bool
         | TcTyVar Bool !Int Bool
         | Var Bool Bool !Int
         deriving (Show)

scrut :: Var -> (Bool, String)
scrut v = (True, case v of
    TcTyVar {} -> "OK"
    _ -> show v ++ show (case (case v of 
                                 TyVar b _ _ -> b 
                                 Var _ _ b -> b) of 
                           I# x# -> if x# ==# 7# 
                                    then show (I# (x# +# 1#)) 
                                    else show (I# (x# +# 2#))))

main = putStrLn $ snd (scrut (TcTyVar True 1 False))

Try this:

ghc -O -fno-specialise Segfault.hs
./Segfault

The bug is in the new case-floating machinery. If you compile with -dverbose-core2core you'll see the following after the first float-out phase:

Main.scrut =
  \ (v_acT :: Main.Var) ->
    case case v_acT of _ {
           Main.TyVar b_acU ds_dw6 ds_dw7 -> b_acU;
           Main.Var ds_dw4 ds_dw5 b_acV -> b_acV
         }
    of _ { GHC.Types.I# x#_szn ->
    (GHC.Types.True,
     case v_acT of wild_Xh {
       __DEFAULT ->
         GHC.Base.augment
           @ GHC.Types.Char
           (\ (@ b_axY)
              (c_axZ [Lbv=OneShot] :: GHC.Types.Char -> b_axY -> b_axY)
              (n_ay0 [Lbv=OneShot] :: b_axY) ->
              GHC.Base.foldr
                @ GHC.Types.Char @ b_axY c_axZ n_ay0 ($cshow_avj v_acT))
           (GHC.Show.$fShow[]_$cshow
              @ GHC.Types.Char
              GHC.Show.$fShowChar
              (case case x#_szn of _ {
                      __DEFAULT -> GHC.Types.False;
                      7 -> GHC.Types.True
                    }
               of _ {
                 GHC.Types.False ->
                   GHC.Show.$fShowInt_$cshow (GHC.Types.I# (GHC.Prim.+# x#_szn 2));
                 GHC.Types.True ->
                   GHC.Show.$fShowInt_$cshow (GHC.Types.I# (GHC.Prim.+# x#_szn 1))
               }));
       Main.TcTyVar ds_dwf ds_dwg ds_dwh -> lvl_szP
     })
    }

See the way that case case v_acT has gotten floated right out? There are two separate bugs here:

  1. It's wrong from a strictness point of view, because it's made scrut strict in v
  2. It's wrong from a semantics point of view, because the floated-out case is non-exhaustive, and that's what ultimately leads to the seg fault.

Problem (2) is with CoreUtils.exprOkForSpeculation. A non-exhaustive case is not ok for speculation!

Problem (1) is with the AnnCase case of SetLevels.lvlExpr, where we're testing the wrong expression for ok-for-speculation-nes. Both are quite easy to fix.

Thanks to Max for identifying this bug.

Trac metadata
Trac field Value
Version 7.2.1
Type Bug
TypeOfFailure OtherFailure
Priority normal
Resolution Unresolved
Component Compiler
Test case
Differential revisions
BlockedBy
Related
Blocking
CC
Operating system
Architecture
To upload designs, you'll need to enable LFS and have an admin enable hashed storage. More information
Assignee
Assign to
Time tracking