Skip to content

Commit

Permalink
Use TH name to identify bottoming values
Browse files Browse the repository at this point in the history
This way we can just refer to "'patError" regardless of whether
it lives in:
- Control.Exceptions.Base, or
- GHC.Internal.Control.Exception.Base

(cherry picked from commit e565d26)
  • Loading branch information
christiaanb authored and kleinreact committed Nov 7, 2024
1 parent 7dfc59d commit d26a06b
Show file tree
Hide file tree
Showing 3 changed files with 46 additions and 28 deletions.
44 changes: 26 additions & 18 deletions clash-lib/src/Clash/Core/Util.hs
Original file line number Diff line number Diff line change
Expand Up @@ -19,6 +19,12 @@
module Clash.Core.Util where

import Control.Concurrent.Supply (Supply, freshId)
import Control.Exception.Base (patError)
#if MIN_VERSION_base(4,16,0)
import GHC.Prim.Panic (absentError)
#else
import Control.Exception.Base (absentError)
#endif
import Control.Monad.Trans.Except (Except, throwE, runExcept)
import Data.Bifunctor (first, second)
import qualified Data.HashSet as HashSet
Expand All @@ -31,6 +37,9 @@ import Data.Maybe
import qualified Data.Set as Set
import qualified Data.Set.Lens as Lens
import qualified Data.Text as T
import Data.Text.Extra (showt)
import GHC.Real
(divZeroError, overflowError, ratioZeroDenominatorError, underflowError)
import GHC.Stack (HasCallStack)

#if MIN_VERSION_ghc(9,0,0)
Expand Down Expand Up @@ -59,6 +68,9 @@ import Clash.Debug (traceIf)
import Clash.Unique (fromGhcUnique)
import Clash.Util

import {-# SOURCE #-} qualified Clash.Normalize.Primitives as Primitives
import Clash.XException (errorX)

-- | Rebuild a let expression / let expressions by taking the SCCs of a list
-- of bindings and remaking Let (NonRec ...) ... and Let (Rec ...) ...
--
Expand Down Expand Up @@ -479,27 +491,23 @@ primUCo =
}

undefinedPrims :: [T.Text]
undefinedPrims =
[ "Clash.Normalize.Primitives.undefined"
, "Control.Exception.Base.absentError"
, "Control.Exception.Base.patError"
, "GHC.Err.error"
, "GHC.Err.errorWithoutStackTrace"
, "GHC.Err.undefined"
, "GHC.Internal.Err.error"
, "GHC.Internal.Err.errorWithoutStackTrace"
, "GHC.Internal.Err.undefined"
, "GHC.Prim.Panic.absentError"
, "GHC.Real.divZeroError"
, "GHC.Real.overflowError"
, "GHC.Real.ratioZeroDenominatorError"
, "GHC.Real.underflowError"
undefinedPrims = fmap showt
[ 'Primitives.undefined
, 'patError
, 'error
, 'errorWithoutStackTrace
, 'undefined
, 'absentError
, 'divZeroError
, 'overflowError
, 'ratioZeroDenominatorError
, 'underflowError
]

undefinedXPrims :: [T.Text]
undefinedXPrims =
[ "Clash.Normalize.Primitives.undefinedX"
, "Clash.XException.errorX"
undefinedXPrims = fmap showt
[ 'Primitives.undefinedX
, 'errorX
]

substArgTys
Expand Down
6 changes: 6 additions & 0 deletions clash-lib/src/Clash/Normalize/Primitives.hs-boot
Original file line number Diff line number Diff line change
@@ -0,0 +1,6 @@
module Clash.Normalize.Primitives where

import Clash.Core.Term (PrimInfo)

undefined :: PrimInfo
undefinedX :: PrimInfo
24 changes: 14 additions & 10 deletions clash-lib/src/Clash/Normalize/Transformations/Case.hs
Original file line number Diff line number Diff line change
Expand Up @@ -26,6 +26,12 @@ module Clash.Normalize.Transformations.Case
, elimExistentials
) where

import Control.Exception.Base (patError)
#if MIN_VERSION_base(4,16,0)
import GHC.Prim.Panic (absentError)
#else
import Control.Exception.Base (absentError)
#endif
import qualified Control.Lens as Lens
import Control.Monad.State.Strict (evalState)
import Data.Bifunctor (second)
Expand Down Expand Up @@ -80,6 +86,8 @@ import Clash.Rewrite.Util (changed, isFromInt, whnfRW)
import Clash.Rewrite.WorkFree
import Clash.Util (curLoc)

import Clash.XException (errorX)

-- | Move a Case-decomposition from the subject of a Case-decomposition to the
-- alternatives
caseCase :: HasCallStack => NormRewrite
Expand Down Expand Up @@ -266,27 +274,23 @@ caseCon' ctx@(TransformContext is0 _) e@(Case subj ty alts) = do
-- WHNF of subject is _|_, in the form of `error`: that means that the
-- entire case-expression is evaluates to _|_
(Prim pInfo,repTy:_:callStack:msg:_,ticks)
| primName pInfo `elem` ["GHC.Err.error"
,"GHC.Internal.Err.error"] ->
| primName pInfo == Text.showt 'error ->
let e1 = mkApps (mkTicks (Prim pInfo) ticks)
[repTy,Right ty,callStack,msg]
in changed e1
-- WHNF of subject is _|_, in the form of `absentError`: that means that
-- the entire case-expression is evaluates to _|_
(Prim pInfo,_:msgOrCallStack:_,ticks)
| primName pInfo `elem` ["Control.Exception.Base.absentError"
,"GHC.Prim.Panic.absentError"] ->
| primName pInfo == Text.showt 'absentError ->
let e1 = mkApps (mkTicks (Prim pInfo) ticks)
[Right ty,msgOrCallStack]
in changed e1
-- WHNF of subject is _|_, in the form of `patError`, `undefined`, or
-- `errorWithoutStackTrace`: that means the entire case-expression is _|_
(Prim pInfo,repTy:_:msgOrCallStack:_,ticks)
| primName pInfo `elem` ["Control.Exception.Base.patError"
,"GHC.Err.undefined"
,"GHC.Err.errorWithoutStackTrace"
,"GHC.Internal.Err.undefined"
,"GHC.Internal.Err.errorWithoutStackTrace"] ->
| primName pInfo `elem` [ Text.showt 'patError
, Text.showt 'undefined
, Text.showt 'errorWithoutStackTrace] ->
let e1 = mkApps (mkTicks (Prim pInfo) ticks)
[repTy,Right ty,msgOrCallStack]
in changed e1
Expand All @@ -300,7 +304,7 @@ caseCon' ctx@(TransformContext is0 _) e@(Case subj ty alts) = do
-- WHNF of subject is _|_, in the form of `errorX`: that means that
-- the entire case-expression is evaluates to _|_
(Prim pInfo,_:callStack:msg:_,ticks)
| primName pInfo == "Clash.XException.errorX"
| primName pInfo == Text.showt 'errorX
-> let e1 = mkApps (mkTicks (Prim pInfo) ticks) [Right ty,callStack,msg]
in changed e1
-- WHNF of subject is non of the above, so either a variable reference,
Expand Down

0 comments on commit d26a06b

Please sign in to comment.