Merge pull request #2702 from clash-lang/ensure-spine-BitVector

lmbollen · web-flow · commit a26bb9ef3cb5 · 2024-04-09T11:14:01.000+02:00
Implement `ensureSpine` for `BitVector n` as `pack`
diff --git a/changelog/2024-04-08T16_44_03+02_00_bitvector_add_ensurespine b/changelog/2024-04-08T16_44_03+02_00_bitvector_add_ensurespine
@@ -0,0 +1 @@
+CHANGED: `BitVector n` now has an implementation for `ensureSpine` which ensures the constructor is present.
diff --git a/changelog/2024-04-08T17_33_38+02_00_move_xToBV b/changelog/2024-04-08T17_33_38+02_00_move_xToBV
@@ -0,0 +1 @@
+CHANGED: `xToBV` is now located in `Clash.Sized.Internal.BitVector` to avoid circular dependencies.
diff --git a/clash-cores/clash-cores.cabal b/clash-cores/clash-cores.cabal
@@ -158,6 +158,9 @@ library
     Clash.Cores.Xilinx.Xpm.Cdc.Single
     Clash.Cores.Xilinx.Xpm.Cdc.SyncRst
 
+  other-modules:
+    Data.Text.Extra
+
   ghc-options:
     -fexpose-all-unfoldings
     -fno-worker-wrapper
diff --git a/clash-cores/src/Data/Text/Extra.hs b/clash-cores/src/Data/Text/Extra.hs
@@ -0,0 +1,14 @@
+module Data.Text.Extra
+  ( showt
+  , showtl
+  ) where
+
+import Prelude
+import qualified Data.Text as TS
+import qualified Data.Text.Lazy as TL
+
+showt :: (Show a) => a -> TS.Text
+showt = TS.pack . show
+
+showtl :: (Show a) => a -> TL.Text
+showtl = TL.pack . show
diff --git a/clash-ghc/clash-ghc.cabal b/clash-ghc/clash-ghc.cabal
@@ -237,6 +237,7 @@ library
                       Clash.GHC.GHC2Core
                       Clash.GHC.LoadInterfaceFiles
                       Clash.GHC.Util
+                      Data.Text.Extra
                       Paths_clash_ghc
   if impl(ghc >= 8.8.0)
     Other-Modules:    Clash.GHCi.Util
diff --git a/clash-ghc/src-ghc/Clash/GHC/Evaluator/Primitive.hs b/clash-ghc/src-ghc/Clash/GHC/Evaluator/Primitive.hs
@@ -43,6 +43,7 @@ import           Data.Proxy          (Proxy)
 import           Data.Reflection     (reifyNat)
 import           Data.Text           (Text)
 import qualified Data.Text           as Text
+import           Data.Text.Extra     (showt)
 import           GHC.Exts (IsList(..))
 import           GHC.Float
 import           GHC.Int
@@ -202,7 +203,7 @@ ghcPrimUnwind tcm p tys vs v [e] m0
                        , "Clash.Sized.Vector.replace_int"
                        , "GHC.Classes.&&"
                        , "GHC.Classes.||"
-                       , "Clash.Class.BitPack.Internal.xToBV"
+                       , showt 'BitVector.xToBV
                        , "Clash.Sized.Vector.imap_go"
                        ]
   = if isUndefinedPrimVal v then
@@ -2444,7 +2445,7 @@ ghcPrimStep tcm isSubj pInfo tys args mach = case primName pInfo of
            val = unpack (toBV i :: BitVector 64)
         in reduce (mkDoubleCLit tcm val resTy)
 
-  "Clash.Class.BitPack.Internal.xToBV"
+  "Clash.Sized.Internal.BitVector.xToBV"
     | isSubj
     , Just (nTy, kn) <- extractKnownNat tcm tys
     -- The second argument to `xToBV` is always going to be suspended.
diff --git a/clash-ghc/src-ghc/Data/Text/Extra.hs b/clash-ghc/src-ghc/Data/Text/Extra.hs
@@ -0,0 +1,14 @@
+module Data.Text.Extra
+  ( showt
+  , showtl
+  ) where
+
+import Prelude
+import qualified Data.Text as TS
+import qualified Data.Text.Lazy as TL
+
+showt :: (Show a) => a -> TS.Text
+showt = TS.pack . show
+
+showtl :: (Show a) => a -> TL.Text
+showtl = TL.pack . show
diff --git a/clash-lib/prims/common/Clash_Class_BitPack.primitives.yaml b/clash-lib/prims/common/Clash_Class_BitPack.primitives.yaml
@@ -27,7 +27,7 @@
     template: ~ARG[0]
     workInfo: Never
 - BlackBox:
-    name: Clash.Class.BitPack.Internal.xToBV
+    name: Clash.Sized.Internal.BitVector.xToBV
     kind: Expression
     type: 'xToBV :: KnownNat n => BitVector n -> BitVector n'
     template: ~ARG[1]
diff --git a/clash-lib/src/Clash/Normalize/Transformations/Inline.hs b/clash-lib/src/Clash/Normalize/Transformations/Inline.hs
@@ -2,7 +2,7 @@
   Copyright  :  (C) 2012-2016, University of Twente,
                     2016-2017, Myrtle Software Ltd,
                     2017-2022, Google Inc.,
-                    2021-2022, QBayLogic B.V.
+                    2021-2024, QBayLogic B.V.
   License    :  BSD2 (see the file LICENSE)
   Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>
 
@@ -14,6 +14,7 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MagicHash #-}
 {-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE TemplateHaskell #-}
@@ -48,7 +49,7 @@ import GHC.Stack (HasCallStack)
 import GHC.BasicTypes.Extra (isNoInline)
 
 import qualified Clash.Explicit.SimIO as SimIO
-import qualified Clash.Sized.Internal.BitVector as BV (Bit(Bit), BitVector(BV))
+import qualified Clash.Sized.Internal.BitVector as BV (Bit(Bit), BitVector(BV), xToBV)
 
 import Clash.Annotations.Primitive (extractPrim)
 import Clash.Core.DataCon (DataCon(..))
@@ -438,7 +439,8 @@ collapseRHSNoops _ (Letrec binds body) = do
     isNoopApp x (Prim PrimInfo{primWorkInfo=WorkIdentity i []},args) = do
       arg <- getTermArg (lefts args) i
       isNoopApp x (collectArgs arg)
-    isNoopApp x (Prim PrimInfo{primName="Clash.Class.BitPack.Internal.xToBV"},args) = do
+    isNoopApp x (Prim PrimInfo{primName},args)
+      | primName == Text.showt 'BV.xToBV = do
       -- We don't make 'xToBV' something of 'WorkIdentity 1 []' because we don't
       -- want 'getIdentity' to replace "naked" occurances of 'xToBV' by
       -- 'unsafeCoerce#'. We don't want that since 'xToBV' has a special evaluator
diff --git a/clash-prelude/src/Clash/Class/BitPack/Internal.hs b/clash-prelude/src/Clash/Class/BitPack/Internal.hs
@@ -1,7 +1,7 @@
 {-|
 Copyright  :  (C) 2013-2016, University of Twente,
                   2016-2017, Myrtle Software Ltd,
-                  2021-2023  QBayLogic B.V.,
+                  2021-2024  QBayLogic B.V.,
                   2022,      Google Inc.
 License    :  BSD2 (see the file LICENSE)
 Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>
@@ -26,7 +26,6 @@ module Clash.Class.BitPack.Internal where
 
 import Prelude                        hiding (map)
 
-import Control.Exception              (catch, evaluate)
 import Data.Binary.IEEE754            (doubleToWord, floatToWord, wordToDouble,
                                        wordToFloat)
 
@@ -44,16 +43,14 @@ import GHC.Generics
 import GHC.TypeLits                   (KnownNat, Nat, type (+), type (-))
 import GHC.TypeLits.Extra             (CLog, Max)
 import Numeric.Half                   (Half (..))
-import System.IO.Unsafe               (unsafeDupablePerformIO)
 
 import Clash.Annotations.Primitive    (hasBlackBox)
 import Clash.Class.BitPack.Internal.TH (deriveBitPackTuples)
 import Clash.Class.Resize             (zeroExtend, resize)
 import Clash.Promoted.Nat             (SNat(..), snatToNum)
 import Clash.Sized.Internal.BitVector
   (pack#, split#, checkUnpackUndef, undefined#, unpack#, unsafeToNatural, isLike#,
-   BitVector, Bit, (++#))
-import Clash.XException
+   BitVector, Bit, (++#), xToBV)
 
 {- $setup
 >>> :m -Prelude
@@ -164,14 +161,6 @@ packXWith
 packXWith f = xToBV . f
 {-# INLINE packXWith #-}
 
-xToBV :: KnownNat n => BitVector n -> BitVector n
-xToBV x =
-  unsafeDupablePerformIO (catch (evaluate x)
-                                (\(XException _) -> return undefined#))
--- See: https://github.com/clash-lang/clash-compiler/pull/2511
-{-# CLASH_OPAQUE xToBV #-}
-{-# ANN xToBV hasBlackBox #-}
-
 -- | Pack both arguments to a 'BitVector' and use
 -- 'Clash.Sized.Internal.BitVector.isLike#' to compare them. This is a more
 -- lentiant comparison than '(==)', behaving more like (but not necessarily
diff --git a/clash-prelude/src/Clash/Sized/Internal/BitVector.hs b/clash-prelude/src/Clash/Sized/Internal/BitVector.hs
@@ -2,7 +2,7 @@
 Copyright  :  (C) 2013-2016, University of Twente,
                   2019     , Gergő Érdi
                   2016-2019, Myrtle Software Ltd,
-                  2021-2022, QBayLogic B.V.
+                  2021-2024, QBayLogic B.V.
                   2023     , Nadia Chambers
 License    :  BSD2 (see the file LICENSE)
 Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>
@@ -131,10 +131,12 @@ module Clash.Sized.Internal.BitVector
   , undefError
   , checkUnpackUndef
   , bitPattern
+  , xToBV
   )
 where
 
 import Control.DeepSeq            (NFData (..))
+import Control.Exception          (catch, evaluate)
 import Control.Lens               (Index, Ixed (..), IxValue)
 import Data.Bits                  (Bits (..), FiniteBits (..))
 import Data.Data                  (Data)
@@ -183,6 +185,7 @@ import Language.Haskell.TH        (Quote)
 #else
 import Language.Haskell.TH        (TypeQ)
 #endif
+import System.IO.Unsafe               (unsafeDupablePerformIO)
 import Test.QuickCheck.Arbitrary  (Arbitrary (..), CoArbitrary (..),
                                    arbitraryBoundedIntegral,
                                    coarbitraryIntegral, shrinkIntegral)
@@ -194,7 +197,7 @@ import Clash.Class.Resize         (Resize (..))
 import Clash.Promoted.Nat
   (SNat (..), SNatLE (..), compareSNat, snatToInteger, snatToNum, natToNum)
 import Clash.XException
-  (ShowX (..), NFDataX (..), errorX, isX, showsPrecXWith, rwhnfX)
+  (ShowX (..), NFDataX (..), errorX, isX, showsPrecXWith, rwhnfX, XException(..))
 
 import Clash.Sized.Internal.Mod
 
@@ -506,6 +509,7 @@ instance KnownNat n => NFDataX (BitVector n) where
   deepErrorX _ = undefined#
   rnfX = rwhnfX
   hasUndefined bv = isLeft (isX bv) || unsafeMask bv /= 0
+  ensureSpine = xToBV -- Converts `XException` to 'undefined#'
 
 -- | Create a binary literal
 --
@@ -1605,3 +1609,11 @@ bitPattern s = [p| ((\_x -> $preprocess) -> $tuple) |]
       | otherwise = error $
         "Invalid bit pattern: " ++ show c ++
         ", expecting one of '0', '1', '.', '_', or a lowercase alphabetic character"
+
+xToBV :: KnownNat n => BitVector n -> BitVector n
+xToBV x =
+  unsafeDupablePerformIO (catch (evaluate x)
+                                (\(XException _) -> return undefined#))
+-- See: https://github.com/clash-lang/clash-compiler/pull/2511
+{-# CLASH_OPAQUE xToBV #-}
+{-# ANN xToBV hasBlackBox #-}

Original file line number	Diff line number	Diff line change
`@@ -0,0 +1 @@`
	`1`	+CHANGED: `BitVector n` now has an implementation for `ensureSpine` which ensures the constructor is present.
Original file line number	Diff line number	Diff line change
`@@ -0,0 +1 @@`
	`1`	+CHANGED: `xToBV` is now located in `Clash.Sized.Internal.BitVector` to avoid circular dependencies.