copilot-bluespec 3.20 → 4.0
raw patch · 4 files changed
+207/−17 lines, 4 filesdep +extradep ~copilot-corePVP ok
version bump matches the API change (PVP)
Dependencies added: extra
Dependency ranges changed: copilot-core
API changes (from Hackage documentation)
Files
- CHANGELOG +7/−0
- copilot-bluespec.cabal +3/−2
- src/Copilot/Compile/Bluespec/Expr.hs +13/−6
- tests/Test/Copilot/Compile/Bluespec.hs +184/−9
CHANGELOG view
@@ -1,3 +1,10 @@+2024-09-09+ * Version bump (4.0). (#23)+ * Support translating Copilot array updates to Bluespec. (#19)++2024-08-03+ * Test GHC 9.4 through 9.8. (#20)+ 2024-07-11 * Version bump (3.20). (#11) * Support translating Copilot struct updates to Bluespec (#10).
copilot-bluespec.cabal view
@@ -1,6 +1,6 @@ cabal-version : >= 1.10 name : copilot-bluespec-version : 3.20+version : 4.0 synopsis : A compiler for Copilot targeting FPGAs. description : This package is a back-end from Copilot to FPGAs in Bluespec.@@ -44,7 +44,7 @@ , filepath >= 1.4 && < 1.5 , pretty >= 1.1.2 && < 1.2 - , copilot-core >= 3.20 && < 3.21+ , copilot-core >= 4.0 && < 4.1 , language-bluespec >= 0.1 && < 0.2 exposed-modules : Copilot.Compile.Bluespec@@ -75,6 +75,7 @@ , directory , HUnit , QuickCheck+ , extra , ieee754 , pretty , process
src/Copilot/Compile/Bluespec/Expr.hs view
@@ -158,6 +158,7 @@ transOp3 op e1 e2 e3 = case op of Mux _ -> BS.Cif BS.NoPos e1 e2 e3+ UpdateArray _ -> cUpdateVector e1 e2 e3 -- | Translate @'Sign' e@ in Copilot Core into a Bluespec expression. --@@ -576,12 +577,10 @@ foldl' (\(!i, !v) x -> ( i+1- , BS.CApply- (BS.CVar (BS.mkId BS.NoPos "update"))- [ v- , cLit (BS.LInt (BS.ilDec (toInteger i)))- , f i x- ]+ , cUpdateVector+ v+ (cLit (BS.LInt (BS.ilDec (toInteger i))))+ (f i x) )) (0, BS.CVar (BS.mkId BS.NoPos "newVector")) vec@@ -629,6 +628,14 @@ cIndexVector :: BS.CExpr -> BS.CExpr -> BS.CExpr cIndexVector vec idx = BS.CApply (BS.CVar (BS.mkId BS.NoPos "select")) [vec, idx]++-- | Create a Bluespec expression that updates a @Vector@ element at a+-- particular index.+cUpdateVector :: BS.CExpr -> BS.CExpr -> BS.CExpr -> BS.CExpr+cUpdateVector vec idx newElem =+ BS.CApply+ (BS.CVar (BS.mkId BS.NoPos "update"))+ [vec, idx, newElem] -- | Explicitly annotate an expression with a type signature. This is necessary -- to prevent expressions from having ambiguous types in certain situations.
tests/Test/Copilot/Compile/Bluespec.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wno-orphans #-} -- | Test copilot-bluespec:Copilot.Compile.Bluespec. module Test.Copilot.Compile.Bluespec ( tests )@@ -14,7 +15,8 @@ import Data.AEq (AEq (..)) import Data.Bits (Bits, complement) import Data.Foldable (foldl')-import Data.List (intercalate)+import Data.List (intercalate, stripPrefix)+import Data.List.Extra (stripSuffix) import Data.Type.Equality (testEquality) import Data.Typeable (Proxy (..), (:~:) (Refl)) import GHC.Float (castDoubleToWord64,@@ -217,8 +219,9 @@ .&&. testRunCompare1 (arbitraryOpFloatingBool :: Gen (TestCase1 Double Bool)) .&&. testRunCompare1 (arbitraryOpStruct :: Gen (TestCase1 MyStruct Int8)) .&&. testRunCompare2 (arbitraryOp2Struct :: Gen (TestCase2 MyStruct Int8 MyStruct))- .&&. testRunCompare2 (arbitraryArrayNum :: Gen (TestCase2 (Array 2 Int8) Word32 Int8))- .&&. testRunCompare2 (arbitraryArrayNum :: Gen (TestCase2 (Array 2 Int16) Word32 Int16))+ .&&. testRunCompare2 (arbitraryArray2Num :: Gen (TestCase2 (Array 2 Int8) Word32 Int8))+ .&&. testRunCompare2 (arbitraryArray2Num :: Gen (TestCase2 (Array 2 Int16) Word32 Int16))+ .&&. testRunCompare3 (arbitraryArray3Num :: Gen (TestCase3 (Array 2 Int16) Word32 Int16 (Array 2 Int16))) -- * Regression tests @@ -395,6 +398,20 @@ arbitraryArrayIx = return (Op2 (Index typeOf), zipWith (\x y -> arrayElems x !! fromIntegral y)) +-- | Generator of functions that take arrays, indices, and values, and then+-- produce new arrays by updating the elements at the indices with the values.+arbitraryArrayUpdate :: forall t n . (Typed t, KnownNat n, Num t)+ => Gen ( Fun3 (Array n t) Word32 t (Array n t)+ , [Array n t] -> [Word32] -> [t] -> [Array n t]+ )+arbitraryArrayUpdate = return+ (Op3 (UpdateArray typeOf), zipWith3 (\x y z -> array (updateAt y z (arrayElems x))))+ where+ updateAt :: forall a. Word32 -> a -> [a] -> [a]+ updateAt _ _ [] = []+ updateAt 0 x (_ : as) = x : as+ updateAt n x (a : as) = a : updateAt (n-1) x as+ -- | Generator of functions that take structs produce fields of the struct. arbitraryStructField :: Gen ( Fun MyStruct Int8 , [MyStruct] -> [Int8]@@ -526,10 +543,10 @@ -- | Generator for test cases on Arrays selection producing values of the -- array.-arbitraryArrayNum :: forall n a+arbitraryArray2Num :: forall n a . (KnownNat n, Num a, Random a, Typed a) => Gen (TestCase2 (Array n a) Word32 a)-arbitraryArrayNum = oneof+arbitraryArray2Num = oneof [ mkTestCase2 arbitraryArrayIx arbitraryArray gen ] where@@ -539,6 +556,20 @@ len :: Word32 len = fromIntegral $ natVal (Proxy :: Proxy n) +-- | Generator for test cases on Arrays which update values of the array.+arbitraryArray3Num :: forall n a+ . (KnownNat n, Num a, Random a, Typed a)+ => Gen (TestCase3 (Array n a) Word32 a (Array n a))+arbitraryArray3Num = oneof+ [ mkTestCase3 arbitraryArrayUpdate arbitraryArray gen chooseAny+ ]+ where+ gen :: Gen Word32+ gen = choose (0, len - 1)++ len :: Word32+ len = fromIntegral $ natVal (Proxy :: Proxy n)+ -- | Generator for test cases on structs that produce fields of the struct. arbitraryOpStruct :: Gen (TestCase1 MyStruct Int8) arbitraryOpStruct = oneof@@ -570,6 +601,9 @@ -- | Binary Copilot function. type Fun2 a b c = Expr a -> Expr b -> Expr c +-- | Ternary Copilot function.+type Fun3 a b c d = Expr a -> Expr b -> Expr c -> Expr d+ -- | Compose functions, paired with the Haskell functions that define their -- idealized meaning. funCompose1 :: (Fun b c, [b] -> [c])@@ -590,8 +624,7 @@ -- | Test case specification for specs with one input variable and one output. data TestCase1 a b = TestCase1 { wrapTC1Expr :: Spec- -- ^ Specification containing a trigger an extern of type 'a' and a trigger- -- with an argument of type 'b'.+ -- ^ Specification containing a trigger with an extern of type 'a'. , wrapTC1Fun :: [a] -> [b] -- ^ Function expected to function in the same way as the Spec being@@ -614,8 +647,8 @@ -- | Test case specification for specs with two input variables and one output. data TestCase2 a b c = TestCase2 { wrapTC2Expr :: Spec- -- ^ Specification containing a trigger an extern of type 'a' and a trigger- -- with an argument of type 'b'.+ -- ^ Specification containing a trigger with an extern of type 'a' and a+ -- trigger with an argument of type 'b'. , wrapTC2Fun :: [a] -> [b] -> [c] -- ^ Function expected to function in the same way as the Spec being@@ -645,6 +678,51 @@ -- ^ The type of the output in Bluespec. } +-- | Test case specification for specs with three input variables and one output.+data TestCase3 a b c d = TestCase3+ { wrapTC3Expr :: Spec+ -- ^ Specification containing a trigger with an extern of type 'a', a+ -- trigger with an argument of type 'b', and a trigger with an argument of+ -- type 'c'.++ , wrapTC3Fun :: [a] -> [b] -> [c] -> [d]+ -- ^ Function expected to function in the same way as the Spec being+ -- tested.++ , wrapTC3CopInp1 :: (Type a, String, Gen a)+ -- ^ Input specification for the first input.+ --+ -- - The first element contains the type of the input in Bluespec.+ --+ -- - The second contains the variable name in Bluespec.+ --+ -- - The latter contains a randomized generator for values of the given+ -- type.++ , wrapTC3CopInp2 :: (Type b, String, Gen b)+ -- ^ Input specification for the second input.+ --+ -- - The first element contains the type of the input in Bluespec.+ --+ -- - The second contains the variable name in Bluespec.+ --+ -- - The latter contains a randomized generator for values of the given+ -- type.++ , wrapTC3CopInp3 :: (Type c, String, Gen c)+ -- ^ Input specification for the second input.+ --+ -- - The first element contains the type of the input in Bluespec.+ --+ -- - The second contains the variable name in Bluespec.+ --+ -- - The latter contains a randomized generator for values of the given+ -- type.++ , wrapTC3CopOut :: Type d+ -- ^ The type of the output in Bluespec.+ }+ -- | Generate test cases for expressions that behave like unary functions. mkTestCase1 :: (Typed a, Typed b) => Gen (Fun a b, [a] -> [b])@@ -702,6 +780,42 @@ varName1 = "input1" varName2 = "input2" +-- | Generate test cases for expressions that behave like ternary functions.+mkTestCase3 :: (Typed a, Typed b, Typed c, Typed d)+ => Gen (Fun3 a b c d, [a] -> [b] -> [c] -> [d])+ -> Gen a+ -> Gen b+ -> Gen c+ -> Gen (TestCase3 a b c d)+mkTestCase3 genO genA genB genC = do+ (copilotF, semF) <- genO++ let spec = alwaysTriggerArg1 (UExpr t4 appliedOp)+ appliedOp = copilotF (ExternVar t1 varName1 Nothing)+ (ExternVar t2 varName2 Nothing)+ (ExternVar t3 varName3 Nothing)++ return $+ TestCase3+ { wrapTC3Expr = spec+ , wrapTC3Fun = semF+ , wrapTC3CopInp1 = ( t1, varName1, genA )+ , wrapTC3CopInp2 = ( t2, varName2, genB )+ , wrapTC3CopInp3 = ( t3, varName3, genC )+ , wrapTC3CopOut = t4+ }++ where++ t1 = typeOf+ t2 = typeOf+ t3 = typeOf+ t4 = typeOf++ varName1 = "input1"+ varName2 = "input2"+ varName3 = "input3"+ -- | Test running a compiled Bluespec program and comparing the results. testRunCompare1 :: (Show a, Typed a, DisplayableInBluespec b, ReadableFromBluespec b,@@ -768,6 +882,48 @@ testRunCompareArg inputs len outputs copilotSpec (typeBluespec outputType) +-- | Test running a compiled Bluespec program and comparing the results.+testRunCompare3 :: (Show a1, Typed a1, Show a2, Typed a2, Show a3, Typed a3,+ DisplayableInBluespec b, ReadableFromBluespec b,+ AEq b, Typed b)+ => Gen (TestCase3 a1 a2 a3 b) -> Property+testRunCompare3 ops =+ forAllBlind ops $ \testCase ->+ let (TestCase3+ { wrapTC3Expr = copilotSpec+ , wrapTC3Fun = haskellFun+ , wrapTC3CopInp1 = inputVar1+ , wrapTC3CopInp2 = inputVar2+ , wrapTC3CopInp3 = inputVar3+ , wrapTC3CopOut = outputType+ }) =+ testCase++ (bluespecTypeInput1, bluespecInputName1, gen1) = inputVar1+ (bluespecTypeInput2, bluespecInputName2, gen2) = inputVar2+ (bluespecTypeInput3, bluespecInputName3, gen3) = inputVar3++ in forAll (getPositive <$> arbitrary) $ \len ->+ forAll (vectorOf len gen1) $ \vals1 ->+ forAll (vectorOf len gen2) $ \vals2 ->+ forAll (vectorOf len gen3) $ \vals3 -> do+ let inputs = filterOutUnusedExts+ copilotSpec+ [ (typeBluespec bluespecTypeInput1,+ fmap (bluespecShow bluespecTypeInput1) vals1,+ bluespecInputName1)+ , (typeBluespec bluespecTypeInput2,+ fmap (bluespecShow bluespecTypeInput2) vals2,+ bluespecInputName2)+ , (typeBluespec bluespecTypeInput3,+ fmap (bluespecShow bluespecTypeInput3) vals3,+ bluespecInputName3)+ ]+ outputs = haskellFun vals1 vals2 vals3++ testRunCompareArg+ inputs len outputs copilotSpec (typeBluespec outputType)+ -- | Test running a compiled Bluespec program and comparing the results, when -- the program produces one output as an argument to a trigger that always -- fires.@@ -1167,6 +1323,9 @@ instance DisplayableInBluespec Double where displayInBluespec = hexFloatDisplay +instance DisplayableInBluespec a => DisplayableInBluespec (Array n a) where+ displayInBluespec = fshowDisplay+ -- | @copilot-bluespec@–generated structs currently do not have @FShow@ -- instances. (Perhaps they should: see -- https://github.com/Copilot-Language/copilot-bluespec/issues/12)@@ -1219,6 +1378,14 @@ instance ReadableFromBluespec Double where readFromBluespec s = castWord64ToDouble $ read $ "0x" ++ s +instance (KnownNat n, ReadableFromBluespec a) => ReadableFromBluespec (Array n a) where+ readFromBluespec s0+ | Just s1 <- stripPrefix "<V" s0+ , Just s2 <- stripSuffix ">" s1+ = array $ map readFromBluespec $ words s2+ | otherwise+ = error $ "Unexpected Vector fshow output: " ++ s0+ instance ReadableFromBluespec MyStruct where readFromBluespec str = case readsEither (readsStruct minPrec) str of@@ -1234,6 +1401,14 @@ [x] -> Right x [] -> Left $ "readsEither: no parse: " ++ s _ -> Left $ "readsEither: ambiguous parse: " ++ s++-- ** Orphan instances for Arrays++instance Eq a => Eq (Array n a) where+ a1 == a2 = arrayElems a1 == arrayElems a2++instance AEq a => AEq (Array n a) where+ a1 === a2 = arrayElems a1 === arrayElems a2 -- ** A simple struct definition for unit testing purposes