copilot-c99-3.19.1/0000755000000000000000000000000014616626046012061 5ustar0000000000000000copilot-c99-3.19.1/README.md0000644000000000000000000000255214616626046013344 0ustar0000000000000000[![Build Status](https://travis-ci.com/Copilot-Language/copilot.svg?branch=master)](https://app.travis-ci.com/github/Copilot-Language/copilot) # Copilot: a stream DSL Copilot-c99 implements a C99 backend for Copilot, producing high quality code suitable for hard realtime applications. Copilot is a runtime verification framework written in Haskell. It allows the user to write programs in a simple but powerful way using a stream-based approach. Programs can be interpreted for testing, or translated C99 code to be incorporated in a project, or as a standalone application. The C99 backend ensures us that the output is constant in memory and time, making it suitable for systems with hard realtime requirements. ## Installation Copilot-c99 can be found on [Hackage](https://hackage.haskell.org/package/copilot-c99). It is typically only installed as part of the complete Copilot distribution. For installation instructions, please refer to the [Copilot website](https://copilot-language.github.io). ## Further information For further information, install instructions and documentation, please visit the Copilot website: [https://copilot-language.github.io](https://copilot-language.github.io) ## License Copilot is distributed under the BSD-3-Clause license, which can be found [here](https://raw.githubusercontent.com/Copilot-Language/copilot/master/copilot-c99/LICENSE). copilot-c99-3.19.1/copilot-c99.cabal0000644000000000000000000000555014616626046015125 0ustar0000000000000000cabal-version : >= 1.10 name : copilot-c99 version : 3.19.1 synopsis : A compiler for Copilot targeting C99. description : This package is a back-end from Copilot to C. . Copilot is a stream (i.e., infinite lists) domain-specific language (DSL) in Haskell that compiles into embedded C. Copilot contains an interpreter, multiple back-end compilers, and other verification tools. . A tutorial, examples, and other information are available at . license : BSD3 license-file : LICENSE maintainer : Ivan Perez homepage : https://copilot-language.github.io bug-reports : https://github.com/Copilot-Language/copilot/issues stability : Experimental category : Language, Embedded build-type : Simple extra-source-files : README.md , CHANGELOG author : Frank Dedden , Alwyn Goodloe , Ivan Perez x-curation: uncurated source-repository head type: git location: https://github.com/Copilot-Language/copilot.git subdir: copilot-c99 library default-language : Haskell2010 hs-source-dirs : src ghc-options : -Wall build-depends : base >= 4.9 && < 5 , directory >= 1.3 && < 1.4 , filepath >= 1.4 && < 1.5 , mtl >= 2.2 && < 2.4 , pretty >= 1.1 && < 1.2 , copilot-core >= 3.19.1 && < 3.20 , language-c99 >= 0.2.0 && < 0.3 , language-c99-simple >= 0.3 && < 0.4 exposed-modules : Copilot.Compile.C99 other-modules : Copilot.Compile.C99.Expr , Copilot.Compile.C99.Type , Copilot.Compile.C99.Error , Copilot.Compile.C99.Name , Copilot.Compile.C99.CodeGen , Copilot.Compile.C99.External , Copilot.Compile.C99.Compile , Copilot.Compile.C99.Settings test-suite unit-tests type: exitcode-stdio-1.0 main-is: Main.hs other-modules: Test.Copilot.Compile.C99 build-depends: base , directory , HUnit , QuickCheck , pretty , process , random , test-framework , test-framework-hunit , test-framework-quickcheck2 , unix , copilot-core , copilot-c99 hs-source-dirs: tests default-language: Haskell2010 ghc-options: -Wall copilot-c99-3.19.1/LICENSE0000644000000000000000000000263614616626046013075 0ustar00000000000000002009 BSD3 License terms Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. Neither the name of the developers nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. copilot-c99-3.19.1/Setup.hs0000644000000000000000000000005514616626046013515 0ustar0000000000000000import Distribution.Simple main = defaultMaincopilot-c99-3.19.1/CHANGELOG0000644000000000000000000001106714616626046013300 0ustar00000000000000002024-05-07 * Version bump (3.19.1). (#512) 2024-03-07 * Version bump (3.19). (#504) 2024-01-07 * Version bump (3.18.1). (#493) 2024-01-07 * Version bump (3.18). (#487) * Change return type of main generated for tests. (#468) * Print constants in tests using portable suffixes. (#471). * Pass output arrays as arguments to trigger argument functions. (#431) * Compliance with MISRA C 2023 / MISRA C 2012. (#472) 2023-11-07 * Version bump (3.17). (#466) * Replace uses of deprecated functions. (#457) 2023-09-07 * Version bump (3.16.1). (#455) * Clean code. (#453) 2023-07-07 * Version bump (3.16). (#448) * Introduce testing infrastructure. (#413) 2023-05-07 * Version bump (3.15). (#438) 2023-03-07 * Version bump (3.14). (#422) 2023-01-07 * Version bump (3.13). (#406) * Declare local array variables in generated guards as pointers. (#401) * Use pointer to pass output array as argument to generators. (#386) 2022-11-07 * Version bump (3.12). (#389) * Removed deprecated flag from cabal file. (#380) * Generate type declarations in separate header file. (#373) 2022-09-07 * Version bump (3.11). (#376) * Update to support language-c99-0.2.0. (#371) * Fix error handling buffers in generated code for 'step'. (#314) 2022-07-07 * Version bump (3.10). (#356) * Remove unnecessary dependencies from Cabal package. (#323) * Remove duplicated compiler option. (#328) * Pass structs by reference, not value, in handlers. (#305) * Relax version bounds of dependencies. (#335) * Update repo info in cabal file. (#333) 2022-05-06 * Version bump (3.9). (#320) * Compliance with style guide (partial). (#316) * Translate math operations taking type into account. (#263) * Fix issue with delays of streams of structs or arrays. (#276) * Fix issue in C99 implementation of signum. (#278) 2022-03-07 * Version bump (3.8). (#298) * Hide internal modules deprecated in Copilot 3.5. (#289) * Mark package as uncurated to avoid modification. (#288) 2022-01-07 * Version bump (3.7). (#287) * Guard against empty specs. (#274) * Make typetypes respect dependency order. (#275) 2021-11-07 * Version bump (3.6). (#264) * Introduce new ops atan2, ceiling, floor. (#246) * Allow customizing output directory. (#255) * Fix outdated/broken links. (#252) 2021-08-19 * Version bump (3.5). (#247) * Update travis domain in README. (#222) * Remove second element of pair FunEnv. (#170) * Allow customizing name of step function. (#64) * Update official maintainer. (#236) * Deprecate internal modules. (#237, #242) * Update source repo location. (#241) * Fix out-of-bounds array access. (#238) * Add I. Perez to author list. (#243) 2021-07-07 * Version bump (3.4). (#231) * Remove broken test. (#232) 2021-05-07 * Version bump (3.3). (#217) * Fix URL in bug-reports field in cabal file. (#215) * Remove unaccessible code. (#169) 2021-03-07 * Version bump (3.2.1). (#167) * Completed the documentation. (#171) 2020-12-06 * Version bump (3.2). * Implemented arrays in test driver (#176). * Fixed nested array initialisation bug (#173). * Fixed length of buffer allocation for n-dimensional arrays (#174). * Fixed printing of long ints in test suite (#177). * Fixed printing of unsigned ints in test suite (#177). * Fixed '-Wsequence-point' warnings from GCC (#179). * Split Property.hs (#180). * Removed 'Test' from module paths (#181). * Made compiletest take compiler options as an argument (#182). * Fixed problem with property and empty string in driver CSV (#183). * Added comma to output of driver to match the interpreter (#184). * Implemented basic quickcheck based testing (#185). 2020-03-30 * Version bump (3.1.2) * Fixed bug where stream buffers are updated too soon. (#188) * Updated description of cabal package. (#192) 2019-12-23 * Version bump (3.1.1). * Fixed bug with constant structs and arrays.(#200). 2019-11-22 * Version bump (3.1). * Remove ExternFun (#207). * Fix bug in code generation for local expression (#198). * Implement code generation for labels (trivially) (#199). copilot-c99-3.19.1/tests/0000755000000000000000000000000014616626046013223 5ustar0000000000000000copilot-c99-3.19.1/tests/Main.hs0000644000000000000000000000057714616626046014454 0ustar0000000000000000-- | Test copilot-c99. module Main where -- External imports import Test.Framework (Test, defaultMain) -- Internal library modules being tested import qualified Test.Copilot.Compile.C99 -- | Run all unit tests on copilot-c99. main :: IO () main = defaultMain tests -- | All unit tests in copilot-c99. tests :: [Test.Framework.Test] tests = [ Test.Copilot.Compile.C99.tests ] copilot-c99-3.19.1/tests/Test/0000755000000000000000000000000014616626046014142 5ustar0000000000000000copilot-c99-3.19.1/tests/Test/Copilot/0000755000000000000000000000000014616626046015553 5ustar0000000000000000copilot-c99-3.19.1/tests/Test/Copilot/Compile/0000755000000000000000000000000014616626046017143 5ustar0000000000000000copilot-c99-3.19.1/tests/Test/Copilot/Compile/C99.hs0000644000000000000000000007520714616626046020056 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} -- | Test copilot-c99:Copilot.Compile.C99. module Test.Copilot.Compile.C99 ( tests ) where -- External imports import Control.Arrow ((&&&)) import Control.Exception (IOException, catch) import Control.Monad (when) import Data.Bits (Bits, complement) import Data.List (intercalate) import Data.Type.Equality (testEquality) import Data.Typeable (Proxy (..), (:~:) (Refl)) import GHC.TypeLits (KnownNat, natVal) import System.Directory (doesFileExist, getTemporaryDirectory, removeDirectory, removeFile, setCurrentDirectory) import System.IO (hPutStrLn, stderr) import System.Posix.Temp (mkdtemp) import System.Process (callProcess, readProcess) import System.Random (Random) import Test.Framework (Test, testGroup) import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.QuickCheck (Arbitrary, Gen, Property, arbitrary, choose, elements, forAll, forAllBlind, frequency, getPositive, ioProperty, oneof, vectorOf, (.&&.)) import Test.QuickCheck.Gen (chooseAny, chooseBoundedIntegral) -- External imports: Copilot import Copilot.Core hiding (Property) import Copilot.Core.Type.Array (array) -- External imports: Modules being tested import Copilot.Compile.C99 (cSettingsOutputDirectory, compile, compileWith, mkDefaultCSettings) -- * Constants -- | All unit tests for copilot-core:Copilot.Core.Type. tests :: Test.Framework.Test tests = testGroup "Copilot.Compile.C99" [ testProperty "Compile specification" testCompile , testProperty "Compile specification in custom dir" testCompileCustomDir , testProperty "Run specification" testRun , testProperty "Run and compare results" testRunCompare ] -- * Individual tests -- | Test compiling a spec. testCompile :: Property testCompile = ioProperty $ do tmpDir <- getTemporaryDirectory setCurrentDirectory tmpDir testDir <- mkdtemp "copilot_test_" setCurrentDirectory testDir compile "copilot_test" spec r <- compileC "copilot_test" -- Remove file produced by GCC removeFile "copilot_test.o" -- Remove files produced by Copilot removeFile "copilot_test.c" removeFile "copilot_test.h" removeFile "copilot_test_types.h" setCurrentDirectory tmpDir removeDirectory testDir return r where spec = Spec streams observers triggers properties streams = [ Stream 0 [1] (Const Int8 1) Int8] observers = [] triggers = [ Trigger function guard args ] properties = [] function = "func" guard = Const Bool True args = [] -- | Test compiling a spec in a custom directory. testCompileCustomDir :: Property testCompileCustomDir = ioProperty $ do tmpDir <- getTemporaryDirectory setCurrentDirectory tmpDir testDir <- mkdtemp "copilot_test_" compileWith (mkDefaultCSettings { cSettingsOutputDirectory = testDir }) "copilot_test" spec setCurrentDirectory testDir r <- compileC "copilot_test" -- Remove file produced by GCC removeFile "copilot_test.o" -- Remove files produced by Copilot removeFile "copilot_test.c" removeFile "copilot_test.h" removeFile "copilot_test_types.h" setCurrentDirectory tmpDir removeDirectory testDir return r where spec = Spec streams observers triggers properties streams = [ Stream 0 [1] (Const Int8 1) Int8] observers = [] triggers = [ Trigger function guard args ] properties = [] function = "nop" guard = Const Bool True args = [] -- | Test compiling a spec and running the resulting program. -- -- The actual behavior is ignored. testRun :: Property testRun = ioProperty $ do tmpDir <- getTemporaryDirectory setCurrentDirectory tmpDir testDir <- mkdtemp "copilot_test_" setCurrentDirectory testDir compile "copilot_test" spec r <- compileC "copilot_test" let cProgram = unlines [ "#include \"copilot_test.h\"" , "" , "void nop () {" , "}" , "" , "int main () {" , " step();" , "}" ] writeFile "main.c" cProgram -- Compile a main program r2 <- compileExecutable "main" [ "copilot_test.o" ] callProcess "./main" [] -- Remove file produced by GCC removeFile "copilot_test.o" removeFile "main" -- Remove files produced "by hand" removeFile "main.c" -- Remove files produced by Copilot removeFile "copilot_test.c" removeFile "copilot_test.h" removeFile "copilot_test_types.h" setCurrentDirectory tmpDir removeDirectory testDir return $ r && r2 where spec = Spec streams observers triggers properties streams = [ Stream 0 [1] (Const Int8 1) Int8] observers = [] triggers = [ Trigger function guard args ] properties = [] function = "nop" guard = Const Bool True args = [] -- | Test running compiled spec and comparing the results to the -- expectation. testRunCompare :: Property testRunCompare = testRunCompare1 (arbitraryOpIntegralBool :: Gen (TestCase1 Int8 Bool)) .&&. testRunCompare1 (arbitraryOpIntegralBool :: Gen (TestCase1 Int16 Bool)) .&&. testRunCompare1 (arbitraryOpIntegralBool :: Gen (TestCase1 Int32 Bool)) .&&. testRunCompare1 (arbitraryOpIntegralBool :: Gen (TestCase1 Int64 Bool)) .&&. testRunCompare1 (arbitraryOpIntegralBool :: Gen (TestCase1 Word8 Bool)) .&&. testRunCompare1 (arbitraryOpIntegralBool :: Gen (TestCase1 Word16 Bool)) .&&. testRunCompare1 (arbitraryOpIntegralBool :: Gen (TestCase1 Word32 Bool)) .&&. testRunCompare1 (arbitraryOpIntegralBool :: Gen (TestCase1 Word64 Bool)) .&&. testRunCompare1 (arbitraryOpFloatingBool :: Gen (TestCase1 Float Bool)) .&&. testRunCompare1 (arbitraryOpFloatingBool :: Gen (TestCase1 Double Bool)) .&&. testRunCompare2 (arbitraryArrayNum :: Gen (TestCase2 (Array 2 Int8) Word32 Int8)) .&&. testRunCompare2 (arbitraryArrayNum :: Gen (TestCase2 (Array 2 Int16) Word32 Int16)) -- * Random generators -- ** Random function generators -- | Generator of functions that produce booleans. arbitraryOpBool :: Typed a => Gen (Fun a Bool, [a] -> [Bool]) arbitraryOpBool = frequency [ (5, arbitraryOp1Any) , (5, funCompose1 <$> arbitraryOp1Bool <*> arbitraryOpBool) , (2, funCompose2 <$> arbitraryOp2Bool <*> arbitraryOpBool <*> arbitraryOpBool) , (1, funCompose2 <$> arbitraryOp2Eq <*> arbitraryOpBool <*> arbitraryOpBool) , (1, funCompose2 <$> arbitraryOp2Ord <*> arbitraryOpBool <*> arbitraryOpBool) ] -- | Generator of functions that take Bits and produce booleans. arbitraryOpBoolBits :: (Typed a, Bits a) => Gen (Fun a Bool, [a] -> [Bool]) arbitraryOpBoolBits = frequency [ (1, funCompose2 <$> arbitraryOp2Eq <*> arbitraryOpBits <*> arbitraryOpBits) ] -- | Generator of functions that take Nums and produce booleans. arbitaryOpBoolOrdEqNum :: (Typed a, Eq a, Ord a, Num a) => Gen (Fun a Bool, [a] -> [Bool]) arbitaryOpBoolOrdEqNum = frequency [ (1, funCompose2 <$> arbitraryOp2Eq <*> arbitraryOpNum <*> arbitraryOpNum) , (1, funCompose2 <$> arbitraryOp2Ord <*> arbitraryOpNum <*> arbitraryOpNum) ] -- | Generator of functions that take Floating point numbers and produce -- booleans. arbitraryOpBoolEqNumFloat :: (Typed t, Eq t, Num t, Floating t) => Gen (Fun t Bool, [t] -> [Bool]) arbitraryOpBoolEqNumFloat = frequency [ (1, funCompose2 <$> arbitraryOp2Eq <*> arbitraryOpNum <*> arbitraryOpFloat) , (1, funCompose2 <$> arbitraryOp2Eq <*> arbitraryOpFloat <*> arbitraryOpNum) ] -- | Generator of functions that take and produce Bits. arbitraryOpBits :: (Bits t, Typed t) => Gen (Fun t t, [t] -> [t]) arbitraryOpBits = elements [ (Op1 (BwNot typeOf), fmap complement) ] -- | Generator of functions that take and produce Nums. arbitraryOpNum :: (Typed t, Num t) => Gen (Fun t t, [t] -> [t]) arbitraryOpNum = elements [ (Op1 (Abs typeOf), fmap abs) , (Op1 (Sign typeOf), fmap signum) ] -- | Generator of functions that take an arrays and indicates and produce -- elements from the array. arbitraryArrayIx :: forall t n . (Typed t, KnownNat n, Num t) => Gen ( Fun2 (Array n t) Word32 t , [Array n t] -> [Word32] -> [t] ) arbitraryArrayIx = return (Op2 (Index typeOf), zipWith (\x y -> arrayElems x !! fromIntegral y)) -- | Generator of functions on Floating point numbers. arbitraryOpFloat :: (Floating t, Typed t) => Gen (Fun t t, [t] -> [t]) arbitraryOpFloat = elements [ (Op1 (Exp typeOf), fmap exp) , (Op1 (Sqrt typeOf), fmap sqrt) , (Op1 (Log typeOf), fmap log) , (Op1 (Sin typeOf), fmap sin) , (Op1 (Tan typeOf), fmap tan) , (Op1 (Cos typeOf), fmap cos) , (Op1 (Asin typeOf), fmap asin) , (Op1 (Atan typeOf), fmap atan) , (Op1 (Acos typeOf), fmap acos) , (Op1 (Sinh typeOf), fmap sinh) , (Op1 (Tanh typeOf), fmap tanh) , (Op1 (Cosh typeOf), fmap cosh) , (Op1 (Asinh typeOf), fmap asinh) , (Op1 (Atanh typeOf), fmap atanh) , (Op1 (Acosh typeOf), fmap acosh) ] -- | Generator of functions on that produce elements of any type. arbitraryOp1Any :: forall a b . (Arbitrary b, Typed a, Typed b) => Gen (Fun a b, [a] -> [b]) arbitraryOp1Any = oneof $ [ (\v -> (\_ -> Const typeOf v, fmap (const v))) <$> arbitrary ] ++ rest where rest | Just Refl <- testEquality t1 t2 = [return (id, id)] | otherwise = [] t1 :: Type a t1 = typeOf t2 :: Type b t2 = typeOf -- | Generator of functions on Booleans. arbitraryOp1Bool :: Gen (Fun Bool Bool, [Bool] -> [Bool]) arbitraryOp1Bool = elements [ (Op1 Not, fmap not) ] -- | Generator of binary functions on Booleans. arbitraryOp2Bool :: Gen (Fun2 Bool Bool Bool, [Bool] -> [Bool] -> [Bool]) arbitraryOp2Bool = elements [ (Op2 And, zipWith (&&)) , (Op2 Or, zipWith (||)) ] -- | Generator of binary functions that take two Eq elements of the same type -- and return a Bool. arbitraryOp2Eq :: (Typed t, Eq t) => Gen (Fun2 t t Bool, [t] -> [t] -> [Bool]) arbitraryOp2Eq = elements [ (Op2 (Eq typeOf), zipWith (==)) , (Op2 (Ne typeOf), zipWith (/=)) ] -- | Generator of binary functions that take two Ord elements of the same type -- and return a Bool. arbitraryOp2Ord :: (Typed t, Ord t) => Gen (Fun2 t t Bool, [t] -> [t] -> [Bool]) arbitraryOp2Ord = elements [ (Op2 (Le typeOf), zipWith (<=)) , (Op2 (Lt typeOf), zipWith (<)) , (Op2 (Ge typeOf), zipWith (>=)) , (Op2 (Gt typeOf), zipWith (>)) ] -- ** Random data generators -- | Random array generator. arbitraryArray :: forall n t . (KnownNat n, Random t) => Gen (Array n t) arbitraryArray = array <$> vectorOf len chooseAny where len :: Int len = fromIntegral $ natVal (Proxy :: Proxy n) -- ** Random test case generators -- | Generator for test cases on integral numbers that produce booleans. arbitraryOpIntegralBool :: (Typed t, Bounded t, Integral t, Bits t) => Gen (TestCase1 t Bool) arbitraryOpIntegralBool = frequency [ (5, mkTestCase1 arbitraryOpBool (chooseBoundedIntegral (minBound, maxBound))) , (2, mkTestCase1 arbitraryOpBoolBits (chooseBoundedIntegral (minBound, maxBound))) -- we need to use +1 because certain operations overflow the number , (2, mkTestCase1 arbitaryOpBoolOrdEqNum (chooseBoundedIntegral (minBound + 1, maxBound))) ] -- | Generator for test cases on floating-point numbers that produce booleans. arbitraryOpFloatingBool :: (Random t, Typed t, Floating t, Eq t) => Gen (TestCase1 t Bool) arbitraryOpFloatingBool = oneof [ mkTestCase1 arbitraryOpBoolEqNumFloat chooseAny ] -- | Generator for test cases on Arrays selection producing values of the -- array. arbitraryArrayNum :: forall n a . (KnownNat n, Num a, Random a, Typed a) => Gen (TestCase2 (Array n a) Word32 a) arbitraryArrayNum = oneof [ mkTestCase2 arbitraryArrayIx arbitraryArray gen ] where gen :: Gen Word32 gen = choose (0, len - 1) len :: Word32 len = fromIntegral $ natVal (Proxy :: Proxy n) -- * Semantics -- ** Functions -- | Unary Copilot function. type Fun a b = Expr a -> Expr b -- | Binary Copilot function. type Fun2 a b c = Expr a -> Expr b -> Expr c -- | Compose functions, paired with the Haskell functions that define their -- idealized meaning. funCompose1 :: (Fun b c, [b] -> [c]) -> (Fun a b, [a] -> [b]) -> (Fun a c, [a] -> [c]) funCompose1 (f1, g1) (f2, g2) = (f1 . f2, g1 . g2) -- | Compose a binary function, with two functions, one for each argument. funCompose2 :: (Fun2 b c d, [b] -> [c] -> [d]) -> (Fun a b, [a] -> [b]) -> (Fun a c, [a] -> [c]) -> (Fun a d, [a] -> [d]) funCompose2 (f1, g1) (f2, g2) (f3, g3) = (uncurry f1 . (f2 &&& f3), uncurry g1 . (g2 &&& g3)) -- ** Test cases -- | 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'. , wrapTC1Fun :: [a] -> [b] -- ^ Function expected to function in the same way as the Spec being -- tested. , wrapTC1CopInp :: (String -> String, String, String, Gen a) -- ^ Input specification. -- -- - The first element is a function that prints the variable declaration -- in C. -- -- - The second element obtains a C expression that calculates the size of -- the variable in C. -- -- - The third contains the variable name in C. -- -- - The latter contains a randomized generator for values of the given -- type. , wrapTC1CopOut :: (String, String) -- ^ Output specification. -- -- The first element of the tuple contains the type of the output in C. -- -- The second element of the tuple is the formatting string when printing -- values of the given kind. } -- | 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'. , wrapTC2Fun :: [a] -> [b] -> [c] -- ^ Function expected to function in the same way as the Spec being -- tested. , wrapTC2CopInp1 :: (String -> String, String, String, Gen a) -- ^ Input specification for the first input. -- -- - The first element is a function that prints the variable declaration -- in C. -- -- - The second element obtains a C expression that calculates the size of -- the variable in C. -- -- - The third contains the variable name in C. -- -- - The latter contains a randomized generator for values of the given -- type. , wrapTC2CopInp2 :: (String -> String, String, String, Gen b) -- ^ Input specification for the second input. -- -- - The first element is a function that prints the variable declaration -- in C. -- -- - The second element obtains a C expression that calculates the size of -- the variable in C. -- -- - The third contains the variable name in C. -- -- - The latter contains a randomized generator for values of the given -- type. , wrapTC2CopOut :: (String, String) -- ^ Output specification. -- -- The first element of the tuple contains the type of the output in C. -- -- The second element of the tuple is the formatting string when printing -- values of the given kind. } -- | Generate test cases for expressions that behave like unary functions. mkTestCase1 :: (Typed a, Typed b) => Gen (Fun a b, [a] -> [b]) -> Gen a -> Gen (TestCase1 a b) mkTestCase1 genO gen = do (copilotF, semF) <- genO let spec = alwaysTriggerArg1 (UExpr t2 appliedOp) appliedOp = copilotF (ExternVar t1 varName Nothing) return $ TestCase1 spec semF ( varDeclC t1, sizeC t1, varName, gen ) ( typeC t2, formatC t2) where t1 = typeOf t2 = typeOf varName = "input" -- | Generate test cases for expressions that behave like binary functions. mkTestCase2 :: (Typed a, Typed b, Typed c) => Gen (Fun2 a b c, [a] -> [b] -> [c]) -> Gen a -> Gen b -> Gen (TestCase2 a b c) mkTestCase2 genO genA genB = do (copilotF, semF) <- genO let spec = alwaysTriggerArg1 (UExpr t3 appliedOp) appliedOp = copilotF (ExternVar t1 varName1 Nothing) (ExternVar t2 varName2 Nothing) return $ TestCase2 spec semF ( varDeclC t1, sizeC t1, varName1, genA ) ( varDeclC t2, sizeC t2, varName2, genB ) ( typeC t3, formatC t3) where t1 = typeOf t2 = typeOf t3 = typeOf varName1 = "input1" varName2 = "input2" -- | Test running a compiled C program and comparing the results. testRunCompare1 :: (Show a, CShow a, ReadableFromC b, Eq b) => Gen (TestCase1 a b) -> Property testRunCompare1 ops = forAllBlind ops $ \testCase -> let (TestCase1 copilotSpec haskellFun inputVar outputVar) = testCase (cTypeInput, size, cInputName, gen) = inputVar in forAll (getPositive <$> arbitrary) $ \len -> forAll (vectorOf len gen) $ \nums -> do let inputs = [ (cTypeInput, size, fmap cshow nums, cInputName) ] outputs = haskellFun nums testRunCompareArg inputs len outputs copilotSpec outputVar -- | Test running a compiled C program and comparing the results. testRunCompare2 :: (Show a1, CShow a1, Show a2, CShow a2, ReadableFromC b, Eq b) => Gen (TestCase2 a1 a2 b) -> Property testRunCompare2 ops = forAllBlind ops $ \testCase -> let (TestCase2 copilotSpec haskellFun inputVar1 inputVar2 outputVar) = testCase (cTypeInput1, size1, cInputName1, gen1) = inputVar1 (cTypeInput2, size2, cInputName2, gen2) = inputVar2 in forAll (getPositive <$> arbitrary) $ \len -> forAll (vectorOf len gen1) $ \nums1 -> forAll (vectorOf len gen2) $ \nums2 -> do let inputs = [ (cTypeInput1, size1, fmap cshow nums1, cInputName1) , (cTypeInput2, size2, fmap cshow nums2, cInputName2) ] outputs = haskellFun nums1 nums2 testRunCompareArg inputs len outputs copilotSpec outputVar -- | Test running a compiled C program and comparing the results, when the -- program produces one output as an argument to a trigger that always fires. -- -- PRE: all lists (second argument) of inputs have the length given as second -- argument. -- -- PRE: the monitoring code this is linked against uses the function -- @printBack@ with exactly one argument to pass the results. testRunCompareArg :: (ReadableFromC b, Eq b) => [(String -> String, String, [String], String)] -> Int -> [b] -> Spec -> (String, String) -> Property testRunCompareArg inputs numInputs nums spec outputVar = ioProperty $ do tmpDir <- getTemporaryDirectory setCurrentDirectory tmpDir -- Operate in temporary directory testDir <- mkdtemp "copilot_test_" setCurrentDirectory testDir -- Produce copilot monitoring code compile "copilot_test" spec r <- compileC "copilot_test" -- Produce wrapper program let cProgram = testRunCompareArgCProgram inputs numInputs outputVar writeFile "main.c" cProgram -- Compile main program r2 <- compileExecutable "main" [ "copilot_test.o" ] -- Print result so far (for debugging purposes only) print r2 print testDir -- Run program and compare result out <- readProcess "./main" [] "" let outNums = readFromC <$> lines out comparison = outNums == nums -- Only clean up if the test succeeded; otherwise, we want to inspect it. when comparison $ do -- Remove file produced by GCC removeFile "copilot_test.o" removeFile "main" -- Remove files produced "by hand" removeFile "main.c" -- Remove files produced by Copilot removeFile "copilot_test.c" removeFile "copilot_test.h" removeFile "copilot_test_types.h" -- Remove temporary directory setCurrentDirectory tmpDir removeDirectory testDir return $ r && r2 && comparison -- | Return a wrapper C program that runs a loop for a number of iterations, -- putting values in global variables at every step, running the monitors, and -- publishing the results of any outputs. testRunCompareArgCProgram :: [(String -> String, String, [String], String)] -> Int -> (String, String) -> String testRunCompareArgCProgram inputs numSteps outputVar = unlines $ [ "#include " , "#include " , "#include " , "#include " , "#include " , "#include \"copilot_test.h\"" , "" ] ++ varDecls ++ [ "" , "void printBack (" ++ cTypeRes ++ " num) {" , " printf(\"" ++ cStr ++ "\\n\", num);" , "}" , "" , "int main () {" , " int i = 0;" , " for (i = 0; i < " ++ maxInputsName ++ "; i++) {" ] ++ inputUpdates ++ [ "" , " step();" , " }" , " return 0;" , "}" ] where varDecls :: [String] varDecls = [ "int " ++ maxInputsName ++ " = " ++ show numSteps ++ ";" ] ++ inputVarDecls inputVarDecls :: [String] inputVarDecls = concatMap (\(ctypeF, _size, varName, arrVar, arrVals) -> let inputsStr = intercalate ", " (arrVals :: [String]) in [ ctypeF (arrVar ++ "[]") ++ " = {" ++ inputsStr ++ "};" , "" , ctypeF varName ++ ";" ] ) vars inputUpdates :: [String] inputUpdates = concatMap (\(_ctype, size, varName, arrVar, _arrVals) -> [ " memcpy(&" ++ varName ++ ", &" ++ arrVar ++ "[i], " ++ size ++ ");" ]) vars (cTypeRes, cStr) = outputVar vars = map oneInput inputs oneInput (cTypeInput, size, inputVals, cInputName) = (cTypeInput, size, inputVarName, inputArrVarName, inputVals) where inputVarName = cInputName inputArrVarName = cInputName ++ "_s" maxInputsName = "MAX_STEPS" -- * Auxiliary functions -- ** Specs handling -- | Build a 'Spec' that triggers at every step, passing the given expression -- as argument, and execution a function 'printBack'. alwaysTriggerArg1 :: UExpr -> Spec alwaysTriggerArg1 = triggerArg1 (Const Bool True) where -- | Build a 'Spec' that triggers based on a given boolean stream, passing -- the given expression as argument, and execution a function 'printBack'. triggerArg1 :: Expr Bool -> UExpr -> Spec triggerArg1 guard expr = Spec streams observers triggers properties where streams = [] observers = [] properties = [] triggers = [ Trigger function guard args ] function = "printBack" args = [ expr ] -- ** Compilation of C programs -- | Compile a C file given its basename. compileC :: String -> IO Bool compileC baseName = do result <- catch (do callProcess "gcc" [ "-c", baseName ++ ".c" ] return True ) (\e -> do hPutStrLn stderr $ "copilot-c99: error: compileC: cannot compile " ++ baseName ++ ".c with gcc" hPutStrLn stderr $ "copilot-c99: exception: " ++ show (e :: IOException) return False ) if result then doesFileExist $ baseName ++ ".o" else return False -- | Compile a C file into an executable, given its basename and files to link -- with it. compileExecutable :: String -> [String] -> IO Bool compileExecutable baseName linked = do result <- catch (do callProcess "gcc" $ [ baseName ++ ".c" ] ++ linked ++ [ "-lm" ] ++ [ "-o", baseName ] return True ) (\e -> do hPutStrLn stderr $ "copilot-c99: error: compileExecutable: cannot compile " ++ baseName ++ ".c with gcc" hPutStrLn stderr $ "copilot-c99: exception: " ++ show (e :: IOException) return False ) if result then doesFileExist baseName else return False -- ** Interfacing between Haskell and C -- | C formatting string that can be used to print values of a given type. formatC :: Typed a => Type a -> String formatC Bool = "%d" formatC Int8 = "%d" formatC Int16 = "%d" formatC Int32 = "%d" formatC Int64 = "%ld" formatC Word8 = "%d" formatC Word16 = "%d" formatC Word32 = "%d" formatC Word64 = "%ld" formatC Float = "%f" formatC Double = "%lf" formatC _ = error "copilot-c99 (test): Printing of arrays and structs is not yet supported." -- | C type used to store values of a given type. typeC :: Typed a => Type a -> String typeC Bool = "bool" typeC Int8 = "int8_t" typeC Int16 = "int16_t" typeC Int32 = "int32_t" typeC Int64 = "int64_t" typeC Word8 = "uint8_t" typeC Word16 = "uint16_t" typeC Word32 = "uint32_t" typeC Word64 = "uint64_t" typeC Float = "float" typeC Double = "double" typeC (Array tE) = typeC tE ++ "[]" typeC _ = error "copilot-c99 (test): Input variables of type struct are not yet supported." -- | C variable declaration for values of a given type. varDeclC :: Typed a => Type a -> String -> String varDeclC Bool v = "bool " ++ v varDeclC Int8 v = "int8_t " ++ v varDeclC Int16 v = "int16_t " ++ v varDeclC Int32 v = "int32_t " ++ v varDeclC Int64 v = "int64_t " ++ v varDeclC Word8 v = "uint8_t " ++ v varDeclC Word16 v = "uint16_t " ++ v varDeclC Word32 v = "uint32_t " ++ v varDeclC Word64 v = "uint64_t " ++ v varDeclC Float v = "float " ++ v varDeclC Double v = "double " ++ v varDeclC t@(Array tE) v = typeC tE ++ " " ++ v ++ "[" ++ show (typeLength t) ++ "]" varDeclC _ _ = error "copilot-c99 (test): Input variables of type struct are not yet supported." -- | Expression that calculates the size of a variable of a given type. sizeC :: Typed a => Type a -> String sizeC Bool = "sizeof(bool)" sizeC Int8 = "sizeof(int8_t)" sizeC Int16 = "sizeof(int16_t)" sizeC Int32 = "sizeof(int32_t)" sizeC Int64 = "sizeof(int64_t)" sizeC Word8 = "sizeof(uint8_t)" sizeC Word16 = "sizeof(uint16_t)" sizeC Word32 = "sizeof(uint32_t)" sizeC Word64 = "sizeof(uint64_t)" sizeC Float = "sizeof(float)" sizeC Double = "sizeof(double)" sizeC t@(Array tE) = show (typeLength t) ++ "* sizeof(" ++ typeC tE ++ ")" sizeC _ = error "copilot-c99 (test): Input variables of type struct are not yet supported." -- | Show a value of a given type in C. class CShow s where cshow :: s -> String instance CShow Int8 where -- Use a macro to ensure that any necessary suffixes are added to the number. -- We choose this macro instead of specifically adding a suffix for reasons -- of portability. cshow x = "INT8_C(" ++ show x ++ ")" instance CShow Int16 where -- Use a macro to ensure that any necessary suffixes are added to the number. -- We choose this macro instead of specifically adding a suffix for reasons -- of portability. cshow x = "INT16_C(" ++ show x ++ ")" instance CShow Int32 where -- Use a macro to ensure that any necessary suffixes are added to the number. -- We choose this macro instead of specifically adding a suffix for reasons -- of portability. cshow x = "INT32_C(" ++ show x ++ ")" instance CShow Int64 where -- Use a macro to ensure that any necessary suffixes are added to the number. -- We choose this macro instead of specifically adding a suffix for reasons -- of portability. cshow x = "INT64_C(" ++ show x ++ ")" instance CShow Word8 where -- Use a macro to ensure that any necessary suffixes are added to the number. -- We choose this macro instead of specifically adding a suffix for reasons -- of portability. cshow x = "UINT8_C(" ++ show x ++ ")" instance CShow Word16 where -- Use a macro to ensure that any necessary suffixes are added to the number. -- We choose this macro instead of specifically adding a suffix for reasons -- of portability. cshow x = "UINT16_C(" ++ show x ++ ")" instance CShow Word32 where -- Use a macro to ensure that any necessary suffixes are added to the number. -- We choose this macro instead of specifically adding a suffix for reasons -- of portability. cshow x = "UINT32_C(" ++ show x ++ ")" instance CShow Word64 where -- Use a macro to ensure that any necessary suffixes are added to the number. -- We choose this macro instead of specifically adding a suffix for reasons -- of portability. cshow x = "UINT64_C(" ++ show x ++ ")" instance CShow Float where cshow = show instance CShow Double where cshow = show instance CShow Bool where cshow True = "true" cshow False = "false" instance CShow t => CShow (Array n t) where cshow a = intercalate "," $ map cshow $ arrayElems a -- | Read a value of a given type in C. class ReadableFromC a where readFromC :: String -> a instance ReadableFromC Bool where readFromC "0" = False readFromC _ = True instance ReadableFromC Int8 where readFromC = read instance ReadableFromC Int16 where readFromC = read instance ReadableFromC Int32 where readFromC = read instance ReadableFromC Int64 where readFromC = read instance ReadableFromC Word8 where readFromC = read instance ReadableFromC Word16 where readFromC = read instance ReadableFromC Word32 where readFromC = read instance ReadableFromC Word64 where readFromC = read copilot-c99-3.19.1/src/0000755000000000000000000000000014616626046012650 5ustar0000000000000000copilot-c99-3.19.1/src/Copilot/0000755000000000000000000000000014616626046014261 5ustar0000000000000000copilot-c99-3.19.1/src/Copilot/Compile/0000755000000000000000000000000014616626046015651 5ustar0000000000000000copilot-c99-3.19.1/src/Copilot/Compile/C99.hs0000644000000000000000000000047014616626046016552 0ustar0000000000000000-- | Compile Copilot specifications to C99 code. module Copilot.Compile.C99 ( compile , compileWith , CSettings(..) , mkDefaultCSettings ) where -- Internal imports import Copilot.Compile.C99.Compile ( compile, compileWith ) import Copilot.Compile.C99.Settings ( CSettings (..), mkDefaultCSettings ) copilot-c99-3.19.1/src/Copilot/Compile/C99/0000755000000000000000000000000014616626046016215 5ustar0000000000000000copilot-c99-3.19.1/src/Copilot/Compile/C99/Error.hs0000644000000000000000000000132214616626046017640 0ustar0000000000000000{-# LANGUAGE Safe #-} -- | -- Copyright: (c) 2011 National Institute of Aerospace / Galois, Inc. -- -- Custom functions to report error messages to users. module Copilot.Compile.C99.Error ( impossible ) where -- | Report an error due to a bug in Copilot. impossible :: String -- ^ Name of the function in which the error was detected. -> String -- ^ Name of the package in which the function is located. -> a impossible function package = error $ "Impossible error in function " ++ function ++ ", in package " ++ package ++ ". Please file an issue at " ++ "https://github.com/Copilot-Language/copilot/issues" ++ " or email the maintainers at " copilot-c99-3.19.1/src/Copilot/Compile/C99/Compile.hs0000644000000000000000000002402114616626046020140 0ustar0000000000000000{-# LANGUAGE GADTs #-} -- | Compile Copilot specifications to C99 code. module Copilot.Compile.C99.Compile ( compile , compileWith ) where -- External imports import Data.List ( nub, union ) import Data.Maybe ( mapMaybe ) import Data.Typeable ( Typeable ) import Language.C99.Pretty ( pretty ) import qualified Language.C99.Simple as C import System.Directory ( createDirectoryIfMissing ) import System.Exit ( exitFailure ) import System.FilePath ( () ) import System.IO ( hPutStrLn, stderr ) import Text.PrettyPrint ( render ) -- Internal imports: Copilot import Copilot.Core ( Expr (..), Spec (..), Stream (..), Struct (..), Trigger (..), Type (..), UExpr (..), UType (..), Value (..) ) -- Internal imports import Copilot.Compile.C99.CodeGen ( mkAccessDecln, mkBuffDecln, mkExtCpyDecln, mkExtDecln, mkGenFun, mkGenFunArray, mkIndexDecln, mkStep, mkStructDecln, mkStructForwDecln ) import Copilot.Compile.C99.External ( External, gatherExts ) import Copilot.Compile.C99.Name ( argNames, generatorName, generatorOutputArgName, guardName ) import Copilot.Compile.C99.Settings ( CSettings, cSettingsOutputDirectory, cSettingsStepFunctionName, mkDefaultCSettings ) import Copilot.Compile.C99.Type ( transType ) -- | Compile a specification to a .h and a .c file. -- -- The first argument is the settings for the C code generated. -- -- The second argument is used as prefix for the .h and .c files generated. compileWith :: CSettings -> String -> Spec -> IO () compileWith cSettings prefix spec | null (specTriggers spec) = do hPutStrLn stderr $ "Copilot error: attempt at compiling empty specification.\n" ++ "You must define at least one trigger to generate C monitors." exitFailure | otherwise = do let cFile = render $ pretty $ C.translate $ compileC cSettings spec hFile = render $ pretty $ C.translate $ compileH cSettings spec typeDeclnsFile = safeCRender $ compileTypeDeclns cSettings spec cMacros = unlines [ "#include " , "#include " , "#include " , "#include " , "#include " , "" , "#include \"" ++ prefix ++ "_types.h\"" , "#include \"" ++ prefix ++ ".h\"" , "" ] let dir = cSettingsOutputDirectory cSettings createDirectoryIfMissing True dir writeFile (dir prefix ++ ".c") $ cMacros ++ cFile writeFile (dir prefix ++ ".h") hFile writeFile (dir prefix ++ "_types.h") typeDeclnsFile -- | Compile a specification to a .h and a .c file. -- -- The first argument is used as prefix for the .h and .c files generated. compile :: String -> Spec -> IO () compile = compileWith mkDefaultCSettings -- | Generate the .c file from a 'Spec'. -- -- The generated C file has the following structure: -- -- * Include .h file. -- * Declarations of global buffers and indices. -- * Generator functions for streams, guards and trigger arguments. -- * Declaration of the @step()@ function. compileC :: CSettings -> Spec -> C.TransUnit compileC cSettings spec = C.TransUnit declns funs where declns = mkExts exts ++ mkGlobals streams funs = mkGenFuns streams triggers ++ [mkStep cSettings streams triggers exts] streams = specStreams spec triggers = specTriggers spec exts = gatherExts streams triggers -- Make declarations for copies of external variables. mkExts :: [External] -> [C.Decln] mkExts = map mkExtCpyDecln -- Make buffer and index declarations for streams. mkGlobals :: [Stream] -> [C.Decln] mkGlobals streamList = map buffDecln streamList ++ map indexDecln streamList where buffDecln (Stream sId buff _ ty) = mkBuffDecln sId ty buff indexDecln (Stream sId _ _ _ ) = mkIndexDecln sId -- Make generator functions, including trigger arguments. mkGenFuns :: [Stream] -> [Trigger] -> [C.FunDef] mkGenFuns streamList triggerList = map accessDecln streamList ++ map streamGen streamList ++ concatMap triggerGen triggerList where accessDecln :: Stream -> C.FunDef accessDecln (Stream sId buff _ ty) = mkAccessDecln sId ty buff streamGen :: Stream -> C.FunDef streamGen (Stream sId _ expr ty) = exprGen (generatorName sId) (generatorOutputArgName sId) expr ty triggerGen :: Trigger -> [C.FunDef] triggerGen (Trigger name guard args) = guardDef : argDefs where guardDef = mkGenFun (guardName name) guard Bool argDefs = zipWith argGen (argNames name) args argGen :: String -> UExpr -> C.FunDef argGen argName (UExpr ty expr) = exprGen argName (argName ++ "_output") expr ty -- Create a function that calculates the current value generated by an -- expression `expr` of type `ty`. The generator treats arrays -- specially, and the function takes an output array as a parameter. -- The second identifier `outputArrName` is not used if `expr` is not an -- array. exprGen :: C.Ident -> C.Ident -> Expr a -> Type a -> C.FunDef exprGen funName outputArrName expr ty@(Array _) = mkGenFunArray funName outputArrName expr ty exprGen funName _ expr ty = mkGenFun funName expr ty -- | Generate the .h file from a 'Spec'. compileH :: CSettings -> Spec -> C.TransUnit compileH cSettings spec = C.TransUnit declns [] where declns = mkStructForwDeclns exprs ++ mkExts exts ++ extFunDeclns triggers ++ [stepDecln] exprs = gatherExprs streams triggers exts = gatherExts streams triggers streams = specStreams spec triggers = specTriggers spec mkStructForwDeclns :: [UExpr] -> [C.Decln] mkStructForwDeclns es = mapMaybe mkDecln uTypes where mkDecln (UType ty) = case ty of Struct _ -> Just $ mkStructForwDecln ty _ -> Nothing uTypes = nub $ concatMap (\(UExpr _ e) -> exprTypes e) es -- Make declarations for external variables. mkExts :: [External] -> [C.Decln] mkExts = map mkExtDecln extFunDeclns :: [Trigger] -> [C.Decln] extFunDeclns = map extFunDecln where extFunDecln :: Trigger -> C.Decln extFunDecln (Trigger name _ args) = C.FunDecln Nothing cTy name params where cTy = C.TypeSpec C.Void params = zipWith mkParam (argNames name) args mkParam paramName (UExpr ty _) = C.Param (mkParamTy ty) paramName -- Special case for Struct, to pass struct arguments by reference. -- Arrays are also passed by reference, but using C's array type -- does that automatically. mkParamTy ty = case ty of Struct _ -> C.Ptr (transType ty) _ -> transType ty -- Declaration for the step function. stepDecln :: C.Decln stepDecln = C.FunDecln Nothing (C.TypeSpec C.Void) (cSettingsStepFunctionName cSettings) [] -- | Generate a C translation unit that contains all type declarations needed -- by the Copilot specification. compileTypeDeclns :: CSettings -> Spec -> C.TransUnit compileTypeDeclns _cSettings spec = C.TransUnit declns [] where declns = mkTypeDeclns exprs exprs = gatherExprs streams triggers streams = specStreams spec triggers = specTriggers spec -- Generate type declarations. mkTypeDeclns :: [UExpr] -> [C.Decln] mkTypeDeclns es = mapMaybe mkTypeDecln uTypes where uTypes = nub $ concatMap (\(UExpr _ e) -> exprTypes e) es mkTypeDecln (UType ty) = case ty of Struct _ -> Just $ mkStructDecln ty _ -> Nothing -- * Auxiliary definitions -- | Render a C.TransUnit to a String, accounting for the case in which the -- translation unit is empty. safeCRender :: C.TransUnit -> String safeCRender (C.TransUnit [] []) = "" safeCRender transUnit = render $ pretty $ C.translate transUnit -- ** Obtain information from Copilot Core Exprs and Types. -- | List all types of an expression, returns items uniquely. exprTypes :: Typeable a => Expr a -> [UType] exprTypes e = case e of Const ty _ -> typeTypes ty Local ty1 ty2 _ e1 e2 -> typeTypes ty1 `union` typeTypes ty2 `union` exprTypes e1 `union` exprTypes e2 Var ty _ -> typeTypes ty Drop ty _ _ -> typeTypes ty ExternVar ty _ _ -> typeTypes ty Op1 _ e1 -> exprTypes e1 Op2 _ e1 e2 -> exprTypes e1 `union` exprTypes e2 Op3 _ e1 e2 e3 -> exprTypes e1 `union` exprTypes e2 `union` exprTypes e3 Label ty _ _ -> typeTypes ty -- | List all types of a type, returns items uniquely. typeTypes :: Typeable a => Type a -> [UType] typeTypes ty = case ty of Array ty' -> typeTypes ty' `union` [UType ty] Struct x -> concatMap (\(Value ty' _) -> typeTypes ty') (toValues x) `union` [UType ty] _ -> [UType ty] -- | Collect all expression of a list of streams and triggers and wrap them -- into an UEXpr. gatherExprs :: [Stream] -> [Trigger] -> [UExpr] gatherExprs streams triggers = map streamUExpr streams ++ concatMap triggerUExpr triggers where streamUExpr (Stream _ _ expr ty) = UExpr ty expr triggerUExpr (Trigger _ guard args) = UExpr Bool guard : args copilot-c99-3.19.1/src/Copilot/Compile/C99/CodeGen.hs0000644000000000000000000003117614616626046020065 0ustar0000000000000000{-# LANGUAGE GADTs #-} -- | High-level translation of Copilot Core into C99. module Copilot.Compile.C99.CodeGen ( -- * Externs mkExtCpyDecln , mkExtDecln -- * Type declarations , mkStructDecln , mkStructForwDecln -- * Ring buffers , mkBuffDecln , mkIndexDecln , mkAccessDecln -- * Stream generators , mkGenFun , mkGenFunArray -- * Monitor processing , mkStep ) where -- External imports import Control.Monad.State ( runState ) import Data.List ( unzip4 ) import qualified Data.List.NonEmpty as NonEmpty import qualified Language.C99.Simple as C -- Internal imports: Copilot import Copilot.Core ( Expr (..), Id, Stream (..), Struct (..), Trigger (..), Type (..), UExpr (..), Value (..), fieldName, typeSize ) -- Internal imports import Copilot.Compile.C99.Error ( impossible ) import Copilot.Compile.C99.Expr ( constArray, transExpr ) import Copilot.Compile.C99.External ( External (..) ) import Copilot.Compile.C99.Name ( argNames, argTempNames, generatorName, guardName, indexName, streamAccessorName, streamName ) import Copilot.Compile.C99.Settings ( CSettings, cSettingsStepFunctionName ) import Copilot.Compile.C99.Type ( transType ) -- * Externs -- | Make a extern declaration of a variable. mkExtDecln :: External -> C.Decln mkExtDecln (External name _ ty) = decln where decln = C.VarDecln (Just C.Extern) cTy name Nothing cTy = transType ty -- | Make a declaration for a copy of an external variable. mkExtCpyDecln :: External -> C.Decln mkExtCpyDecln (External _name cpyName ty) = decln where decln = C.VarDecln (Just C.Static) cTy cpyName Nothing cTy = transType ty -- * Type declarations -- | Write a struct declaration based on its definition. mkStructDecln :: Struct a => Type a -> C.Decln mkStructDecln (Struct x) = C.TypeDecln struct where struct = C.TypeSpec $ C.StructDecln (Just $ typeName x) fields fields = NonEmpty.fromList $ map mkField (toValues x) mkField :: Value a -> C.FieldDecln mkField (Value ty field) = C.FieldDecln (transType ty) (fieldName field) -- | Write a forward struct declaration. mkStructForwDecln :: Struct a => Type a -> C.Decln mkStructForwDecln (Struct x) = C.TypeDecln struct where struct = C.TypeSpec $ C.Struct (typeName x) -- * Ring buffers -- | Make a C buffer variable and initialise it with the stream buffer. mkBuffDecln :: Id -> Type a -> [a] -> C.Decln mkBuffDecln sId ty xs = C.VarDecln (Just C.Static) cTy name initVals where name = streamName sId cTy = C.Array (transType ty) (Just $ C.LitInt $ fromIntegral buffSize) buffSize = length xs initVals = Just $ C.InitList $ constArray ty xs -- | Make a C index variable and initialise it to 0. mkIndexDecln :: Id -> C.Decln mkIndexDecln sId = C.VarDecln (Just C.Static) cTy name initVal where name = indexName sId cTy = C.TypeSpec $ C.TypedefName "size_t" initVal = Just $ C.InitExpr $ C.LitInt 0 -- | Define an accessor functions for the ring buffer associated with a stream. mkAccessDecln :: Id -> Type a -> [a] -> C.FunDef mkAccessDecln sId ty xs = C.FunDef static cTy name params [] [C.Return (Just expr)] where static = Just C.Static cTy = C.decay $ transType ty name = streamAccessorName sId -- We cast the buffer length to a size_t to make sure that there are no -- implicit conversions. This is a requirement for compliance with MISRA C -- (Rule 10.4). buffLength = C.Cast sizeT $ C.LitInt $ fromIntegral $ length xs sizeT = C.TypeName $ C.TypeSpec $ C.TypedefName "size_t" params = [C.Param (C.TypeSpec $ C.TypedefName "size_t") "x"] index = (C.Ident (indexName sId) C..+ C.Ident "x") C..% buffLength expr = C.Index (C.Ident (streamName sId)) index -- * Stream generators -- | Write a generator function for a stream. mkGenFun :: String -> Expr a -> Type a -> C.FunDef mkGenFun name expr ty = C.FunDef static cTy name [] cVars [C.Return $ Just cExpr] where static = Just C.Static cTy = C.decay $ transType ty (cExpr, cVars) = runState (transExpr expr) mempty -- | Write a generator function for a stream that returns an array. mkGenFunArray :: String -> String -> Expr a -> Type a -> C.FunDef mkGenFunArray name nameArg expr ty@(Array _) = C.FunDef static funType name [ outputParam ] varDecls stmts where static = Just C.Static funType = C.TypeSpec C.Void -- The output value is an array outputParam = C.Param cArrayType nameArg cArrayType = transType ty -- Output value, and any variable declarations needed (cExpr, varDecls) = runState (transExpr expr) mempty -- Copy expression to output argument stmts = [ C.Expr $ memcpy (C.Ident nameArg) cExpr size ] size = C.LitInt (fromIntegral $ typeSize ty) C..* C.SizeOfType (C.TypeName $ tyElemName ty) mkGenFunArray _name _nameArg _expr _ty = impossible "mkGenFunArray" "copilot-c99" -- * Monitor processing -- | Define the step function that updates all streams. mkStep :: CSettings -> [Stream] -> [Trigger] -> [External] -> C.FunDef mkStep cSettings streams triggers exts = C.FunDef Nothing void (cSettingsStepFunctionName cSettings) [] declns stmts where void = C.TypeSpec C.Void declns = streamDeclns ++ concat triggerDeclns stmts = map mkExCopy exts ++ triggerStmts ++ tmpAssigns ++ bufferUpdates ++ indexUpdates (streamDeclns, tmpAssigns, bufferUpdates, indexUpdates) = unzip4 $ map mkUpdateGlobals streams (triggerDeclns, triggerStmts) = unzip $ map mkTriggerCheck triggers -- Update the value of a variable with the result of calling a function that -- generates the next value in a stream expression. If the type of the -- variable is an array, then we cannot perform a direct C assignment, so -- we instead pass the variable as an output array to the function. updateVar :: C.Ident -> C.Ident -> Type a -> C.Expr updateVar varName genName (Array _) = C.Funcall (C.Ident genName) [C.Ident varName] updateVar varName genName _ = C.AssignOp C.Assign (C.Ident varName) (C.Funcall (C.Ident genName) []) -- Write code to update global stream buffers and index. mkUpdateGlobals :: Stream -> (C.Decln, C.Stmt, C.Stmt, C.Stmt) mkUpdateGlobals (Stream sId buff _expr ty) = (tmpDecln, tmpAssign, bufferUpdate, indexUpdate) where tmpDecln = C.VarDecln Nothing cTy tmpVar Nothing tmpAssign = C.Expr $ updateVar tmpVar (generatorName sId) ty bufferUpdate = case ty of Array _ -> C.Expr $ memcpy dest (C.Ident tmpVar) size where dest = C.Index buffVar indexVar size = C.LitInt (fromIntegral $ typeSize ty) C..* C.SizeOfType (C.TypeName (tyElemName ty)) _ -> C.Expr $ C.Index buffVar indexVar C..= C.Ident tmpVar indexUpdate = C.Expr $ indexVar C..= (incIndex C..% buffLength) where -- We cast the buffer length and the literal one to a size_t to -- make sure that there are no implicit conversions. This is a -- requirement for compliance with MISRA C (Rule 10.4). buffLength = C.Cast sizeT $ C.LitInt $ fromIntegral $ length buff incIndex = indexVar C..+ C.Cast sizeT (C.LitInt 1) sizeT = C.TypeName $ C.TypeSpec $ C.TypedefName "size_t" tmpVar = streamName sId ++ "_tmp" buffVar = C.Ident $ streamName sId indexVar = C.Ident $ indexName sId cTy = transType ty -- Make code that copies an external variable to its local one. mkExCopy :: External -> C.Stmt mkExCopy (External name cpyName ty) = C.Expr $ case ty of Array _ -> memcpy exVar locVar size where exVar = C.Ident cpyName locVar = C.Ident name size = C.LitInt (fromIntegral $ typeSize ty) C..* C.SizeOfType (C.TypeName (tyElemName ty)) _ -> C.Ident cpyName C..= C.Ident name -- Make if-statement to check the guard, call the handler if necessary. -- This returns two things: -- -- * A list of Declns for temporary variables, one for each argument that -- the handler function accepts. For example, if a handler function takes -- three arguments, the list of Declns might look something like this: -- -- @ -- int8_t handler_arg_temp0; -- int16_t handler_arg_temp1; -- struct s handler_arg_temp2; -- @ -- -- * A Stmt representing the if-statement. Continuing the example above, -- the if-statement would look something like this: -- -- @ -- if (handler_guard()) { -- handler_arg_temp0 = handler_arg0(); -- handler_arg_temp1 = handler_arg1(); -- handler_arg_temp2 = handler_arg2(); -- handler(handler_arg_temp0, handler_arg_temp1, &handler_arg_temp2); -- } -- @ -- -- We create temporary variables because: -- -- 1. We want to pass structs by reference intead of by value. To this end, -- we use C's & operator to obtain a reference to a temporary variable -- of a struct type and pass that to the handler function. -- -- 2. Assigning a struct to a temporary variable defensively ensures that -- any modifications that the handler called makes to the struct argument -- will not affect the internals of the monitoring code. mkTriggerCheck :: Trigger -> ([C.Decln], C.Stmt) mkTriggerCheck (Trigger name _guard args) = (aTmpDeclns, triggerCheckStmt) where aTmpDeclns :: [C.Decln] aTmpDeclns = zipWith declare args aTempNames where declare :: UExpr -> C.Ident -> C.Decln declare (UExpr { uExprType = ty }) tmpVar = C.VarDecln Nothing (transType ty) tmpVar Nothing triggerCheckStmt :: C.Stmt triggerCheckStmt = C.If guard' fireTrigger where guard' = C.Funcall (C.Ident $ guardName name) [] -- The body of the if-statement. This consists of statements that -- assign the values of the temporary variables, following by a -- final statement that passes the temporary variables to the -- handler function. fireTrigger = map C.Expr argAssigns ++ [C.Expr $ C.Funcall (C.Ident name) (zipWith passArg aTempNames args)] where -- List of assignments of values of temporary variables. argAssigns :: [C.Expr] argAssigns = zipWith3 assign aTempNames aArgNames args assign :: C.Ident -> C.Ident -> UExpr -> C.Expr assign aTempName aArgName (UExpr { uExprType = ty }) = updateVar aTempName aArgName ty aArgNames :: [C.Ident] aArgNames = take (length args) (argNames name) -- Build an expression to pass a temporary variable as argument -- to a trigger handler. -- -- We need to pass a reference to the variable in some cases, -- so we also need the type of the expression, which is enclosed -- in the second argument, an UExpr. passArg :: String -> UExpr -> C.Expr passArg aTempName (UExpr { uExprType = ty }) = case ty of -- Special case for Struct to pass reference to temporary -- struct variable to handler. (See the comments for -- mktriggercheck for details.) Struct _ -> C.UnaryOp C.Ref $ C.Ident aTempName _ -> C.Ident aTempName aTempNames :: [String] aTempNames = take (length args) (argTempNames name) -- * Auxiliary functions -- Write a call to the memcpy function. memcpy :: C.Expr -> C.Expr -> C.Expr -> C.Expr memcpy dest src size = C.Funcall (C.Ident "memcpy") [dest, src, size] -- Translate a Copilot type to a C99 type, handling arrays especially. -- -- If the given type is an array (including multi-dimensional arrays), the -- type is that of the elements in the array. Otherwise, it is just the -- equivalent representation of the given type in C. tyElemName :: Type a -> C.Type tyElemName ty = case ty of Array ty' -> tyElemName ty' _ -> transType ty copilot-c99-3.19.1/src/Copilot/Compile/C99/Type.hs0000644000000000000000000000334314616626046017475 0ustar0000000000000000{-# LANGUAGE GADTs #-} -- | Translate Copilot Core expressions and operators to C99. module Copilot.Compile.C99.Type ( transType , transLocalVarDeclType , transTypeName ) where -- External imports import qualified Language.C99.Simple as C -- Internal imports: Copilot import Copilot.Core ( Type (..), typeLength, typeName ) -- | Translate a Copilot type to a C99 type. transType :: Type a -> C.Type transType ty = case ty of Bool -> C.TypeSpec $ C.TypedefName "bool" Int8 -> C.TypeSpec $ C.TypedefName "int8_t" Int16 -> C.TypeSpec $ C.TypedefName "int16_t" Int32 -> C.TypeSpec $ C.TypedefName "int32_t" Int64 -> C.TypeSpec $ C.TypedefName "int64_t" Word8 -> C.TypeSpec $ C.TypedefName "uint8_t" Word16 -> C.TypeSpec $ C.TypedefName "uint16_t" Word32 -> C.TypeSpec $ C.TypedefName "uint32_t" Word64 -> C.TypeSpec $ C.TypedefName "uint64_t" Float -> C.TypeSpec C.Float Double -> C.TypeSpec C.Double Array ty' -> C.Array (transType ty') len where len = Just $ C.LitInt $ fromIntegral $ typeLength ty Struct s -> C.TypeSpec $ C.Struct (typeName s) -- | Translate a Copilot type to a valid (local) variable declaration C99 type. -- -- If the type denotes an array, translate it to a pointer to whatever the -- array holds. This special case is needed when the type is used for a local -- variable declaration. We treat global variables differently (we generate -- list initializers). transLocalVarDeclType :: Type a -> C.Type transLocalVarDeclType (Array ty') = C.Ptr $ transType ty' transLocalVarDeclType ty = transType ty -- | Translate a Copilot type intro a C typename transTypeName :: Type a -> C.TypeName transTypeName ty = C.TypeName $ transType ty copilot-c99-3.19.1/src/Copilot/Compile/C99/Settings.hs0000644000000000000000000000071214616626046020351 0ustar0000000000000000-- | Settings used by the code generator to customize the code. module Copilot.Compile.C99.Settings ( CSettings(..) , mkDefaultCSettings ) where -- | Settings used to customize the code generated. data CSettings = CSettings { cSettingsStepFunctionName :: String , cSettingsOutputDirectory :: FilePath } -- | Default settings with a step function called @step@. mkDefaultCSettings :: CSettings mkDefaultCSettings = CSettings "step" "." copilot-c99-3.19.1/src/Copilot/Compile/C99/Name.hs0000644000000000000000000000350214616626046017431 0ustar0000000000000000-- | Naming of variables and functions in C. module Copilot.Compile.C99.Name ( argNames , argTempNames , exCpyName , generatorName , generatorOutputArgName , guardName , indexName , streamAccessorName , streamName ) where -- External imports: Copilot import Copilot.Core (Id) -- | Turn a stream id into a suitable C variable name. streamName :: Id -> String streamName sId = "s" ++ show sId -- | Turn a stream id into the global varname for indices. indexName :: Id -> String indexName sId = streamName sId ++ "_idx" -- | Turn a stream id into the name of its accessor function streamAccessorName :: Id -> String streamAccessorName sId = streamName sId ++ "_get" -- | Add a postfix for copies of external variables the name. exCpyName :: String -> String exCpyName name = name ++ "_cpy" -- | Turn stream id into name of its generator function. generatorName :: Id -> String generatorName sId = streamName sId ++ "_gen" -- | Turn stream id into name of its output argument array. generatorOutputArgName :: Id -> String generatorOutputArgName sId = streamName sId ++ "_output" -- | Turn the name of a trigger into a guard generator. guardName :: String -> String guardName name = name ++ "_guard" -- | Turn a trigger name into a trigger argument name. argName :: String -> Int -> String argName name n = name ++ "_arg" ++ show n -- | Turn a handler function name into a name for a temporary variable for a -- handler argument. argTempName :: String -> Int -> String argTempName name n = name ++ "_arg_temp" ++ show n -- | Enumerate all argument names based on trigger name. argNames :: String -> [String] argNames base = map (argName base) [0..] -- | Enumerate all temporary variable names based on handler function name. argTempNames :: String -> [String] argTempNames base = map (argTempName base) [0..] copilot-c99-3.19.1/src/Copilot/Compile/C99/External.hs0000644000000000000000000000425014616626046020334 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification #-} -- | Represent information about externs needed in the generation of C99 code -- for stream declarations and triggers. module Copilot.Compile.C99.External ( External(..) , gatherExts ) where -- External imports import Data.List (unionBy) -- Internal imports: Copilot import Copilot.Core ( Expr (..), Stream (..), Trigger (..), Type, UExpr (..) ) -- Internal imports import Copilot.Compile.C99.Name ( exCpyName ) -- | Representation of external variables. data External = forall a. External { extName :: String , extCpyName :: String , extType :: Type a } -- | Collect all external variables from the streams and triggers. -- -- Although Copilot specifications can contain also properties and theorems, -- the C99 backend currently only generates code for streams and triggers. gatherExts :: [Stream] -> [Trigger] -> [External] gatherExts streams triggers = streamsExts `extUnion` triggersExts where streamsExts = foldr (extUnion . streamExts) mempty streams triggersExts = foldr (extUnion . triggerExts) mempty triggers streamExts :: Stream -> [External] streamExts (Stream _ _ expr _) = exprExts expr triggerExts :: Trigger -> [External] triggerExts (Trigger _ guard args) = guardExts `extUnion` argExts where guardExts = exprExts guard argExts = concatMap uExprExts args uExprExts :: UExpr -> [External] uExprExts (UExpr _ expr) = exprExts expr exprExts :: Expr a -> [External] exprExts (Local _ _ _ e1 e2) = exprExts e1 `extUnion` exprExts e2 exprExts (ExternVar ty name _) = [External name (exCpyName name) ty] exprExts (Op1 _ e) = exprExts e exprExts (Op2 _ e1 e2) = exprExts e1 `extUnion` exprExts e2 exprExts (Op3 _ e1 e2 e3) = exprExts e1 `extUnion` exprExts e2 `extUnion` exprExts e3 exprExts (Label _ _ e) = exprExts e exprExts _ = [] -- | Union over lists of External, we solely base the equality on the -- extName's. extUnion :: [External] -> [External] -> [External] extUnion = unionBy (\a b -> extName a == extName b) copilot-c99-3.19.1/src/Copilot/Compile/C99/Expr.hs0000644000000000000000000003626614616626046017504 0ustar0000000000000000{-# LANGUAGE GADTs #-} -- | Translate Copilot Core expressions and operators to C99. module Copilot.Compile.C99.Expr ( transExpr , constArray ) where -- External imports import Control.Monad.State ( State, modify ) import qualified Data.List.NonEmpty as NonEmpty import qualified Language.C99.Simple as C -- Internal imports: Copilot import Copilot.Core ( Expr (..), Field (..), Op1 (..), Op2 (..), Op3 (..), Type (..), Value (..), accessorName, arrayElems, toValues ) -- Internal imports import Copilot.Compile.C99.Error ( impossible ) import Copilot.Compile.C99.Name ( exCpyName, streamAccessorName ) import Copilot.Compile.C99.Type ( transLocalVarDeclType, transTypeName ) -- | Translates a Copilot Core expression into a C99 expression. transExpr :: Expr a -> State FunEnv C.Expr transExpr (Const ty x) = return $ constTy ty x transExpr (Local ty1 _ name e1 e2) = do e1' <- transExpr e1 let cTy1 = transLocalVarDeclType ty1 initExpr = Just $ C.InitExpr e1' -- Add new decl to the tail of the fun env modify (++ [C.VarDecln Nothing cTy1 name initExpr]) transExpr e2 transExpr (Var _ n) = return $ C.Ident n transExpr (Drop _ amount sId) = do let accessVar = streamAccessorName sId index = C.LitInt (fromIntegral amount) return $ funCall accessVar [index] transExpr (ExternVar _ name _) = return $ C.Ident (exCpyName name) transExpr (Label _ _ e) = transExpr e -- ignore label transExpr (Op1 op e) = do e' <- transExpr e return $ transOp1 op e' transExpr (Op2 op e1 e2) = do e1' <- transExpr e1 e2' <- transExpr e2 return $ transOp2 op e1' e2' transExpr (Op3 op e1 e2 e3) = do e1' <- transExpr e1 e2' <- transExpr e2 e3' <- transExpr e3 return $ transOp3 op e1' e2' e3' -- | Translates a Copilot unary operator and its argument into a C99 -- expression. transOp1 :: Op1 a b -> C.Expr -> C.Expr transOp1 op e = -- There are three types of ways in which a function in Copilot Core can be -- translated into C: -- -- 1) Direct translation (perfect 1-to-1 mapping) -- 2) Type-directed translation (1-to-many mapping, choice based on type) -- 3) Desugaring/complex (expands to complex expression) case op of Not -> (C..!) e Abs ty -> transAbs ty e Sign ty -> transSign ty e Recip ty -> constNumTy ty 1 C../ e Acos ty -> funCall (specializeMathFunName ty "acos") [e] Asin ty -> funCall (specializeMathFunName ty "asin") [e] Atan ty -> funCall (specializeMathFunName ty "atan") [e] Cos ty -> funCall (specializeMathFunName ty "cos") [e] Sin ty -> funCall (specializeMathFunName ty "sin") [e] Tan ty -> funCall (specializeMathFunName ty "tan") [e] Acosh ty -> funCall (specializeMathFunName ty "acosh") [e] Asinh ty -> funCall (specializeMathFunName ty "asinh") [e] Atanh ty -> funCall (specializeMathFunName ty "atanh") [e] Cosh ty -> funCall (specializeMathFunName ty "cosh") [e] Sinh ty -> funCall (specializeMathFunName ty "sinh") [e] Tanh ty -> funCall (specializeMathFunName ty "tanh") [e] Exp ty -> funCall (specializeMathFunName ty "exp") [e] Log ty -> funCall (specializeMathFunName ty "log") [e] Sqrt ty -> funCall (specializeMathFunName ty "sqrt") [e] Ceiling ty -> funCall (specializeMathFunName ty "ceil") [e] Floor ty -> funCall (specializeMathFunName ty "floor") [e] BwNot _ -> (C..~) e Cast _ ty -> C.Cast (transTypeName ty) e GetField (Struct _) _ f -> C.Dot e (accessorName f) -- | Translates a Copilot binary operator and its arguments into a C99 -- expression. transOp2 :: Op2 a b c -> C.Expr -> C.Expr -> C.Expr transOp2 op e1 e2 = case op of And -> e1 C..&& e2 Or -> e1 C..|| e2 Add _ -> e1 C..+ e2 Sub _ -> e1 C..- e2 Mul _ -> e1 C..* e2 Mod _ -> e1 C..% e2 Div _ -> e1 C../ e2 Fdiv _ -> e1 C../ e2 Pow ty -> funCall (specializeMathFunName ty "pow") [e1, e2] Logb ty -> funCall (specializeMathFunName ty "log") [e2] C../ funCall (specializeMathFunName ty "log") [e1] Atan2 ty -> funCall (specializeMathFunName ty "atan2") [e1, e2] Eq _ -> e1 C..== e2 Ne _ -> e1 C..!= e2 Le _ -> e1 C..<= e2 Ge _ -> e1 C..>= e2 Lt _ -> e1 C..< e2 Gt _ -> e1 C..> e2 BwAnd _ -> e1 C..& e2 BwOr _ -> e1 C..| e2 BwXor _ -> e1 C..^ e2 BwShiftL _ _ -> e1 C..<< e2 BwShiftR _ _ -> e1 C..>> e2 Index _ -> C.Index e1 e2 -- | Translates a Copilot ternary operator and its arguments into a C99 -- expression. transOp3 :: Op3 a b c d -> C.Expr -> C.Expr -> C.Expr -> C.Expr transOp3 op e1 e2 e3 = case op of Mux _ -> C.Cond e1 e2 e3 -- | Translate @'Abs' e@ in Copilot Core into a C99 expression. -- -- This function produces a portable implementation of abs in C99 that works -- for the type given, provided that the output fits in a variable of the same -- type (which may not be true, for example, for signed integers in the lower -- end of their type range). If the absolute value is out of range, the -- behavior is undefined. -- -- PRE: The type given is a Num type (floating-point number, or a -- signed/unsigned integer of fixed size). transAbs :: Type a -> C.Expr -> C.Expr transAbs ty e -- Abs for floats/doubles is called fabs in C99's math.h. | typeIsFloating ty = funCall (specializeMathFunName ty "fabs") [e] -- C99 provides multiple implementations of abs, depending on the type of -- the arguments. For integers, it provides C99 abs, labs, and llabs, which -- take, respectively, an int, a long int, and a long long int. -- -- However, the code produced by Copilot uses types with fixed width (e.g., -- int16_t), and there is no guarantee that, for example, 32-bit int or -- 64-bit int will fit in a C int (only guaranteed to be 16 bits). -- Consequently, this function provides a portable version of abs for signed -- and unsigned ints implemented using shift and xor. For example, for a -- value x of type int32_t, the absolute value is: -- (x + (x >> sizeof(int32_t)-1)) ^ (x >> sizeof(int32_t)-1)) | otherwise = (e C..+ (e C..>> tyBitSizeMinus1)) C..^ (e C..>> tyBitSizeMinus1) where -- Size of an integer type in bits, minus one. It's easier to hard-code -- them than to try and generate the right expressions in C using sizeof. -- -- PRE: the type 'ty' is a signed or unsigned integer type. tyBitSizeMinus1 :: C.Expr tyBitSizeMinus1 = case ty of Int8 -> C.LitInt 7 Int16 -> C.LitInt 15 Int32 -> C.LitInt 31 Int64 -> C.LitInt 63 Word8 -> C.LitInt 7 Word16 -> C.LitInt 15 Word32 -> C.LitInt 31 Word64 -> C.LitInt 63 _ -> impossible "transAbs" "copilot-c99" "Abs applied to unexpected types." -- | Translate @'Sign' e@ in Copilot Core into a C99 expression. -- -- Sign is is translated as @e > 0 ? 1 : (e < 0 ? -1 : e)@, that is: -- -- 1. If @e@ is positive, return @1@. -- -- 2. If @e@ is negative, return @-1@. -- -- 3. Otherwise, return @e@. This handles the case where @e@ is @0@ when the -- type is an integral type. If the type is a floating-point type, it also -- handles the cases where @e@ is @-0@ or @NaN@. -- -- This implementation is modeled after how GHC implements 'signum' -- . transSign :: Type a -> C.Expr -> C.Expr transSign ty e = positiveCase $ negativeCase e where -- If @e@ is positive, return @1@, otherwise fall back to argument. -- -- Produces the following code, where @@ is the argument to this -- function: -- @ -- e > 0 ? 1 : -- @ positiveCase :: C.Expr -- ^ Value returned if @e@ is not positive. -> C.Expr positiveCase = C.Cond (C.BinaryOp C.GT e (constNumTy ty 0)) (constNumTy ty 1) -- If @e@ is negative, return @1@, otherwise fall back to argument. -- -- Produces the following code, where @@ is the argument to this -- function: -- @ -- e < 0 ? -1 : -- @ negativeCase :: C.Expr -- ^ Value returned if @e@ is not negative. -> C.Expr negativeCase = C.Cond (C.BinaryOp C.LT e (constNumTy ty 0)) (constNumTy ty (-1)) -- | Transform a Copilot Core literal, based on its value and type, into a C99 -- literal. constTy :: Type a -> a -> C.Expr constTy ty = case ty of Bool -> C.LitBool Int8 -> explicitTy ty . C.LitInt . fromIntegral Int16 -> explicitTy ty . C.LitInt . fromIntegral Int32 -> explicitTy ty . C.LitInt . fromIntegral Int64 -> explicitTy ty . C.LitInt . fromIntegral Word8 -> explicitTy ty . C.LitInt . fromIntegral Word16 -> explicitTy ty . C.LitInt . fromIntegral Word32 -> explicitTy ty . C.LitInt . fromIntegral Word64 -> explicitTy ty . C.LitInt . fromIntegral Float -> explicitTy ty . C.LitFloat Double -> explicitTy ty . C.LitDouble Struct _ -> C.InitVal (transTypeName ty) . constStruct . toValues Array ty' -> C.InitVal (transTypeName ty) . constArray ty' . arrayElems -- | Transform a Copilot Core literal, based on its value and type, into a C99 -- initializer. constInit :: Type a -> a -> C.Init constInit ty val = case ty of -- We include two special cases for Struct and Array to avoid using constTy -- on them. -- -- In the default case (i.e., InitExpr (constTy ty val)), constant -- initializations are explicitly cast. However, doing so 1) may result in -- incorrect values for arrays, and 2) will be considered a non-constant -- expression in the case of arrays and structs, and thus not allowed as the -- initialization value for a global variable. -- -- In particular, wrt. (1), for example, the nested array: -- [[0, 1], [2, 3]] :: Array 2 (Array 2 Int32) -- -- with explicit casts, will be initialized in C as: -- { (int32_t[2]){(int32_t)(0), (int32_t)(1)}, -- (int32_t[2]){(int32_t)(2), (int32_t)(3)} } -- -- Due to the additional (int32_t[2]) casts, a C compiler will interpret the -- whole expression as an array of two int32_t's (as opposed to a nested -- array). This can either lead to compile-time errors (if you're lucky) or -- incorrect runtime semantics (if you're unlucky). Array ty' -> C.InitList $ constArray ty' $ arrayElems val -- We use InitArray to initialize a struct because the syntax used for -- initializing arrays and structs is compatible. For instance, {1, 2} works -- both for initializing an int array of length 2 as well as a struct with -- two int fields, although the two expressions are conceptually different -- (structs can also be initialized as { .a = 1, .b = 2}. Struct _ -> C.InitList $ constStruct (toValues val) _ -> C.InitExpr $ constTy ty val -- | Transform a Copilot Core struct field into a C99 initializer. constFieldInit :: Value a -> C.InitItem constFieldInit (Value ty (Field val)) = C.InitItem Nothing $ constInit ty val -- | Transform a Copilot Struct, based on the struct fields, into a list of C99 -- initializer values. constStruct :: [Value a] -> NonEmpty.NonEmpty C.InitItem constStruct val = NonEmpty.fromList $ map constFieldInit val -- | Transform a Copilot Array, based on the element values and their type, -- into a list of C99 initializer values. constArray :: Type a -> [a] -> NonEmpty.NonEmpty C.InitItem constArray ty = NonEmpty.fromList . map (C.InitItem Nothing . constInit ty) -- | Explicitly cast a C99 value to a type. explicitTy :: Type a -> C.Expr -> C.Expr explicitTy ty = C.Cast (transTypeName ty) -- Translate a literal number of type @ty@ into a C99 literal. -- -- PRE: The type of PRE is numeric (integer or floating-point), that -- is, not boolean, struct or array. constNumTy :: Type a -> Integer -> C.Expr constNumTy ty = case ty of Float -> C.LitFloat . fromInteger Double -> C.LitDouble . fromInteger _ -> C.LitInt -- | Provide a specialized function name in C99 for a function given the type -- of its arguments, and its "family" name. -- -- C99 provides multiple variants of the same conceptual function, based on the -- types. Depending on the function, common variants exist for signed/unsigned -- arguments, long or short types, float or double. The C99 standard uses the -- same mechanism to name most such functions: the default variant works for -- double, and there are additional variants for float and long double. For -- example, the sin function operates on double, while sinf operates on float, -- and sinl operates on long double. -- -- This function only knows how to provide specialized names for functions in -- math.h that provide a default version for a double argument and vary for -- floats. It won't change the function name given if the variation is based on -- the return type, if the function is defined elsewhere, or for other types. specializeMathFunName :: Type a -> String -> String specializeMathFunName ty s -- The following function pattern matches based on the variants available -- for a specific function. -- -- Do not assume that a function you need implemented follows the same -- standard as others: check whether it is present in the standard. | isMathFPArgs s , Float <- ty = s ++ "f" | otherwise = s where -- True if the function family name is part of math.h and follows the -- standard rule of providing multiple variants for floating point numbers -- based on the type of their arguments. -- -- Note: nan is not in this list because the names of its variants are -- determined by the return type. -- -- For details, see: -- "B.11 Mathematics " in the C99 standard isMathFPArgs :: String -> Bool isMathFPArgs = flip elem [ "acos", "asin", "atan", "atan2", "cos", "sin" , "tan", "acosh", "asinh", "atanh", "cosh", "sinh" , "tanh", "exp", "exp2", "expm1", "frexp", "ilogb" , "ldexp", "log", "log10", "log1p", "log2", "logb" , "modf", "scalbn", "scalbln", "cbrt", "fabs", "hypot" , "pow", "sqrt", "erf", "erfc", "lgamma", "tgamma" , "ceil", "floor", "nearbyint", "rint", "lrint", "llrint" , "round", "lround", "llround", "trunc", "fmod", "remainder" , "remquo", "copysign", "nextafter", "nexttoward", "fdim" , "fmax", "fmin", "fma" ] -- * Auxiliary functions -- | True if the type given is a floating point number. typeIsFloating :: Type a -> Bool typeIsFloating Float = True typeIsFloating Double = True typeIsFloating _ = False -- | Auxiliary type used to collect all the declarations of all the variables -- used in a function to be generated, since variable declarations are always -- listed first at the top of the function body. type FunEnv = [C.Decln] -- | Define a C expression that calls a function with arguments. funCall :: C.Ident -- ^ Function name -> [C.Expr] -- ^ Arguments -> C.Expr funCall name = C.Funcall (C.Ident name)