clash-ghc 1.2.0 → 1.2.1
raw patch · 10 files changed
+150/−94 lines, 10 filesdep ~basedep ~clash-libdep ~clash-preludePVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base, clash-lib, clash-prelude, ghc-typelits-extra, ghc-typelits-knownnat, ghc-typelits-natnormalise, time
API changes (from Hackage documentation)
Files
- CHANGELOG.md +18/−0
- clash-ghc.cabal +11/−11
- src-bin-841/Clash/GHCi/UI.hs +6/−4
- src-bin-861/Clash/GHCi/UI.hs +3/−1
- src-bin-881/Clash/GHCi/UI.hs +2/−1
- src-bin-common/Clash/GHCi/Common.hs +1/−15
- src-ghc/Clash/GHC/Evaluator.hs +82/−48
- src-ghc/Clash/GHC/GHC2Core.hs +20/−9
- src-ghc/Clash/GHC/GenerateBindings.hs +5/−4
- src-ghc/Clash/GHC/LoadInterfaceFiles.hs +2/−1
CHANGELOG.md view
@@ -1,5 +1,23 @@ # Changelog for the Clash project +## 1.2.1 *April 23rd 2020*+* Changed:+ * Treat `Signed 0`, `Unsigned 0`, `Index 1`, `BitVector 0` as unit. In effect this means that 'minBound' and 'maxBound' return 0, whereas previously they might crash [#1183](https://github.com/clash-lang/clash-compiler/issues/1183)+ * Infix use of `deepseqX` is now right-associative++* Added:+ * Add 'natToInteger', 'natToNatural', and 'natToNum'. Similar to 'snatTo*', but works solely on a type argument instead of an SNat.+ * `Clash.Sized.Vector.unfoldr` and `Clash.Sized.Vector.unfoldrI` to construct vectors from a seed value+ * Added NFDataX instances for `Data.Monoid.{First,Last}`++* Fixed:+ * The Verilog backend can now deal with non-contiguous ranges in custom bit-representations.+ * Synthesizing BitPack instances for type with phantom parameter fails [#1242](https://github.com/clash-lang/clash-compiler/issues/1242)+ * Synthesis of `fromBNat (toBNat d5)` failed due to `unsafeCoerce` coercing from `Any`+ * Memory leak in register primitives [#1256](https://github.com/clash-lang/clash-compiler/issues/1256)+ * Illegal VHDL slice when projecting nested SOP type [#1254](https://github.com/clash-lang/clash-compiler/issues/1254)+ * Vivado VHDL code path (`-fclash-hdlsyn Vivado`) generates illegal VHDL [#1264](https://github.com/clash-lang/clash-compiler/issues/1264)+ ## 1.2.0 *March 5th 2020* As promised when releasing 1.0, we've tried our best to keep the API stable. We think most designs will continue to compile with this new version, although special
clash-ghc.cabal view
@@ -1,6 +1,6 @@ Cabal-version: 2.2 Name: clash-ghc-Version: 1.2.0+Version: 1.2.1 Synopsis: CAES Language for Synchronous Hardware Description: Clash is a functional hardware description language that borrows both its@@ -69,7 +69,7 @@ executable clash Main-Is: src-ghc/Batch.hs Build-Depends: base, clash-ghc- GHC-Options: -Wall+ GHC-Options: -Wall -Wcompat if flag(dynamic) GHC-Options: -dynamic extra-libraries: pthread@@ -78,7 +78,7 @@ executable clashi Main-Is: src-ghc/Interactive.hs Build-Depends: base, clash-ghc- GHC-Options: -Wall+ GHC-Options: -Wall -Wcompat if flag(dynamic) GHC-Options: -dynamic extra-libraries: pthread@@ -119,7 +119,7 @@ elif impl(ghc >= 8.4.1) HS-Source-Dirs: src-bin-841 - GHC-Options: -Wall+ GHC-Options: -Wall -Wcompat CPP-Options: -DGHCI other-extensions: FlexibleContexts@@ -128,7 +128,7 @@ TemplateHaskell Build-Depends: array >= 0.4 && < 0.6,- base >= 4.10 && < 5,+ base >= 4.11 && < 5, bifunctors >= 4.1.1 && < 6.0, bytestring >= 0.9 && < 0.11, containers >= 0.5.4.0 && < 0.7,@@ -145,14 +145,14 @@ transformers >= 0.5.2.0 && < 0.6, unordered-containers >= 0.2.1.0 && < 0.3, - clash-lib == 1.2.0,- clash-prelude == 1.2.0,+ clash-lib == 1.2.1,+ clash-prelude == 1.2.1, concurrent-supply >= 0.1.7 && < 0.2,- ghc-typelits-extra >= 0.3.2 && < 0.4,- ghc-typelits-knownnat >= 0.6 && < 0.8,- ghc-typelits-natnormalise >= 0.6 && < 0.8,+ ghc-typelits-extra >= 0.3.3 && < 0.5,+ ghc-typelits-knownnat >= 0.7.2 && < 0.8,+ ghc-typelits-natnormalise >= 0.7.2 && < 0.8, deepseq >= 1.3.0.2 && < 1.5,- time >= 1.4.0.1 && < 1.10,+ time >= 1.4.0.1 && < 1.11, ghc-boot >= 8.4.0 && < 8.9, ghc-prim >= 0.3.1.0 && < 0.6, ghci >= 8.4.0 && < 8.9,
src-bin-841/Clash/GHCi/UI.hs view
@@ -624,7 +624,9 @@ Nothing -> do -- Set different defaulting rules (See #280)- runGHCiExpressions ["default ((),[],Integer,Int,Double,String)"]+ runGHCiExpressions+ ["default ((), [], Prelude.Integer, Prelude.Int, Prelude.Double, Prelude.String)"]+ -- enter the interactive loop runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty Just exprs -> do@@ -919,7 +921,7 @@ installInteractivePrint Nothing _ = return () installInteractivePrint (Just ipFun) exprmode = do ok <- trySuccess $ do- (name:_) <- GHC.parseName ipFun+ name <- head <$> GHC.parseName ipFun modifySession (\he -> let new_ic = setInteractivePrintName (hsc_IC he) name in he{hsc_IC = new_ic}) return Succeeded@@ -3336,7 +3338,7 @@ case mb_span of Nothing -> stepCmd [] Just loc -> do- Just md <- getCurrentBreakModule+ md <- fromJust <$> getCurrentBreakModule current_toplevel_decl <- enclosingTickSpan md loc doContinue (`isSubspanOf` RealSrcSpan current_toplevel_decl) GHC.SingleStep @@ -3827,7 +3829,7 @@ getModBreak :: Module -> GHCi (ForeignRef BreakArray, Array Int SrcSpan) getModBreak m = do- Just mod_info <- GHC.getModuleInfo m+ mod_info <- fromJust <$> GHC.getModuleInfo m let modBreaks = GHC.modInfoModBreaks mod_info let arr = GHC.modBreaks_flags modBreaks let ticks = GHC.modBreaks_locs modBreaks
src-bin-861/Clash/GHCi/UI.hs view
@@ -632,7 +632,9 @@ Nothing -> do -- Set different defaulting rules (See #280)- runGHCiExpressions ["default ((),[],Integer,Int,Double,String)"]+ runGHCiExpressions+ ["default ((), [], Prelude.Integer, Prelude.Int, Prelude.Double, Prelude.String)"]+ -- enter the interactive loop runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty Just exprs -> do
src-bin-881/Clash/GHCi/UI.hs view
@@ -668,7 +668,8 @@ Nothing -> do -- Set different defaulting rules (See #280)- runGHCiExpressions ["default ((),[],Integer,Int,Double,String)"]+ runGHCiExpressions+ ["default ((), [], Prelude.Integer, Prelude.Int, Prelude.Double, Prelude.String)"] -- enter the interactive loop runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty
src-bin-common/Clash/GHCi/Common.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} module Clash.GHCi.Common@@ -13,11 +12,7 @@ -- The GHC interface import qualified DynFlags-#if MIN_VERSION_base(4,11,0)-import qualified EnumSet as GHC (member) -- ghc84, ghc86-#else-import qualified Data.IntSet as IntSet -- ghc82-#endif+import qualified EnumSet as GHC (member) import qualified GHC (DynFlags, ModSummary (..), Module (..), extensionFlags, moduleNameString) import qualified GHC.LanguageExtensions as LangExt (Extension (..))@@ -49,16 +44,7 @@ msgStem = "Warning: Extension MonoLocalBinds disabled. This might lead to unexpected logic duplication" active :: GHC.DynFlags -> Bool-#if MIN_VERSION_base(4,11,0)--- ghc84, ghc86 active = GHC.member LangExt.MonoLocalBinds . GHC.extensionFlags-#else--- ghc82-active = member LangExt.MonoLocalBinds . GHC.extensionFlags--member :: Enum a => a -> IntSet.IntSet -> Bool-member = IntSet.member . fromEnum-#endif checkImportDirs :: Foldable t => ClashOpts -> t FilePath -> IO () checkImportDirs opts idirs = when (opt_checkIDir opts) $
src-ghc/Clash/GHC/Evaluator.hs view
@@ -35,7 +35,6 @@ import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Vector.Primitive as Vector-import Debug.Trace (trace) import GHC.Float import GHC.Int import GHC.Integer@@ -70,7 +69,8 @@ (Name (..), NameSort (..), mkUnsafeSystemName) import Clash.Core.Pretty (showPpr) import Clash.Core.Term- (Pat (..), PrimInfo (..), Term (..), WorkInfo (..))+ (Pat (..), PrimInfo (..), Term (..), WorkInfo (..), mkApps)+import Clash.Core.TermInfo (piResultTys) import Clash.Core.Type (Type (..), ConstTy (..), LitTy (..), TypeView (..), mkFunTy, mkTyConApp, splitFunForallTy, tyView)@@ -78,9 +78,10 @@ (TyConMap, TyConName, tyConDataCons) import Clash.Core.TysPrim import Clash.Core.Util- (mkApps,mkRTree,mkVec,piResultTys,tyNatSize,dataConInstArgTys,primCo,+ (mkRTree,mkVec,tyNatSize,dataConInstArgTys,primCo, undefinedTm) import Clash.Core.Var (mkLocalId, mkTyVar)+import Clash.Debug (trace) import Clash.GHC.GHC2Core (modNameM) import Clash.Rewrite.Util (mkSelectorCase) import Clash.Unique (lookupUniqMap)@@ -1334,7 +1335,7 @@ -> let resTyInfo = extractTySizeInfo tcm ty tys in Just $ mach2 { mStack = mStack mach- , mTerm = mkBitVectorLit' resTyInfo 0 (BitVector.unsafeToInteger $ (pack :: Double -> BitVector 64) $ fromRational i)+ , mTerm = mkBitVectorLit' resTyInfo 0 (toInteger $ (pack :: Double -> BitVector 64) $ fromRational i) } "Clash.Class.BitPack.packFloat#" -- :: Float -> BitVector 32@@ -1343,7 +1344,7 @@ -> let resTyInfo = extractTySizeInfo tcm ty tys in Just $ mach2 { mStack = mStack mach- , mTerm = mkBitVectorLit' resTyInfo 0 (BitVector.unsafeToInteger $ (pack :: Float -> BitVector 32) $ fromRational i)+ , mTerm = mkBitVectorLit' resTyInfo 0 (toInteger $ (pack :: Float -> BitVector 32) $ fromRational i) } "Clash.Class.BitPack.unpackFloat#"@@ -1489,20 +1490,20 @@ "Clash.Sized.Internal.BitVector.and##" | [i,j] <- bitLiterals args -> let Bit msk val = BitVector.and## (toBit i) (toBit j)- in reduce (mkBitLit ty msk val)+ in reduce (mkBitLit ty (toInteger msk) (toInteger val)) "Clash.Sized.Internal.BitVector.or##" | [i,j] <- bitLiterals args -> let Bit msk val = BitVector.or## (toBit i) (toBit j)- in reduce (mkBitLit ty msk val)+ in reduce (mkBitLit ty (toInteger msk) (toInteger val)) "Clash.Sized.Internal.BitVector.xor##" | [i,j] <- bitLiterals args -> let Bit msk val = BitVector.xor## (toBit i) (toBit j)- in reduce (mkBitLit ty msk val)+ in reduce (mkBitLit ty (toInteger msk) (toInteger val)) "Clash.Sized.Internal.BitVector.complement##" | [i] <- bitLiterals args -> let Bit msk val = BitVector.complement## (toBit i)- in reduce (mkBitLit ty msk val)+ in reduce (mkBitLit ty (toInteger msk) (toInteger val)) -- Pack "Clash.Sized.Internal.BitVector.pack#"@@ -1561,33 +1562,36 @@ in reduce (mkBitLit resTy msk val) where op :: KnownNat n => BitVector n -> Int -> Proxy n -> (Integer,Integer)- op u i _ = (m, v)+ op u i _ = (toInteger m, toInteger v) where Bit m v = (BitVector.index# u i) "Clash.Sized.Internal.BitVector.replaceBit#" -- :: :: KnownNat n => BitVector n -> Int -> Bit -> BitVector n | Just (_, n) <- extractKnownNat tcm tys , [ _- , PrimVal bvP _ [_, Lit (IntegerLiteral mskBv), Lit (IntegerLiteral bv)]+ , PrimVal bvP _ [_, Lit (NaturalLiteral mskBv), Lit (IntegerLiteral bv)] , valArgs -> Just [Literal (IntLiteral i)]- , PrimVal bP _ [Lit (IntegerLiteral mskB), Lit (IntegerLiteral b)]+ , PrimVal bP _ [Lit (WordLiteral mskB), Lit (IntegerLiteral b)] ] <- args , primName bvP == "Clash.Sized.Internal.BitVector.fromInteger#" , primName bP == "Clash.Sized.Internal.BitVector.fromInteger##" -> let resTyInfo = extractTySizeInfo tcm ty tys- (mskVal,val) = reifyNat n (op (BV mskBv bv) (fromInteger i) (Bit mskB b))+ (mskVal,val) = reifyNat n (op (BV (fromInteger mskBv) (fromInteger bv))+ (fromInteger i)+ (Bit (fromInteger mskB) (fromInteger b))) in reduce (mkBitVectorLit' resTyInfo mskVal val) where op :: KnownNat n => BitVector n -> Int -> Bit -> Proxy n -> (Integer,Integer) -- op bv i b _ = (BitVector.unsafeMask res, BitVector.unsafeToInteger res) op bv i b _ = splitBV (BitVector.replaceBit# bv i b) "Clash.Sized.Internal.BitVector.setSlice#"- -- :: BitVector (m + 1 + i) -> SNat m -> SNat n -> BitVector (m + 1 - n) -> BitVector (m + 1 + i)- | mTy : _ : nTy : _ <- tys+ -- :: SNat (m+1+i) -> BitVector (m + 1 + i) -> SNat m -> SNat n -> BitVector (m + 1 - n) -> BitVector (m + 1 + i)+ | mTy : iTy : nTy : _ <- tys , Right m <- runExcept (tyNatSize tcm mTy)+ , Right iN <- runExcept (tyNatSize tcm iTy) , Right n <- runExcept (tyNatSize tcm nTy) , [i,j] <- bitVectorLiterals' args- -> let BV msk val = BitVector.setSlice# (toBV i) (unsafeSNat m) (unsafeSNat n) (toBV j)+ -> let BV msk val = BitVector.setSlice# (unsafeSNat (m+1+iN)) (toBV i) (unsafeSNat m) (unsafeSNat n) (toBV j) resTyInfo = extractTySizeInfo tcm ty tys- in reduce (mkBitVectorLit' resTyInfo msk val)+ in reduce (mkBitVectorLit' resTyInfo (toInteger msk) (toInteger val)) "Clash.Sized.Internal.BitVector.slice#" -- :: BitVector (m + 1 + i) -> SNat m -> SNat n -> BitVector (m + 1 - n) | mTy : _ : nTy : _ <- tys@@ -1596,7 +1600,7 @@ , [i] <- bitVectorLiterals' args -> let BV msk val = BitVector.slice# (toBV i) (unsafeSNat m) (unsafeSNat n) resTyInfo = extractTySizeInfo tcm ty tys- in reduce (mkBitVectorLit' resTyInfo msk val)+ in reduce (mkBitVectorLit' resTyInfo (toInteger msk) (toInteger val)) "Clash.Sized.Internal.BitVector.split#" -- :: forall n m. KnownNat n => BitVector (m + n) -> (BitVector m, BitVector n) | nTy : mTy : _ <- tys , Right n <- runExcept (tyNatSize tcm nTy)@@ -1622,9 +1626,9 @@ , Just (_, kn) <- extractKnownNat tcm tys -> let resTy = getResultTy tcm ty tys (msk,val) = reifyNat kn (op (toBV i))- in reduce (mkBitLit resTy msk val)+ in reduce (mkBitLit resTy (toInteger msk) (toInteger val)) where- op :: KnownNat n => BitVector n -> Proxy n -> (Integer,Integer)+ op :: KnownNat n => BitVector n -> Proxy n -> (Word,Word) op u _ = (unsafeMask# res, BitVector.unsafeToInteger# res) where res = BitVector.msb# u@@ -1632,7 +1636,7 @@ | [i] <- bitVectorLiterals' args -> let resTy = getResultTy tcm ty tys Bit msk val = BitVector.lsb# (toBV i)- in reduce (mkBitLit resTy msk val)+ in reduce (mkBitLit resTy (toInteger msk) (toInteger val)) -- Eq@@ -1761,20 +1765,17 @@ -- Bits "Clash.Sized.Internal.BitVector.and#"- | Just (i,j) <- bitVectorLiterals args- , Just (nTy, kn) <- extractKnownNat tcm tys- -> let BV msk val = BitVector.and# (toBV i) (toBV j)- in reduce (mkBitVectorLit ty nTy kn msk val)+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftBitVector2 (BitVector.and#) ty tcm tys args)+ -> reduce val "Clash.Sized.Internal.BitVector.or#"- | Just (i,j) <- bitVectorLiterals args- , Just (nTy, kn) <- extractKnownNat tcm tys- -> let BV msk val = BitVector.or# (toBV i) (toBV j)- in reduce (mkBitVectorLit ty nTy kn msk val)+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftBitVector2 (BitVector.or#) ty tcm tys args)+ -> reduce val "Clash.Sized.Internal.BitVector.xor#"- | Just (i,j) <- bitVectorLiterals args- , Just (nTy, kn) <- extractKnownNat tcm tys- -> let BV msk val = BitVector.xor# (toBV i) (toBV j)- in reduce (mkBitVectorLit ty nTy kn msk val)+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftBitVector2 (BitVector.xor#) ty tcm tys args)+ -> reduce val "Clash.Sized.Internal.BitVector.complement#" | [i] <- bitVectorLiterals' args@@ -2304,6 +2305,43 @@ val = i .&. bitsKeep in reduce (mkUnsignedLit ty mTy km val) +-- Conversions+ "Clash.Sized.Internal.Unsigned.unsignedToWord"+ | isSubj+ , [a] <- unsignedLiterals' args+ -> let b = Unsigned.unsignedToWord (U (fromInteger a))+ (_,tyView -> TyConApp wordTcNm []) = splitFunForallTy ty+ (Just wordTc) = lookupUniqMap wordTcNm tcm+ [wordDc] = tyConDataCons wordTc+ in reduce (mkApps (Data wordDc) [Left (Literal (WordLiteral (toInteger b)))])++ "Clash.Sized.Internal.Unsigned.unsigned8toWord8"+ | isSubj+ , [a] <- unsignedLiterals' args+ -> let b = Unsigned.unsigned8toWord8 (U (fromInteger a))+ (_,tyView -> TyConApp wordTcNm []) = splitFunForallTy ty+ (Just wordTc) = lookupUniqMap wordTcNm tcm+ [wordDc] = tyConDataCons wordTc+ in reduce (mkApps (Data wordDc) [Left (Literal (WordLiteral (toInteger b)))])++ "Clash.Sized.Internal.Unsigned.unsigned16toWord16"+ | isSubj+ , [a] <- unsignedLiterals' args+ -> let b = Unsigned.unsigned16toWord16 (U (fromInteger a))+ (_,tyView -> TyConApp wordTcNm []) = splitFunForallTy ty+ (Just wordTc) = lookupUniqMap wordTcNm tcm+ [wordDc] = tyConDataCons wordTc+ in reduce (mkApps (Data wordDc) [Left (Literal (WordLiteral (toInteger b)))])++ "Clash.Sized.Internal.Unsigned.unsigned32toWord32"+ | isSubj+ , [a] <- unsignedLiterals' args+ -> let b = Unsigned.unsigned32toWord32 (U (fromInteger a))+ (_,tyView -> TyConApp wordTcNm []) = splitFunForallTy ty+ (Just wordTc) = lookupUniqMap wordTcNm tcm+ [wordDc] = tyConDataCons wordTc+ in reduce (mkApps (Data wordDc) [Left (Literal (WordLiteral (toInteger b)))])+ "Clash.Annotations.BitRepresentation.Deriving.dontApplyInHDL" | isSubj , f : a : _ <- args@@ -3543,7 +3581,7 @@ where normalizeBit (msk,v) = (msk .&. 1, v .&. 1) go val = case val of- PrimVal p _ [Lit (IntegerLiteral m), Lit (IntegerLiteral i)]+ PrimVal p _ [Lit (WordLiteral m), Lit (IntegerLiteral i)] | primName p == "Clash.Sized.Internal.BitVector.fromInteger##" -> Just (m,i) _ -> Nothing@@ -3560,28 +3598,24 @@ signedLiterals' = sizedLiterals' "Clash.Sized.Internal.Signed.fromInteger#" unsignedLiterals' = sizedLiterals' "Clash.Sized.Internal.Unsigned.fromInteger#" -bitVectorLiterals- :: [Value] -> Maybe ((Integer,Integer),(Integer,Integer))-bitVectorLiterals = pairOf bitVectorLiteral- bitVectorLiterals' :: [Value] -> [(Integer,Integer)] bitVectorLiterals' = listOf bitVectorLiteral bitVectorLiteral :: Value -> Maybe (Integer, Integer) bitVectorLiteral val = case val of- (PrimVal p _ [_, Lit (IntegerLiteral m), Lit (IntegerLiteral i)])+ (PrimVal p _ [_, Lit (NaturalLiteral m), Lit (IntegerLiteral i)]) | primName p == "Clash.Sized.Internal.BitVector.fromInteger#" -> Just (m, i) _ -> Nothing toBV :: (Integer,Integer) -> BitVector n-toBV = uncurry BV+toBV (mask,val) = BV (fromInteger mask) (fromInteger val) splitBV :: BitVector n -> (Integer,Integer)-splitBV (BV msk val) = (msk,val)+splitBV (BV msk val) = (toInteger msk, toInteger val) toBit :: (Integer,Integer) -> Bit-toBit = uncurry Bit+toBit (mask,val) = Bit (fromInteger mask) (fromInteger val) valArgs :: Value@@ -3620,7 +3654,7 @@ bitVectorLitIntLit tcm tys args | Just (nTy,kn) <- extractKnownNat tcm tys , [_- ,PrimVal p _ [_,Lit (IntegerLiteral m),Lit (IntegerLiteral i)]+ ,PrimVal p _ [_,Lit (NaturalLiteral m),Lit (IntegerLiteral i)] ,valArgs -> Just [Literal (IntLiteral j)] ] <- args , primName p == "Clash.Sized.Internal.BitVector.fromInteger#"@@ -3679,7 +3713,7 @@ -- ^ Value -> Term mkBitLit ty msk val =- mkApps (bConPrim sTy) [ Left (Literal (IntegerLiteral (msk .&. 1)))+ mkApps (bConPrim sTy) [ Left (Literal (WordLiteral (msk .&. 1))) , Left (Literal (IntegerLiteral (val .&. 1)))] where (_,sTy) = splitFunForallTy ty@@ -3713,7 +3747,7 @@ = mkApps (bvConPrim sTy) [Right nTy ,Left (Literal (NaturalLiteral kn))- ,Left (Literal (IntegerLiteral mask))+ ,Left (Literal (NaturalLiteral mask)) ,Left (Literal (IntegerLiteral val))] where (_,sTy) = splitFunForallTy ty@@ -3841,14 +3875,14 @@ bConPrim (tyView -> TyConApp bTcNm _) = Prim (PrimInfo "Clash.Sized.Internal.BitVector.fromInteger##" funTy WorkNever) where- funTy = foldr1 mkFunTy [integerPrimTy,integerPrimTy,mkTyConApp bTcNm []]+ funTy = foldr1 mkFunTy [wordPrimTy,integerPrimTy,mkTyConApp bTcNm []] bConPrim _ = error $ $(curLoc) ++ "called with incorrect type" bvConPrim :: Type -> Term bvConPrim (tyView -> TyConApp bvTcNm _) = Prim (PrimInfo "Clash.Sized.Internal.BitVector.fromInteger#" (ForAllTy nTV funTy) WorkNever) where- funTy = foldr1 mkFunTy [naturalPrimTy,integerPrimTy,integerPrimTy,mkTyConApp bvTcNm [nVar]]+ funTy = foldr1 mkFunTy [naturalPrimTy,naturalPrimTy,integerPrimTy,mkTyConApp bvTcNm [nVar]] nName = mkUnsafeSystemName "n" 0 nVar = VarTy nTV nTV = mkTyVar typeNatKind nName@@ -3917,7 +3951,7 @@ | Just (nTy, kn) <- extractKnownNat tcm tys , [i,j] <- bitVectorLiterals' args = let BV mask val = f (toBV i) (toBV j)- in Just $ mkBitVectorLit ty nTy kn mask val+ in Just $ mkBitVectorLit ty nTy kn (toInteger mask) (toInteger val) | otherwise = Nothing liftBitVector2Bool :: KnownNat n
src-ghc/Clash/GHC/GHC2Core.hs view
@@ -78,7 +78,7 @@ import Module (moduleName, moduleNameString) import Name (Name, nameModule_maybe, nameOccName, nameUnique, getSrcSpan)-import PrelNames (tYPETyConKey)+import PrelNames (tYPETyConKey, integerTyConKey, naturalTyConKey) import OccName (occNameString) import Outputable (showPpr) import Pair (Pair (..))@@ -417,10 +417,9 @@ term' (Cast e co) = do let (Pair ty1 ty2) = coercionKind co hasPrimCoM <- hasPrimCo co- ty1_I <- isIntegerTy ty1- ty2_I <- isIntegerTy ty2+ sizedCast <- isSizedCast ty1 ty2 case hasPrimCoM of- Just _ | ty1_I || ty2_I+ Just _ | sizedCast -> C.Cast <$> term e <*> coreToType ty1 <*> coreToType ty2 _ -> term e term' (Tick (SourceNote rsp _) e) =@@ -565,11 +564,23 @@ then RWS.local (const x) m else m -isIntegerTy :: Type -> C2C Bool-isIntegerTy (TyConApp tc []) = do- tcNm <- qualifiedNameString (tyConName tc)- return (tcNm == "GHC.Integer.Type.Integer")-isIntegerTy _ = return False+isSizedCast :: Type -> Type -> C2C Bool+isSizedCast (TyConApp tc1 _) (TyConApp tc2 _) = do+ tc1Nm <- qualifiedNameString (tyConName tc1)+ tc2Nm <- qualifiedNameString (tyConName tc2)+ return+ (or [tc1 `hasKey` integerTyConKey &&+ or [tc2Nm == "Clash.Sized.Internal.Signed.Signed"+ ,tc2Nm == "Clash.Sized.Internal.Index.Index"]+ ,tc2 `hasKey` integerTyConKey &&+ or [tc1Nm == "Clash.Sized.Internal.Signed.Signed"+ ,tc1Nm == "Clash.Sized.Internal.Index.Index"]+ ,tc1 `hasKey` naturalTyConKey &&+ tc2Nm == "Clash.Sized.Internal.Unsigned.Unsigned"+ ,tc2 `hasKey` naturalTyConKey &&+ tc1Nm == "Clash.Sized.Internal.Unsigned.Unsigned"+ ])+isSizedCast _ _ = return False hasPrimCo :: Coercion -> C2C (Maybe Type) hasPrimCo (TyConAppCo _ _ coers) = do
src-ghc/Clash/GHC/GenerateBindings.hs view
@@ -12,6 +12,7 @@ (generateBindings) where +import Control.Arrow ((***), first) import Control.DeepSeq (deepseq) import Control.Lens ((%~),(&)) import Control.Monad (unless)@@ -23,6 +24,7 @@ import qualified Data.IntMap.Strict as IMS import qualified Data.HashMap.Strict as HashMap import Data.List (isPrefixOf)+import Data.List.Extra (indexMaybe) import qualified Data.Text as Text import qualified Data.Time.Clock as Clock @@ -44,14 +46,14 @@ import Clash.Annotations.Primitive (HDL, extractPrim) import Clash.Core.Subst (extendGblSubstList, mkSubst, substTm)-import Clash.Core.Term (Term (..))+import Clash.Core.Term (Term (..), mkLams, mkTyLams) import Clash.Core.Type (Type (..), TypeView (..), mkFunTy, splitFunForallTy, tyView) import Clash.Core.TyCon (TyConMap, TyConName, isNewTypeTc) import Clash.Core.TysPrim (tysPrimMap)-import Clash.Core.Util (mkLams, mkTyLams) import Clash.Core.Var (Var (..), Id, IdScope (..), setIdScope) import Clash.Core.VarEnv (InScopeSet, VarEnv, emptyInScopeSet, extendInScopeSet, mkInScopeSet, mkVarEnv, unionVarEnv)+import Clash.Debug (traceIf) import Clash.Driver (compilePrimitive) import Clash.Driver.Types (BindingMap, Binding(..)) import Clash.GHC.GHC2Core@@ -66,8 +68,7 @@ import Clash.Rewrite.Util (mkInternalVar, mkSelectorCase) import Clash.Unique (listToUniqMap, lookupUniqMap, mapUniqMap, unionUniqMap, uniqMapToUniqSet)-import Clash.Util- ((***),first,traceIf,indexMaybe,reportTimeDiff)+import Clash.Util (reportTimeDiff) generateBindings :: GHC.OverridingBool
src-ghc/Clash/GHC/LoadInterfaceFiles.hs view
@@ -58,10 +58,11 @@ (DataRepr', dataReprAnnToDataRepr') import Clash.Annotations.Primitive import Clash.Annotations.BitRepresentation (DataReprAnn)+import Clash.Debug (traceIf) import Clash.Primitives.Types (UnresolvedPrimitive, name) import Clash.Primitives.Util (decodeOrErr) import Clash.GHC.GHC2Core (qualifiedNameString')-import Clash.Util (curLoc, traceIf)+import Clash.Util (curLoc) runIfl :: GHC.GhcMonad m => GHC.Module -> TcRnTypes.IfL a -> m a runIfl modName action = do