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 new file mode 100644 index 0000000000..a452422cfe --- /dev/null +++ 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 new file mode 100644 index 0000000000..e338bb7d3c --- /dev/null +++ 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 index c269aabeef..7af840ac78 100644 --- a/clash-cores/clash-cores.cabal +++ b/clash-cores/clash-cores.cabal @@ -157,6 +157,9 @@ library Clash.Cores.LatticeSemi.ECP5.IO Clash.Cores.LatticeSemi.ECP5.Blackboxes.IO + 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 new file mode 100644 index 0000000000..a38316ecf7 --- /dev/null +++ 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 index eacf490ba0..e4e7a77d68 100644 --- a/clash-ghc/clash-ghc.cabal +++ b/clash-ghc/clash-ghc.cabal @@ -244,6 +244,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 index db8317878f..c756f13550 100644 --- 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 new file mode 100644 index 0000000000..a38316ecf7 --- /dev/null +++ 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 index 354221505c..c274ee7cea 100644 --- 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 index da8d4bdd48..d74a7070dd 100644 --- 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. @@ -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 index b89cc2a7f2..ff84d16b1c 100644 --- 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. @@ -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,7 +43,6 @@ 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) @@ -52,8 +50,7 @@ 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 index 2b19a1c94f..94e15e9fed 100644 --- 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. @@ -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) @@ -195,7 +198,7 @@ import Clash.Promoted.Nat (SNat (..), SNatLE (..), compareSNat, snatToInteger, snatToNum, natToNum) import Clash.Sized.Internal (formatRange) import Clash.XException - (ShowX (..), NFDataX (..), errorX, isX, showsPrecXWith, rwhnfX) + (ShowX (..), NFDataX (..), errorX, isX, showsPrecXWith, rwhnfX, XException(..)) import Clash.Sized.Internal.Mod @@ -507,6 +510,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 -- @@ -1604,3 +1608,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 #-}