clash-ghc 0.99.2 → 0.99.3
raw patch · 4 files changed
+260/−30 lines, 4 filesdep +primitivedep +vectordep ~Win32dep ~clash-libdep ~clash-preludePVP ok
version bump matches the API change (PVP)
Dependencies added: primitive, vector
Dependency ranges changed: Win32, clash-lib, clash-prelude, containers, ghc, ghc-boot, ghci, time
API changes (from Hackage documentation)
Files
- CHANGELOG.md +10/−0
- clash-ghc.cabal +12/−10
- src-ghc/Clash/GHC/Evaluator.hs +237/−19
- src-ghc/Clash/GHC/GHC2Core.hs +1/−1
CHANGELOG.md view
@@ -1,5 +1,15 @@ # Changelog for the [`clash-ghc`](http://hackage.haskell.org/package/clash-ghc) package +## 0.99.3 *July 28th 2018*+* Fixes bugs:+ * Evaluator recognizes `Bit` literals [#329](https://github.com/clash-lang/clash-compiler/issues/329)+ * Use existential type-variables in context of GADT pattern match+ * Do not create zero-bit temporary variables in generated HDL+ * Use correct arguments in nested primitives [#323](https://github.com/clash-lang/clash-compiler/issues/329)+ * Zero-constructor data type needs 0 bits [#238](https://github.com/clash-lang/clash-compiler/issues/238)+ * Create empty component when result needs 0 bits+ * Evaluator performs BigNat arithmetic+ ## 0.99.1 *May 12th 2018* * Allow `~NAME[N]` tag inside `~GENSYM[X]` * Support HDL record selector generation [#313](https://github.com/clash-lang/clash-compiler/pull/313)
clash-ghc.cabal view
@@ -1,5 +1,5 @@ Name: clash-ghc-Version: 0.99.2+Version: 0.99.3 Synopsis: CAES Language for Synchronous Hardware Description: CλaSH (pronounced ‘clash’) is a functional hardware description language that@@ -58,14 +58,14 @@ executable clash Main-Is: src-ghc/Batch.hs Build-Depends: base, clash-ghc- GHC-Options: -Wall -dynamic+ GHC-Options: -Wall extra-libraries: pthread default-language: Haskell2010 executable clashi Main-Is: src-ghc/Interactive.hs Build-Depends: base, clash-ghc- GHC-Options: -Wall -dynamic+ GHC-Options: -Wall extra-libraries: pthread default-language: Haskell2010 @@ -99,10 +99,10 @@ base >= 4.3.1.0 && < 5, bifunctors >= 4.1.1 && < 5.6, bytestring >= 0.9 && < 0.11,- containers >= 0.5.4.0 && < 0.6,+ containers >= 0.5.4.0 && < 0.7, directory >= 1.2 && < 1.4, filepath >= 1.3 && < 1.5,- ghc >= 8.2.0 && < 8.6,+ ghc >= 8.2.0 && < 8.8, process >= 1.2 && < 1.7, hashable >= 1.1.2.3 && < 1.3, haskeline >= 0.7.0.3 && < 0.8,@@ -120,16 +120,18 @@ ghc-typelits-knownnat >= 0.5 && < 0.6, ghc-typelits-natnormalise >= 0.6 && < 0.7, deepseq >= 1.3.0.2 && < 1.5,- time >= 1.4.0.1 && < 1.9,- ghc-boot >= 8.0.2 && < 8.6,+ time >= 1.4.0.1 && < 1.10,+ ghc-boot >= 8.0.2 && < 8.8, ghc-prim >= 0.3.1.0 && < 0.6,- ghci >= 8.2.0 && < 8.6,+ ghci >= 8.2.0 && < 8.8, uniplate >= 1.6.12 && < 1.8, reflection >= 2.1.2 && < 3.0,- integer-gmp >= 1.0.1.0 && < 2.0+ integer-gmp >= 1.0.1.0 && < 2.0,+ primitive >= 0.5.0.1 && < 1.0,+ vector >= 0.11 && < 1.0 if os(windows)- Build-Depends: Win32 >= 2.3.1 && < 2.6+ Build-Depends: Win32 >= 2.3.1 && < 2.9 else Build-Depends: unix >= 2.7.1 && < 2.8
src-ghc/Clash/GHC/Evaluator.hs view
@@ -25,19 +25,25 @@ import Data.Char (chr,ord) import qualified Data.Either as Either import qualified Data.HashMap.Strict as HashMap+import qualified Data.IntMap as IntMap import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.List as List+import qualified Data.Primitive.ByteArray as ByteArray import Data.Proxy (Proxy) import Data.Reflection (reifyNat) import Data.Text (Text)+import qualified Data.Vector.Primitive as Vector import GHC.Float import GHC.Int import GHC.Integer (decodeDoubleInteger,encodeDoubleInteger)+import GHC.Integer.GMP.Internals (Integer (..), BigNat (..)) import GHC.Prim import GHC.Real (Ratio (..)) import GHC.TypeLits (KnownNat)+import GHC.Types (IO (..)) import GHC.Word+import System.IO.Unsafe (unsafeDupablePerformIO) import qualified Unbound.Generics.LocallyNameless.Name as U import Unbound.Generics.LocallyNameless (Fresh (..), bind, embed, rebind, runFreshM, makeName)@@ -575,6 +581,194 @@ r = float2Double# a in reduce . Literal . DoubleLiteral . toRational $ D# r ++ "GHC.Prim.newByteArray#"+ | [iV,PrimVal rwNm rwTy _ _] <- args+ , [i] <- intLiterals' [iV]+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = HashMap.lookup (nameOcc tupTcNm) tcm+ [tupDc] = tyConDataCons tupTc+ Heap (gh,p) ph ids = h+ lit = Literal (ByteArrayLiteral (Vector.replicate (fromInteger i) 0))+ h' = Heap (IntMap.insert p lit gh,p+1) ph ids+ mbaTy = mkFunTy intPrimTy (last tyArgs)+ newE = mkApps (Data tupDc) (map Right tyArgs +++ [Left (Prim rwNm rwTy)+ ,Left (mkApps (Prim "GHC.Prim.MutableByteArray#" mbaTy)+ [Left (Literal . IntLiteral $ toInteger p)])+ ])+ in Just (h',k,newE)++ "GHC.Prim.setByteArray#"+ | [PrimVal _mbaNm _mbaTy _ [baV]+ ,offV,lenV,cV+ ,PrimVal rwNm rwTy _ _+ ] <- args+ , [ba,off,len,c] <- intLiterals' [baV,offV,lenV,cV]+ -> let Heap (gh,p) ph ids = h+ Just (Literal (ByteArrayLiteral (Vector.Vector voff vlen ba1))) =+ IntMap.lookup (fromInteger ba) gh+ !(I# off') = fromInteger off+ !(I# len') = fromInteger len+ !(I# c') = fromInteger c+ ba2 = unsafeDupablePerformIO $ do+ ByteArray.MutableByteArray mba <- ByteArray.unsafeThawByteArray ba1+ svoid (setByteArray# mba off' len' c')+ ByteArray.unsafeFreezeByteArray (ByteArray.MutableByteArray mba)+ ba3 = Literal (ByteArrayLiteral (Vector.Vector voff vlen ba2))+ h' = Heap (IntMap.insert (fromInteger ba) ba3 gh,p) ph ids+ in Just (h',k,Prim rwNm rwTy)++ "GHC.Prim.writeWordArray#"+ | [PrimVal _mbaNm _mbaTy _ [baV]+ ,iV,wV+ ,PrimVal rwNm rwTy _ _+ ] <- args+ , [ba,i] <- intLiterals' [baV,iV]+ , [w] <- wordLiterals' [wV]+ -> let Heap (gh,p) ph ids = h+ Just (Literal (ByteArrayLiteral (Vector.Vector off len ba1))) =+ IntMap.lookup (fromInteger ba) gh+ !(I# i') = fromInteger i+ !(W# w') = fromIntegral w+ ba2 = unsafeDupablePerformIO $ do+ ByteArray.MutableByteArray mba <- ByteArray.unsafeThawByteArray ba1+ svoid (writeWordArray# mba i' w')+ ByteArray.unsafeFreezeByteArray (ByteArray.MutableByteArray mba)+ ba3 = Literal (ByteArrayLiteral (Vector.Vector off len ba2))+ h' = Heap (IntMap.insert (fromInteger ba) ba3 gh,p) ph ids+ in Just (h',k,Prim rwNm rwTy)++ "GHC.Prim.unsafeFreezeByteArray#"+ | [PrimVal _mbaNm _mbaTy _ [baV]+ ,PrimVal rwNm rwTy _ _+ ] <- args+ , [ba] <- intLiterals' [baV]+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = HashMap.lookup (nameOcc tupTcNm) tcm+ [tupDc] = tyConDataCons tupTc+ Heap (gh,_) _ _ = h+ Just ba' = IntMap.lookup (fromInteger ba) gh+ in reduce $ mkApps (Data tupDc) (map Right tyArgs +++ [Left (Prim rwNm rwTy)+ ,Left ba'])++ "GHC.Prim.sizeofByteArray#"+ | [Lit (ByteArrayLiteral ba)] <- args+ -> reduce (Literal (IntLiteral (toInteger (Vector.length ba))))++ "GHC.Prim.indexWordArray#"+ | [Lit (ByteArrayLiteral (Vector.Vector _ _ (ByteArray.ByteArray ba))),iV] <- args+ , [i] <- intLiterals' [iV]+ -> let !(I# i') = fromInteger i+ !w = indexWordArray# ba i'+ in reduce (Literal (WordLiteral (toInteger (W# w))))++ "GHC.Prim.getSizeofMutBigNat#"+ | [PrimVal _mbaNm _mbaTy _ [baV]+ ,PrimVal rwNm rwTy _ _+ ] <- args+ , [ba] <- intLiterals' [baV]+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = HashMap.lookup (nameOcc tupTcNm) tcm+ [tupDc] = tyConDataCons tupTc+ Heap (gh,_) _ _ = h+ Just (Literal (ByteArrayLiteral ba')) = IntMap.lookup (fromInteger ba) gh+ lit = Literal (IntLiteral (toInteger (Vector.length ba')))+ in reduce $ mkApps (Data tupDc) (map Right tyArgs +++ [Left (Prim rwNm rwTy)+ ,Left lit])++ "GHC.Prim.resizeMutableByteArray#"+ | [PrimVal mbaNm mbaTy _ [baV]+ ,iV+ ,PrimVal rwNm rwTy _ _+ ] <- args+ , [ba,i] <- intLiterals' [baV,iV]+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = HashMap.lookup (nameOcc tupTcNm) tcm+ [tupDc] = tyConDataCons tupTc+ Heap (gh,p) ph ids = h+ Just (Literal (ByteArrayLiteral (Vector.Vector 0 _ ba1)))+ = IntMap.lookup (fromInteger ba) gh+ !(I# i') = fromInteger i+ ba2 = unsafeDupablePerformIO $ do+ ByteArray.MutableByteArray mba <- ByteArray.unsafeThawByteArray ba1+ mba' <- IO (\s -> case resizeMutableByteArray# mba i' s of+ (# s', mba' #) -> (# s', ByteArray.MutableByteArray mba' #))+ ByteArray.unsafeFreezeByteArray mba'+ ba3 = Literal (ByteArrayLiteral (Vector.Vector 0 (I# i') ba2))+ h' = Heap (IntMap.insert p ba3 gh,p+1) ph ids+ newE = mkApps (Data tupDc) (map Right tyArgs +++ [Left (Prim rwNm rwTy)+ ,Left (mkApps (Prim mbaNm mbaTy)+ [Left (Literal . IntLiteral $ toInteger p)])+ ])+ in Just (h',k,newE)++ "GHC.Prim.shrinkMutableByteArray#"+ | [PrimVal _mbaNm _mbaTy _ [baV]+ ,lenV+ ,PrimVal rwNm rwTy _ _+ ] <- args+ , [ba,len] <- intLiterals' [baV,lenV]+ -> let Heap (gh,p) ph ids = h+ Just (Literal (ByteArrayLiteral (Vector.Vector voff vlen ba1))) =+ IntMap.lookup (fromInteger ba) gh+ !(I# len') = fromInteger len+ ba2 = unsafeDupablePerformIO $ do+ ByteArray.MutableByteArray mba <- ByteArray.unsafeThawByteArray ba1+ svoid (shrinkMutableByteArray# mba len')+ ByteArray.unsafeFreezeByteArray (ByteArray.MutableByteArray mba)+ ba3 = Literal (ByteArrayLiteral (Vector.Vector voff vlen ba2))+ h' = Heap (IntMap.insert (fromInteger ba) ba3 gh,p) ph ids+ in Just (h',k,Prim rwNm rwTy)++ "GHC.Prim.copyByteArray#"+ | [Lit (ByteArrayLiteral (Vector.Vector _ _ (ByteArray.ByteArray src_ba)))+ ,src_offV+ ,PrimVal _mbaNm _mbaTy _ [dst_mbaV]+ ,dst_offV, nV+ ,PrimVal rwNm rwTy _ _+ ] <- args+ , [src_off,dst_mba,dst_off,n] <- intLiterals' [src_offV,dst_mbaV,dst_offV,nV]+ -> let Heap (gh,p) ph ids = h+ Just (Literal (ByteArrayLiteral (Vector.Vector voff vlen dst_ba))) =+ IntMap.lookup (fromInteger dst_mba) gh+ !(I# src_off') = fromInteger src_off+ !(I# dst_off') = fromInteger dst_off+ !(I# n') = fromInteger n+ ba2 = unsafeDupablePerformIO $ do+ ByteArray.MutableByteArray dst_mba1 <- ByteArray.unsafeThawByteArray dst_ba+ svoid (copyByteArray# src_ba src_off' dst_mba1 dst_off' n')+ ByteArray.unsafeFreezeByteArray (ByteArray.MutableByteArray dst_mba1)+ ba3 = Literal (ByteArrayLiteral (Vector.Vector voff vlen ba2))+ h' = Heap (IntMap.insert (fromInteger dst_mba) ba3 gh,p) ph ids+ in Just (h',k,Prim rwNm rwTy)++ "GHC.Prim.readWordArray#"+ | [PrimVal _mbaNm _mbaTy _ [baV]+ ,offV+ ,PrimVal rwNm rwTy _ _+ ] <- args+ , [ba,off] <- intLiterals' [baV,offV]+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = HashMap.lookup (nameOcc tupTcNm) tcm+ [tupDc] = tyConDataCons tupTc+ Heap (gh,_) _ _ = h+ Just (Literal (ByteArrayLiteral (Vector.Vector _ _ ba1))) =+ IntMap.lookup (fromInteger ba) gh+ !(I# off') = fromInteger off+ w = unsafeDupablePerformIO $ do+ ByteArray.MutableByteArray mba <- ByteArray.unsafeThawByteArray ba1+ IO (\s -> case readWordArray# mba off' s of+ (# s', w' #) -> (# s', W# w' #))+ newE = mkApps (Data tupDc) (map Right tyArgs +++ [Left (Prim rwNm rwTy)+ ,Left (Literal (WordLiteral (toInteger w)))+ ])+ in reduce newE+ -- decodeFloat_Int# :: Float# -> (#Int#, Int##) "GHC.Prim.decodeFloat_Int#" | [i] <- floatLiterals' args -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty@@ -632,7 +826,7 @@ -> reduce (Literal (IntegerLiteral i)) "GHC.Integer.Type.integerToInt"- | [Lit (IntegerLiteral i)] <- args+ | [i] <- integerLiterals' args -> reduce (integerToIntLiteral i) "GHC.Integer.Type.decodeDoubleInteger" -- :: Double# -> (#Integer, Int##)@@ -648,13 +842,14 @@ , Left (integerToIntLiteral . toInteger $ I# c)]) "GHC.Integer.Type.encodeDoubleInteger" -- :: Integer -> Int# -> Double#- | [Lit (IntegerLiteral i), Lit (IntLiteral j)] <- args+ | [iV, Lit (IntLiteral j)] <- args+ , [i] <- integerLiterals' [iV] -> let !(I# k') = fromInteger j r = encodeDoubleInteger i k' in reduce . Literal . DoubleLiteral . toRational $ D# r "GHC.Integer.Type.quotRemInteger" -- :: Integer -> Integer -> (#Integer, Integer#)- | [Lit (IntegerLiteral i), Lit (IntegerLiteral j)] <- args+ | [i, j] <- integerLiterals' args -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty (Just tupTc) = HashMap.lookup (nameOcc tupTcNm) tcm [tupDc] = tyConDataCons tupTc@@ -674,7 +869,7 @@ -> reduce (integerToIntegerLiteral (i*j)) "GHC.Integer.Type.negateInteger"- | [Lit (IntegerLiteral i)] <- args+ | [i] <- integerLiterals' args -> reduce (integerToIntegerLiteral (negate i)) "GHC.Integer.Type.divInteger" | Just (i,j) <- integerLiterals args@@ -738,11 +933,13 @@ -> reduce (boolToIntLiteral (i <= j)) "GHC.Integer.Type.shiftRInteger"- | [Lit (IntegerLiteral i), Lit (IntLiteral j)] <- args+ | [iV, Lit (IntLiteral j)] <- args+ , [i] <- integerLiterals' [iV] -> reduce (integerToIntegerLiteral (i `shiftR` fromInteger j)) "GHC.Integer.Type.shiftLInteger"- | [Lit (IntegerLiteral i), Lit (IntLiteral j)] <- args+ | [iV, Lit (IntLiteral j)] <- args+ , [i] <- integerLiterals' [iV] -> reduce (integerToIntegerLiteral (i `shiftL` fromInteger j)) "GHC.Integer.Type.wordToInteger"@@ -756,10 +953,11 @@ -- GHC.Real.^ -- XXX: Very fragile -- ^_f, $wf, $wf1 are specialisations of the internal function f in the implementation of (^) in GHC.Real "GHC.Real.^_f" -- :: Integer -> Integer -> Integer- | [Lit (IntegerLiteral i), Lit (IntegerLiteral j)] <- args+ | [i,j] <- integerLiterals' args -> reduce (integerToIntegerLiteral $ i ^ j) "GHC.Real.$wf" -- :: Integer -> Int# -> Integer- | [Lit (IntegerLiteral i), Lit (IntLiteral j)] <- args+ | [iV, Lit (IntLiteral j)] <- args+ , [i] <- integerLiterals' [iV] -> reduce (integerToIntegerLiteral $ i ^ j) "GHC.Real.$wf1" -- :: Int# -> Int# -> Int# | [Lit (IntLiteral i), Lit (IntLiteral j)] <- args@@ -856,8 +1054,9 @@ "GHC.Float.$w$sfromRat''" -- XXX: Very fragile | [Lit (IntLiteral _minEx) ,Lit (IntLiteral matDigs)- ,Lit (IntegerLiteral n)- ,Lit (IntegerLiteral d)] <- args+ ,nV+ ,dV] <- args+ , [n,d] <- integerLiterals' [nV,dV] -> case fromInteger matDigs of matDigs' | matDigs' == floatDigits (undefined :: Float)@@ -869,8 +1068,9 @@ "GHC.Float.$w$sfromRat''1" -- XXX: Very fragile | [Lit (IntLiteral _minEx) ,Lit (IntLiteral matDigs)- ,Lit (IntegerLiteral n)- ,Lit (IntegerLiteral d)] <- args+ ,nV+ ,dV] <- args+ , [n,d] <- integerLiterals' [nV,dV] -> case fromInteger matDigs of matDigs' | matDigs' == floatDigits (undefined :: Float)@@ -880,7 +1080,7 @@ _ -> error $ $(curLoc) ++ "GHC.Float.$w$sfromRat'': Not a Float or Double" "GHC.Integer.Type.doubleFromInteger"- | [Lit (IntegerLiteral i)] <- args+ | [i] <- integerLiterals' args -> reduce (Literal (DoubleLiteral (toRational (fromInteger i :: Double)))) "GHC.Base.eqString"@@ -2665,7 +2865,7 @@ , Right n <- runExcept (tyNatSize tcm nTy) -> case n of 0 -> let (pureF,ids') = runPEM (mkSelectorCase $(curLoc) tcm (valToTerm apDict) 1 1) ids- in reduceWHNF' (Heap h' ids') $+ in reduceWHNF' (Heap gh h' ids') $ mkApps pureF [Right (mkTyConApp (vecTcNm) [nTy,bTy]) ,Left (mkVecNil dc bTy)]@@ -2676,7 +2876,7 @@ return (fmapF',apF') n'ty = LitTy (NumTy (n-1)) Just (consCoTy : _) = dataConInstArgTys dc [nTy,bTy,n'ty]- in reduceWHNF' (Heap h' ids') $+ in reduceWHNF' (Heap gh h' ids') $ mkApps apF [Right (mkTyConApp vecTcNm [n'ty,bTy]) ,Right (mkTyConApp vecTcNm [nTy,bTy])@@ -2705,7 +2905,7 @@ where (tyArgs,_) = splitFunForallTy ty TyConApp vecTcNm _ = tyView (Either.rights tyArgs !! 2)- Heap h' ids = h+ Heap gh h' ids = h -- BitPack "Clash.Sized.Vector.concatBitVector#"@@ -2809,10 +3009,25 @@ _ -> Nothing integerLiterals :: [Value] -> Maybe (Integer,Integer)-integerLiterals args = case args of- [Lit (IntegerLiteral i), Lit (IntegerLiteral j)] -> Just (i,j)+integerLiterals args = case integerLiterals' args of+ [i,j] -> Just (i,j) _ -> Nothing +integerLiterals' :: [Value] -> [Integer]+integerLiterals' = typedLiterals' integerLiteral+ where+ integerLiteral x = case x of+ Lit (IntegerLiteral i) -> Just i+ DC dc [Left (Literal (IntLiteral i))]+ | dcTag dc == 1+ -> Just i+ DC dc [Left (Literal (ByteArrayLiteral (Vector.Vector _ _ (ByteArray.ByteArray ba))))]+ | dcTag dc == 2+ -> Just (Jp# (BN# ba))+ | dcTag dc == 3+ -> Just (Jn# (BN# ba))+ _ -> Nothing+ intLiterals :: [Value] -> Maybe (Integer,Integer) intLiterals args = case args of [Lit (IntLiteral i), Lit (IntLiteral j)] -> Just (i,j)@@ -2878,7 +3093,7 @@ bitLiterals = typedLiterals' go where go val = case val of- PrimVal nm _ _ [_, Lit (IntegerLiteral i)]+ PrimVal nm _ _ [Lit (IntegerLiteral i)] | nm == "Clash.Sized.Internal.BitVector.fromInteger##" -> Just i _ -> Nothing@@ -3526,3 +3741,6 @@ n' = fromMaybe "_INTERNAL_" (modNameM n) ++ ('.':occName) occName = occNameString $ nameOccName n n = TyCon.tyConName tc++svoid :: (State# RealWorld -> State# RealWorld) -> IO ()+svoid m0 = IO (\s -> case m0 s of s' -> (# s', () #))
src-ghc/Clash/GHC/GHC2Core.hs view
@@ -855,7 +855,7 @@ (C.FunTy rwTy _) = C.tyView fTy fName = C.string2SystemName "f" fId = C.Id fName (embed fTy)- rwNm = pack "Clash.GHC.GHC2Core.realWorld#"+ rwNm = pack "GHC.Prim.realWorld#" runRWTerm ty = error $ $(curLoc) ++ show ty