diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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) diff --git a/clash-ghc.cabal b/clash-ghc.cabal --- a/clash-ghc.cabal +++ b/clash-ghc.cabal @@ -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 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 @@ -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', () #)) 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 @@ -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