Andreas Klebinger pushed to branch wip/andreask/fold_tag_to_enum at Glasgow Haskell Compiler / GHC

Commits:

3 changed files:

Changes:

  • compiler/GHC/Core/Opt/ConstantFold.hs
    ... ... @@ -69,7 +69,6 @@ import GHC.Cmm.MachOp ( FMASign(..) )
    69 69 
     import GHC.Cmm.Type ( Width(..) )
    70 70
    71 71 
     import GHC.Data.FastString
    72 
    -import GHC.Data.Maybe      ( orElse )
    73 72
    74 73 
     import GHC.Utils.Outputable
    75 74 
     import GHC.Utils.Misc
    ... ... @@ -1997,6 +1996,13 @@ because we don't expect the user to call tagToEnum# at all; we merely
    1997 1996 
     generate calls in derived instances of Enum.  So we compromise: a
    1998 1997 
     rewrite rule rewrites a bad instance of tagToEnum# to an error call,
    1999 1998 
     and emits a warning.
    1999 
    +
    2000 
    +We also do something similar if we can see that the argument of tagToEnum is out
    2001 
    +of bounds, e.g. `tagToEnum# 99# :: Bool`.
    2002 
    +Replacing this with an error expression is better for two reasons:
    2003 
    +* It allow us to eliminate more dead code in cases like `case tagToEnum# 99# :: Bool of ...`
    2004 
    +* Should we actually end up executing the relevant code at runtime the user will
    2005 
    +  see a meaningful error message, instead of a segfault or incorrect result.
    2000 2006 
     -}
    2001 2007
    2002 2008 
     tagToEnumRule :: RuleM CoreExpr
    ... ... @@ -2008,9 +2014,13 @@ tagToEnumRule = do
    2008 2014 
         Just (tycon, tc_args) | isEnumerationTyCon tycon -> do
    2009 2015 
           let tag = fromInteger i
    2010 2016 
               correct_tag dc = (dataConTagZ dc) == tag
    2011 
    -      (dc:rest) <- return $ filter correct_tag (tyConDataCons_maybe tycon `orElse` [])
    2012 
    -      massert (null rest)
    2013 
    -      return $ mkTyApps (Var (dataConWorkId dc)) tc_args
    2017 
    +      Just dataCons <- pure $ tyConDataCons_maybe tycon
    2018 
    +      case filter correct_tag dataCons of
    2019 
    +        (dc:rest) -> do
    2020 
    +          massert (null rest)
    2021 
    +          pure $ mkTyApps (Var (dataConWorkId dc)) tc_args
    2022 
    +        -- Literal is out of range, e.g. tagToEnum @Bool #4
    2023 
    +        [] -> pure $ mkImpossibleExpr ty "tagToEnum: Argument out of range"
    2014 2024
    2015 2025 
         -- See Note [tagToEnum#]
    2016 2026 
         _ -> warnPprTrace True "tagToEnum# on non-enumeration type" (ppr ty) $

  • testsuite/tests/simplCore/should_compile/T25976.hs
    1 
    +{-# LANGUAGE MagicHash #-}
    2 
    +
    3 
    +module T25976 where
    4 
    +
    5 
    +import GHC.PrimOps (tagToEnum#)
    6 
    +
    7 
    +-- Spoiler - it's all dead code since tagToEnum 3# is undefined
    8 
    +main = case (tagToEnum# 4# :: Bool) of
    9 
    +  True -> print "Dead Code"
    10 
    +  False -> print "Dead Code"
    \ No newline at end of file

  • testsuite/tests/simplCore/should_compile/all.T
    ... ... @@ -541,3 +541,5 @@ test('T25883', normal, compile_grep_core, [''])
    541 541 
     test('T25883b', normal, compile_grep_core, [''])
    542 542 
     test('T25883c', normal, compile_grep_core, [''])
    543 543 
     test('T25883d', [extra_files(['T25883d_import.hs'])], multimod_compile_filter, ['T25883d', '-O -ddump-simpl -dno-typeable-binds -dsuppress-all -dsuppress-uniques', r'grep -e "y ="'])
    544 
    +
    545 
    +test('T25976', [grep_errmsg('Dead Code')], compile, ['-O -ddump-simpl -dsuppress-uniques -dno-typeable-binds'])

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help