diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/clash-ghc.cabal b/clash-ghc.cabal --- a/clash-ghc.cabal +++ b/clash-ghc.cabal @@ -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, diff --git a/src-bin-841/Clash/GHCi/UI.hs b/src-bin-841/Clash/GHCi/UI.hs --- a/src-bin-841/Clash/GHCi/UI.hs +++ b/src-bin-841/Clash/GHCi/UI.hs @@ -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 diff --git a/src-bin-861/Clash/GHCi/UI.hs b/src-bin-861/Clash/GHCi/UI.hs --- a/src-bin-861/Clash/GHCi/UI.hs +++ b/src-bin-861/Clash/GHCi/UI.hs @@ -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 diff --git a/src-bin-881/Clash/GHCi/UI.hs b/src-bin-881/Clash/GHCi/UI.hs --- a/src-bin-881/Clash/GHCi/UI.hs +++ b/src-bin-881/Clash/GHCi/UI.hs @@ -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 diff --git a/src-bin-common/Clash/GHCi/Common.hs b/src-bin-common/Clash/GHCi/Common.hs --- a/src-bin-common/Clash/GHCi/Common.hs +++ b/src-bin-common/Clash/GHCi/Common.hs @@ -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) $ diff --git a/src-ghc/Clash/GHC/Evaluator.hs b/src-ghc/Clash/GHC/Evaluator.hs --- a/src-ghc/Clash/GHC/Evaluator.hs +++ b/src-ghc/Clash/GHC/Evaluator.hs @@ -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 diff --git a/src-ghc/Clash/GHC/GHC2Core.hs b/src-ghc/Clash/GHC/GHC2Core.hs --- a/src-ghc/Clash/GHC/GHC2Core.hs +++ b/src-ghc/Clash/GHC/GHC2Core.hs @@ -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 diff --git a/src-ghc/Clash/GHC/GenerateBindings.hs b/src-ghc/Clash/GHC/GenerateBindings.hs --- a/src-ghc/Clash/GHC/GenerateBindings.hs +++ b/src-ghc/Clash/GHC/GenerateBindings.hs @@ -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 diff --git a/src-ghc/Clash/GHC/LoadInterfaceFiles.hs b/src-ghc/Clash/GHC/LoadInterfaceFiles.hs --- a/src-ghc/Clash/GHC/LoadInterfaceFiles.hs +++ b/src-ghc/Clash/GHC/LoadInterfaceFiles.hs @@ -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