diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,26 @@ + Copyright (c) 2003-2013, ES Group at the School of Information and + Communication Technology, (Royal Institute of Technology, Stockholm, Sweden) + + All rights reserved. + + 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 SAM Group 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 SAM GROUP ``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 ForSyDe TEAM 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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,48 @@ +ForSyDe's Haskell-embedded Domain Specific Language. +==================================================== + +DESCRIPTION +----------- + + The ForSyDe (Formal System Design) methodology has been developed + with the objective to move system design to a higher level of + abstraction and to bridge the abstraction gap by transformational + design refinement. + + This library provides ForSyDe's implementation as a Haskell-embedded + Domain Specific Language (DSL). + + For more information, please see ForSyDe's website: + https://forsyde.github.io/ + + +INSTALLATION +------------ + +ForSyDe depends on GHC vesions 7.10.3 or 8.0.1 due to the use of +numerous extensions, namely Template Haskell (TH). + +It depends on the +[`type-level`](https://github.com/forsyde/type-level) and +[`parameterized-data`](https://github.com/forsyde/parameterized-data) +packages and some others normally bundled with GHC distributions. + +For synthesis and simulation of the generated VHDL the Altera toolchain is +supported. Quartus and Modelsim need to be on the PATH for these features to +work. Additionally the open-source VHDL simulator Ghdl is supported from +version ghdl-0.33 onwards. + +This package can be installed with: + +* Cabal, provided you have installed the right version of GHC and its + dependent `cabal-install` package using the commands: + + cabal install # --with-ghc=path/to/ghc-version # installs forsyde-deep + cabal haddock # generates documentation. Needs Haddock > 2.0 + +* Stack, which takes care of all dependencies and installs everything + (including the compiler) in a sandboxed environment: + + stack install # installs forsyde-deep + stack haddock # generates documentation + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,110 @@ +#! /usr/bin/env runhaskell +module Main (main) where + +import Control.Monad (liftM, when) +import Data.List (intersperse) +import Distribution.Simple +import Distribution.Simple.Setup +import Distribution.Simple.LocalBuildInfo +import Distribution.PackageDescription +import System.Process +import System.Exit +import System.Directory +import System.FilePath + +main :: IO () +main = defaultMainWithHooks simpleUserHooks{postInst=forsydePostInst, + postCopy=forsydePostCopy} + +forsydePostInst :: Args -> InstallFlags -> PackageDescription -> + LocalBuildInfo -> IO () +forsydePostInst _ _ = compile_forsyde_vhd NoCopyDest + +forsydePostCopy :: Args -> CopyFlags -> PackageDescription -> + LocalBuildInfo -> IO () +forsydePostCopy _ cf = compile_forsyde_vhd $ removeFlag $ (copyDest cf) where + removeFlag c = case c of + Distribution.Simple.Setup.Flag x -> x + _ -> error "Not a Flag" + + +-- NOTE: Most of this code is duplicated from ForSyDe.Backend.VHDL.Modelsim, +-- however, it allows Setup.hs to be selfcontained + +-- Compile forsyde.vhd if possible, showing what's going on to the end user +compile_forsyde_vhd :: CopyDest -> PackageDescription -> LocalBuildInfo + -> IO () +compile_forsyde_vhd cd pd lbi = do + putStrLn "Compiling ForSyDe's VHDL library with Modelsim ..." + (ifNot isModelsimInstalled + (modelsimError "Modelsim executables could not be found.")) <&&> + (ifNot (do_compile_forsyde_vhd forsyde_vhd_dir) + ( modelsimError "Compilation failed.")) <&&> + (putStrLn "Compilation succeded." >> return True) + return () + where + forsyde_vhd_dir = (datadir $ absoluteInstallDirs pd lbi cd) + "lib" + modelsimError err = putStrLn $ + "Warning: " ++ err ++ "\n" ++ + " ForSyDe will work, but you will not be able to automatically\n" ++ + " compile or simulate the ForSyDe-generated VHDL models with Modelsim\n\n" ++ + " In order to fix this, make sure that the Modelsim executables\n" ++ + " can be found in PATH and reinstall ForSyDe" + +-- Look for modelsim executables +isModelsimInstalled :: IO Bool +isModelsimInstalled = executablePresent "vlib" <&&> + executablePresent "vmap" <&&> + executablePresent "vcom" + where executablePresent = (liftM (maybe False (\_-> True))) .findExecutable + +-- Create a modelsim library for forsyde.vhd +-- in the same directory in which forsyde.vhd was copied +do_compile_forsyde_vhd :: FilePath -- ^ absolute directory which + -- forsyde.vhd was copied into + -> IO Bool +do_compile_forsyde_vhd dir = + (runCommandMsg "vlib" [dir "modelsim"]) <&&> + (runCommandMsg + "vcom" ["-93", "-quiet", "-nologo", "-work", dir "modelsim", + dir "forsyde.vhd"]) + where runWait :: String -> FilePath -> [String] -> IO Bool + runWait msg proc args = do + putStrLn msg + h <- runProcess proc args (Just dir) Nothing Nothing Nothing Nothing + code <- waitForProcess h + return $ code == ExitSuccess + +-- | run a command showing what's being run +runCommandMsg :: String -- ^ Command to execute + -> [String] -- ^ Command arguments + -> IO Bool +runCommandMsg command args = runWait msg command args + where msg = "Running: " ++ command ++ " " ++ (concat $ intersperse " " args) + + +-- | Run a process, previously announcing a message and waiting for it +-- to finnish its execution. +runWait :: String -- ^ message to show + -> FilePath -- ^ command to execute + -> [String] -- ^ command arguments + -> IO Bool -- ^ Did the execution end succesfully? +runWait msg proc args = do + putStrLn msg + h <- runProcess proc args Nothing Nothing Nothing Nothing Nothing + code <- waitForProcess h + return $ code == ExitSuccess + + +-- | short-circuit and for monads +(<&&>) :: Monad m => m Bool -> m Bool -> m Bool +x <&&> y = do p <- x + if p then y else return False + +-- | execute an action when the argument is False +-- and return the boolean value +ifNot :: Monad m => m Bool -> m () -> m Bool +ifNot x a = do p <- x + when (not p) a + return p diff --git a/examples/ALU.hs b/examples/ALU.hs new file mode 100644 --- /dev/null +++ b/examples/ALU.hs @@ -0,0 +1,340 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- The following example is designed as tutorial example for the paper. +-- +-- It implements a simple ALU, which has the following modes +-- HH: out <- a AND b +-- HL: out <- a OR b +-- LH: (cout, out) <- ADD a b +-- LL: out <- shiftl a 0 +-- +-- The expressiveness of the compiler could be clearly improved, if the +-- higher-order function 'zipWith' that works on vectors would be synthesizable. +-- Check 'and4BitFun'! +-- +-- We could improve the example even further, if we use enumeration types for the +-- multiplexer. So far I have not done it, but should only be a matter of time! + +module ALU where + +import ForSyDe.Deep +import Data.Bits +import Data.Param.FSVec +import Data.TypeLevel.Num.Reps +import Data.TypeLevel.Num.Aliases + + +----- AND - 4 Bit + +and4BitFun :: ProcFun (FSVec D4 Bit -> FSVec D4 Bit -> FSVec D4 Bit) +and4BitFun = $(newProcFun [d| and4BitFun :: FSVec D4 Bit + -> FSVec D4 Bit + -> FSVec D4 Bit + --and4BitFun a b = Data.Param.FSVec.zipWith (.&.) a b + and4BitFun a b = (a!d3 .&. b!d3) +> (a!d2 .&. b!d2) +> (a!d1 .&. b!d1) +> (a!d0 .&. b!d0) +> empty + |]) + + +and4BitProc :: Signal (FSVec D4 Bit) + -> Signal (FSVec D4 Bit) + -> Signal (FSVec D4 Bit) +and4BitProc = zipWithSY "and4" and4BitFun + +and4BitSys :: SysDef (Signal (FSVec D4 Bit) + -> Signal (FSVec D4 Bit) + -> Signal (FSVec D4 Bit)) +and4BitSys = newSysDef and4BitProc "and4Bit" ["a", "b"] ["y"] + +simAnd4Bit :: [FSVec D4 Bit] -> [FSVec D4 Bit] -> [FSVec D4 Bit] +simAnd4Bit = simulate and4BitSys + +vhdlAnd4Bit = writeVHDL and4BitSys + + +----- OR - 4 Bit + +or4BitFun :: ProcFun (FSVec D4 Bit -> FSVec D4 Bit -> FSVec D4 Bit) +or4BitFun = $(newProcFun [d| or4BitFun :: FSVec D4 Bit -> FSVec D4 Bit -> FSVec D4 Bit + --or4BitFun a b = Data.Param.FSVec.zipWith (.&.) a b + or4BitFun a b = (a!d3 .|. b!d3) +> (a!d2 .|. b!d2) +> (a!d1 .|. b!d1) +> (a!d0 .|. b!d0) +> empty + |]) + + +or4BitProc :: Signal (FSVec D4 Bit) + -> Signal (FSVec D4 Bit) + -> Signal (FSVec D4 Bit) +or4BitProc = zipWithSY "or4" or4BitFun + +or4BitSys :: SysDef (Signal (FSVec D4 Bit) + -> Signal (FSVec D4 Bit) + -> Signal (FSVec D4 Bit)) +or4BitSys = newSysDef or4BitProc "or4Bit" ["a", "b"] ["y"] + +simOr4Bit :: [FSVec D4 Bit] -> [FSVec D4 Bit] -> [FSVec D4 Bit] +simOr4Bit = simulate or4BitSys + +vhdlOr4Bit = writeVHDL or4BitSys + +----- Logical Shift Left + +lslFun :: ProcFun (FSVec D4 Bit -> FSVec D4 Bit) +lslFun = $(newProcFun [d| lslFun :: FSVec D4 Bit -> FSVec D4 Bit + lslFun a = shiftl a L + |]) + +lslProc :: Signal (FSVec D4 Bit) -> Signal (FSVec D4 Bit) +lslProc = mapSY "lsl" lslFun + +lslSys :: SysDef (Signal (FSVec D4 Bit) -> Signal (FSVec D4 Bit)) +lslSys = newSysDef lslProc "lsl" ["in"] ["out"] + +simLsl :: [FSVec D4 Bit] -> [FSVec D4 Bit] +simLsl = simulate lslSys + +vhdlLsl = writeVHDL lslSys + +----- Mux 4/1 (no use of FSVec as input, only for selection) + +mux41Fun :: ProcFun (FSVec D2 Bit + -> FSVec D4 Bit + -> FSVec D4 Bit + -> FSVec D4 Bit + -> FSVec D4 Bit + -> FSVec D4 Bit) +mux41Fun = $(newProcFun [d| mux41Fun :: FSVec D2 Bit + -> FSVec D4 Bit + -> FSVec D4 Bit + -> FSVec D4 Bit + -> FSVec D4 Bit + -> FSVec D4 Bit + mux41Fun sel x3 x2 x1 x0 + = if sel == H +> H +> empty then + x3 + else + if sel == H +> L +> empty then + x2 + else + if sel == L +> H +> empty then + x1 + else + x0 + |]) + +mux41Proc :: Signal (FSVec D2 Bit) -> Signal (FSVec D4 Bit) + -> Signal (FSVec D4 Bit) -> Signal (FSVec D4 Bit) + -> Signal (FSVec D4 Bit) -> Signal (FSVec D4 Bit) +mux41Proc = zipWith5SY "mux41" mux41Fun + +mux41Sys :: SysDef (Signal (FSVec D2 Bit) -> Signal (FSVec D4 Bit) + -> Signal (FSVec D4 Bit) -> Signal (FSVec D4 Bit) + -> Signal (FSVec D4 Bit) -> Signal (FSVec D4 Bit)) +mux41Sys = newSysDef mux41Proc "mux41" ["sel", "d3", "d2", "d1", "d0"] ["out"] + +simMux41 :: [FSVec D2 Bit] -> [FSVec D4 Bit] -> [FSVec D4 Bit] + -> [FSVec D4 Bit] -> [FSVec D4 Bit] -> [FSVec D4 Bit] +simMux41 = simulate mux41Sys + +vhdlMux41 = writeVHDL mux41Sys + +----- Convert FSVector to Tuple (Size 4) + +convFromFSVec4Fun :: ProcFun (FSVec D4 Bit -> (Bit, Bit, Bit, Bit)) +convFromFSVec4Fun = $(newProcFun [d| convFromFSVec4Fun :: FSVec D4 Bit -> (Bit, Bit, Bit, Bit) + convFromFSVec4Fun v + = (v!d3, v!d2, v!d1, v!d0) + |]) + +convFromFSVec4Proc :: Signal (FSVec D4 Bit) -> (Signal Bit, Signal Bit, Signal Bit, Signal Bit) +convFromFSVec4Proc = (unzip4SY "unzip4" . mapSY "conv4" convFromFSVec4Fun) + +convFromFSVec4Sys :: SysDef (Signal (FSVec D4 Bit) -> (Signal Bit, Signal Bit, Signal Bit, Signal Bit)) +convFromFSVec4Sys = newSysDef convFromFSVec4Proc "convFromFSVec" ["vector4"] ["v3", "v2", "v1", "v0"] + +simConvFromFSVec4 :: [FSVec D4 Bit] -> ([Bit], [Bit], [Bit], [Bit]) +simConvFromFSVec4 = simulate convFromFSVec4Sys + +vhdlConvFromFSVec4 = writeVHDL convFromFSVec4Sys + +----- Convert To FSVector (Size 4) + +convToFSVec4Fun :: ProcFun (Bit -> Bit -> Bit -> Bit -> FSVec D4 Bit) +convToFSVec4Fun = $(newProcFun [d| convToFSVec4Fun :: Bit -> Bit -> Bit -> Bit -> FSVec D4 Bit + convToFSVec4Fun x3 x2 x1 x0 + = x3 +> x2 +> x1 +> x0 +> empty |]) + +convToFSVec4Proc :: Signal Bit -> Signal Bit -> Signal Bit -> Signal Bit -> Signal (FSVec D4 Bit) +convToFSVec4Proc = zipWith4SY "toVector4" convToFSVec4Fun + +convToFSVec4Sys :: SysDef (Signal Bit -> Signal Bit -> Signal Bit -> Signal Bit -> Signal (FSVec D4 Bit)) +convToFSVec4Sys = newSysDef convToFSVec4Proc "convToFSVec" ["x3", "x2", "x1", "x0"] ["vec4"] + +simConvToFSVec4 = simulate convToFSVec4Sys + +vhdlConvToFSVec4 = writeVHDL convToFSVec4Sys + +------ Full Adder + +fullAddFun :: ProcFun (Bit -> Bit -> Bit -> (Bit, Bit)) +fullAddFun = $(newProcFun + [d|fullAddFun :: Bit -> Bit -> Bit -> (Bit, Bit) + fullAddFun a b c_in = (c_out, sum) + where c_out :: Bit + c_out = (a .&. b) .|. (a .&. c_in) .|. (b .&. c_in) + sum :: Bit + sum = (a `xor` b) `xor` c_in |]) + + +--fullAddProc :: Signal Bit -> Signal Bit -> Signal Bit -> Signal (Bit, Bit) +--fullAddProc = zipWith3SY "fulladd" fullAddFun +fullAddProc :: Signal Bit -> Signal Bit -> Signal Bit -> (Signal Bit, Signal Bit) +fullAddProc a b c_in = (unzipSY "unzipSY") $ (zipWith3SY "fulladd" fullAddFun a b c_in) + +fullAddSys :: SysDef (Signal Bit -> Signal Bit -> Signal Bit -> (Signal Bit, Signal Bit)) +fullAddSys = newSysDef fullAddProc "fullAddSys" ["a", "b", "c_in"] ["cout", "sum"] + +simFullAdd :: [Bit] -> [Bit] -> [Bit] -> ([Bit], [Bit]) +simFullAdd = simulate fullAddSys + +--vhdlFullAdd = writeVHDL fullAddSys + +a_in = [L,L,L,L,H,H,H,H] +b_in = [L,H,L,H,L,H,L,H] +c_in = [L,L,H,H,L,L,H,H] + +------ 4-bit Adder Chain + +fourBitAdder :: Signal Bit -- C_IN + -> Signal Bit -- A3 + -> Signal Bit -- A2 + -> Signal Bit -- A1 + -> Signal Bit -- A0 + -> Signal Bit -- B3 + -> Signal Bit -- B2 + -> Signal Bit -- B1 + -> Signal Bit -- B0 + -> (Signal Bit, -- C_OUT + Signal Bit, -- SUM3 + Signal Bit, -- SUM2 + Signal Bit, -- SUM1 + Signal Bit) -- SUM0 +fourBitAdder c_in a3 a2 a1 a0 b3 b2 b1 b0 + = (c_out, sum3, sum2, sum1, sum0) + where (c_out, sum3) = (instantiate "add3" fullAddSys) a3 b3 c2 + (c2, sum2) = (instantiate "add2" fullAddSys) a2 b2 c1 + (c1, sum1) = (instantiate "add1" fullAddSys) a1 b1 c0 + (c0, sum0) = (instantiate "add0" fullAddSys) a0 b0 c_in + +fourBitAdderSys :: SysDef (Signal Bit -- C_IN + -> Signal Bit -- A3 + -> Signal Bit -- A2 + -> Signal Bit -- A1 + -> Signal Bit -- A0 + -> Signal Bit -- B3 + -> Signal Bit -- B2 + -> Signal Bit -- B1 + -> Signal Bit -- B0 + -> (Signal Bit, -- C_OUT + Signal Bit, -- SUM3 + Signal Bit, -- SUM2 + Signal Bit, -- SUM1 + Signal Bit)) -- SUM0 +fourBitAdderSys = newSysDef fourBitAdder "fourBitAdder" ["C_IN", "A3", "A2", "A1", "A0", + "B3", "B2", "B1", "B0"] + ["C_OUT", "SUM3", "SUM2", "SUM1", "SUM0"] + +simFourBitAdder = simulate fourBitAdderSys + +vhdlFourBitAdder = writeVHDL fourBitAdderSys + +a0 = [L,L,L,L,L,L,L,L,H,H,H,H,H,H,H,H] +a1 = [L,L,L,L,H,H,H,H,L,L,L,L,H,H,H,H] +a2 = [L,L,H,H,L,L,H,H,L,L,H,H,L,L,H,H] +a3 = [L,H,L,H,L,H,L,H,L,H,L,H,L,H,L,H] +zero = [L,L,L,L,L,L,L,L,L,L,L,L,L,L,L,L] +one = [H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H] + + +simAdd_0 = simFourBitAdder zero a3 a2 a1 a0 a3 a2 a1 a0 +simAdd_1 = simFourBitAdder one a3 a2 a1 a0 a3 a2 a1 a0 + + +----- FSVec Adder +add4FSVecProc :: Signal (FSVec D4 Bit) + -> Signal (FSVec D4 Bit) + -> (Signal Bit, Signal (FSVec D4 Bit)) +add4FSVecProc a b = (cout, sum) + where + (a3,a2,a1,a0) = (instantiate "split_a" convFromFSVec4Sys) a + (b3,b2,b1,b0) = (instantiate "split_b" convFromFSVec4Sys) b + (cout, s3, s2, s1, s0) = (instantiate "adder" fourBitAdderSys) zero a3 a2 a1 a0 b3 b2 b1 b0 + sum = (instantiate "merge" convToFSVec4Sys) s3 s2 s1 s0 + zero = instantiate "Zero" zeroSys + +add4FSVecSys :: SysDef (Signal (FSVec D4 Bit) + -> Signal (FSVec D4 Bit) + -> (Signal Bit, Signal (FSVec D4 Bit))) +add4FSVecSys = newSysDef add4FSVecProc "add4FSVec" ["a", "b"] ["cout", "sum"] + +simAdd4FSVecSys = simulate add4FSVecSys + +vhdlAdd4FSVecSys = writeVHDL add4FSVecSys + +----- Constant Signals + +-- Constant input 'H' modeled with constSY +oneProc :: Signal Bit +oneProc = constSY "high" H + +oneSys :: SysDef (Signal Bit) +oneSys = newSysDef oneProc "one" [] ["one"] + +-- Constant input 'L' modeled with constSY +zeroProc :: Signal Bit +zeroProc = constSY "low" L + +zeroSys :: SysDef (Signal Bit) +zeroSys = newSysDef zeroProc "zero" [] ["zero"] + +----- ALU + +aluProc :: Signal(FSVec D2 Bit) + -> Signal (FSVec D4 Bit) + -> Signal (FSVec D4 Bit) + -> (Signal Bit, Signal (FSVec D4 Bit)) +aluProc sel a b = (cout, out) + where + andOut = (instantiate "and" and4BitSys) a b + orOut = (instantiate "or" or4BitSys) a b + (cout, sum) = (instantiate "add" add4FSVecSys) a b + lslOut = (instantiate "lsl" lslSys) a + out = (instantiate "mux" mux41Sys) sel andOut orOut sum lslOut + + +aluSys :: SysDef (Signal(FSVec D2 Bit) + -> Signal (FSVec D4 Bit) + -> Signal (FSVec D4 Bit) + -> (Signal Bit, Signal (FSVec D4 Bit))) +aluSys = newSysDef aluProc "alu" ["sel", "a", "b"] ["cout", "data"] + + +simALU :: [FSVec D2 Bit] -> [FSVec D4 Bit] -> [FSVec D4 Bit] -> ([Bit], [FSVec D4 Bit]) +simALU = simulate aluSys + +vhdlALU = writeVHDL aluSys + +----- Test-Inputs + +sel = [reallyUnsafeVector [H,H], -- AND + reallyUnsafeVector [H,L], -- OR + reallyUnsafeVector [L,H], -- ADD + reallyUnsafeVector [L,L]] -- LSL + +a = [reallyUnsafeVector [L,H,H,H], -- LSB D1 D2 MSB + reallyUnsafeVector [L,H,L,H], + reallyUnsafeVector [H,H,H,H], + reallyUnsafeVector [L,H,H,H]] + +b = [reallyUnsafeVector [H,H,H,H], + reallyUnsafeVector [H,H,L,H], + reallyUnsafeVector [H,L,L,L], + reallyUnsafeVector [H,H,H,H]] diff --git a/examples/ALU_Shallow.hs b/examples/ALU_Shallow.hs new file mode 100644 --- /dev/null +++ b/examples/ALU_Shallow.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- *** Shallow-Embedded ForSyDe Model *** +-- +-- The following example is designed as tutorial example for the paper. +-- +-- It implements a simple ALU, which has the following modes +-- HH: out <- a AND b +-- HL: out <- a OR b +-- LH: (cout, out) <- ADD a b +-- LL: out <- shiftl a 0 +-- + +module ALU_Shallow where + +import ForSyDe.Shallow +import ForSyDe.Deep.Bit +import Data.Bits +import Data.Param.FSVec +import Data.TypeLevel.Num.Reps +import Data.TypeLevel.Num.Aliases + + + +----- AND - 4 Bit + +and4Bit :: Signal (FSVec D4 Bit) + -> Signal (FSVec D4 Bit) + -> Signal (FSVec D4 Bit) +and4Bit = zipWithSY (Data.Param.FSVec.zipWith (.&.)) + +----- OR - 4 Bit + +or4Bit :: Signal (FSVec D4 Bit) + -> Signal (FSVec D4 Bit) + -> Signal (FSVec D4 Bit) +or4Bit = zipWithSY (Data.Param.FSVec.zipWith (.|.)) + +----- Logical Shift Left + + + +lsl :: Signal (FSVec D4 Bit) -> Signal (FSVec D4 Bit) +lsl = mapSY shiftl_L where + shiftl_L v = shiftl v L + +----- Mux 4/1 (no use of FSVec as input, only for selection) + +mux41Fun :: FSVec D2 Bit + -> FSVec D4 Bit + -> FSVec D4 Bit + -> FSVec D4 Bit + -> FSVec D4 Bit + -> FSVec D4 Bit +mux41Fun sel x3 x2 x1 x0 = if sel == H +> H +> empty then + x3 + else + if sel == H +> L +> empty then + x2 + else + if sel == L +> H +> empty then + x1 + else + x0 + + +mux41 :: Signal (FSVec D2 Bit) -> Signal (FSVec D4 Bit) + -> Signal (FSVec D4 Bit) -> Signal (FSVec D4 Bit) + -> Signal (FSVec D4 Bit) -> Signal (FSVec D4 Bit) +mux41 = zipWith5SY mux41Fun + +----- Convert FSVector to Tuple (Size 4) + +convFromFSVec4 :: FSVec D4 a -> (a, a, a, a) +convFromFSVec4 v = (v!d3, v!d2, v!d1, v!d0) + +----- Convert To FSVector (Size 4) + +convToFSVec4 :: a -> a -> a -> a -> FSVec D4 a +convToFSVec4 x3 x2 x1 x0 = x3 +> x2 +> x1 +> x0 +> empty + +----- 4-Bit Adder + +------ 4-bit Adder Chain + + +fourBitAdder :: Signal Bit -- C_IN + -> Signal Bit -- A3 + -> Signal Bit -- A2 + -> Signal Bit -- A1 + -> Signal Bit -- A0 + -> Signal Bit -- B3 + -> Signal Bit -- B2 + -> Signal Bit -- B1 + -> Signal Bit -- B0 + -> (Signal Bit, -- C_OUT + Signal Bit, -- SUM3 + Signal Bit, -- SUM2 + Signal Bit, -- SUM1 + Signal Bit) -- SUM0 +fourBitAdder c_in a3 a2 a1 a0 b3 b2 b1 b0 + = (c_out, sum3, sum2, sum1, sum0) + where (c_out, sum3) = unzipSY $ zipWith3SY fullAdd a3 b3 c2 + (c2, sum2) = unzipSY $ zipWith3SY fullAdd a2 b2 c1 + (c1, sum1) = unzipSY $ zipWith3SY fullAdd a1 b1 c0 + (c0, sum0) = unzipSY $ zipWith3SY fullAdd a0 b0 c_in + +fullAdd a b cin = (cout, sum) + where + cout = (a .&. b) .|. (a .&. cin) .|. (b .&. cin) + sum = (a `xor` b) `xor` cin + +----- FSVec Adder +add4FSVec :: Signal (FSVec D4 Bit) + -> Signal (FSVec D4 Bit) + -> (Signal Bit, Signal (FSVec D4 Bit)) +add4FSVec a b = (cout, sum) + where + (a3,a2,a1,a0) = unzip4SY $ mapSY convFromFSVec4 a + (b3,b2,b1,b0) = unzip4SY $ mapSY convFromFSVec4 b + (cout, s3, s2, s1, s0) = fourBitAdder zero a3 a2 a1 a0 b3 b2 b1 b0 + sum = zipWith4SY convToFSVec4 s3 s2 s1 s0 + zero = sourceSY id L + +----- ALU + +alu :: Signal(FSVec D2 Bit) + -> Signal (FSVec D4 Bit) + -> Signal (FSVec D4 Bit) + -> (Signal Bit, Signal (FSVec D4 Bit)) +alu sel a b = (cout, out) + where + andOut = and4Bit a b + orOut = or4Bit a b + (cout, sum) = add4FSVec a b + lslOut = lsl a + out = mux41 sel andOut orOut sum lslOut + + + +----- Test-Inputs + +sel = signal [reallyUnsafeVector [H,H], -- AND + reallyUnsafeVector [H,L], -- OR + reallyUnsafeVector [L,H], -- ADD + reallyUnsafeVector [L,L]] -- LSL + +a = signal [reallyUnsafeVector [L,H,H,H], + reallyUnsafeVector [L,H,L,H], + reallyUnsafeVector [L,H,H,H], + reallyUnsafeVector [L,H,H,H]] + +b = signal [reallyUnsafeVector [H,H,H,H], + reallyUnsafeVector [H,H,L,H], + reallyUnsafeVector [H,H,H,H], + reallyUnsafeVector [H,H,H,H]] + +c = signal [reallyUnsafeVector [L,L,L,L], -- LSB D1 D2 MSB + reallyUnsafeVector [H,L,L,L], + reallyUnsafeVector [L,L,L,H], + reallyUnsafeVector [L,L,L,H]] + +d = signal [reallyUnsafeVector [L,L,L,L], + reallyUnsafeVector [L,L,L,L], + reallyUnsafeVector [L,L,L,H], + reallyUnsafeVector [H,H,H,H]] + +x0 = signal [L,L,L,L] +x1 = signal [H,H,H,H] + +-- Helper functions +zipWith5SY :: (a -> b -> c -> d -> e -> f) + -> Signal a + -> Signal b + -> Signal c + -> Signal d + -> Signal e + -> Signal f +zipWith5SY _ NullS _ _ _ _ = NullS +zipWith5SY _ _ NullS _ _ _ = NullS +zipWith5SY _ _ _ NullS _ _ = NullS +zipWith5SY _ _ _ _ NullS _ = NullS +zipWith5SY _ _ _ _ _ NullS = NullS +zipWith5SY f (a :- as) (b :- bs) (c :- cs) (d :- ds) (e:-es) = + f a b c d e :- zipWith5SY f as bs cs ds es diff --git a/examples/BitVector.hs b/examples/BitVector.hs new file mode 100644 --- /dev/null +++ b/examples/BitVector.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE TemplateHaskell #-} +-- example module to test bit conversion functions +module BitVector where + +import ForSyDe.Deep +import Data.Int (Int32) +import Data.Param.FSVec +import Data.TypeLevel.Num (D32) + +to32BitFun :: ProcFun (Int32 -> FSVec D32 Bit) +to32BitFun = $(newProcFun + [d| to32Bit :: Int32 -> FSVec D32 Bit + to32Bit i = toBitVector32 i |]) + +to32BitProc :: Signal Int32 -> Signal (FSVec D32 Bit) +to32BitProc = mapSY "to32Proc" to32BitFun + +to32BitSysDef :: SysDef (Signal Int32 -> Signal (FSVec D32 Bit)) +to32BitSysDef = newSysDef to32BitProc "to32BitSys" ["in1"] ["out1"] diff --git a/examples/ButtonEncoder.hs b/examples/ButtonEncoder.hs new file mode 100644 --- /dev/null +++ b/examples/ButtonEncoder.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE TemplateHaskell, DeriveDataTypeable #-} + +module ButtonEncoder where + +import ForSyDe.Deep +import Language.Haskell.TH.Lift +import Data.Generics (Data, Typeable) +import Prelude hiding (Either(..)) + +-- Combinational syncrhonous system to encode the keypresses of +-- an arrow-keypad into directions which are easier to process +-- +-- This example shows how the VHDL backend can process custom Enumerated +-- Algebraic types (ie. Algebraic types whose data constructors have all +-- zero arity) + + +data Direction = Up | Down | Left | Right | Unknown + deriving (Data, Typeable, Show, Eq) + +deriveLift1 ''Direction + +type ButtonPress = (Bit, -- is left pressed + Bit, -- is right pressed + Bit, -- is up pressed + Bit) -- is down pressed + +buttonEncoder :: Signal ButtonPress -> Signal Direction +buttonEncoder = mapSY "encoder" transFun + where transFun = + $(newProcFun [d| transFun (left,right,up,down) = + if left == H then Left else + if right == H then Right else + if up == H then Up else + if down == H then Down else Unknown |]) + +buttonEncoderSys :: SysDef (Signal ButtonPress -> Signal Direction) +buttonEncoderSys = newSysDef buttonEncoder "buttonEncoder" ["buttonPress"] ["direction"] + + +simButtonEncoder :: [ButtonPress] -> [Direction] +simButtonEncoder = simulate buttonEncoderSys + diff --git a/examples/CarrySelectAdder.hs b/examples/CarrySelectAdder.hs new file mode 100644 --- /dev/null +++ b/examples/CarrySelectAdder.hs @@ -0,0 +1,395 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- This module models a 16-bit carry select adder + + +module CarrySelectAdder where + +import ForSyDe.Deep -- Definition of Bit data type +import Data.Bits -- Operations for Bit data type +import Data.Param.FSVec +import Data.TypeLevel.Num.Reps +import Data.TypeLevel.Num.Aliases + +-- First we create a four bit carry select adder. +-- It uses eight full adders and five 2/1 muxes. + +------ Full Adder + +fullAddFun :: ProcFun (Bit -> Bit -> Bit -> (Bit, Bit)) +fullAddFun = $(newProcFun [d|fullAddFun :: Bit -> Bit -> Bit -> (Bit, Bit) + -- I would like to use 'where'-clauses. Is this possible? + -- fullAddFun a b c_in = (c_out, sum) + -- where c_out = (a .&. b) .|. (a .&. c_in) .|. (b .&. c_in) + -- sum = (a `xor` b) `xor` c_in |]) + fullAddFun a b c_in = ((a .&. b) .|. (a .&. c_in) .|. (b .&. c_in), + (a `xor` b) `xor` c_in) |]) + +--fullAddProc :: Signal Bit -> Signal Bit -> Signal Bit -> Signal (Bit, Bit) +--fullAddProc = zipWith3SY "fulladd" fullAddFun +fullAddProc :: Signal Bit -> Signal Bit -> Signal Bit -> (Signal Bit, Signal Bit) +fullAddProc a b c_in = (unzipSY "unzipSY") $ (zipWith3SY "fulladd" fullAddFun a b c_in) + +fullAddSys :: SysDef (Signal Bit -> Signal Bit -> Signal Bit -> (Signal Bit, Signal Bit)) +fullAddSys = newSysDef fullAddProc "fullAdd" ["a", "b", "c_in"] ["cout", "sum"] + +simFullAdd :: [Bit] -> [Bit] -> [Bit] -> ([Bit], [Bit]) +simFullAdd = simulate fullAddSys + +--vhdlFullAdd = writeVHDL fullAddSys + +a_in = [L,L,L,L,H,H,H,H] +b_in = [L,H,L,H,L,H,L,H] +c_in = [L,L,H,H,L,L,H,H] + + +------ 2/1 Multiplexer + +--mux21Fun :: ProcFun (Bit -> Bit -> Bit -> Bit) +--mux21Fun = $(newProcFun [d|mux21Fun :: Bit -> Bit -> Bit -> Bit +-- mux21Fun sel d1 d0 = if (sel == L) then +-- d0 +-- else +-- d1 |]) + +mux21Proc :: Signal Bit -> Signal Bit -> Signal Bit -> Signal Bit +mux21Proc = zipWith3SY "mux21" mux21Fun + +mux21Sys :: SysDef (Signal Bit -> Signal Bit -> Signal Bit -> Signal Bit) +mux21Sys = newSysDef mux21Proc "mux21" ["sel", "d1", "d0"] ["out"] + +simMux21 :: [Bit] -> [Bit] -> [Bit] -> [Bit] +simMux21 = simulate mux21Sys + +vhdlMux21 = writeVHDL mux21Sys + +------ 4-bit Adder Chain + +fourBitAdder :: Signal Bit -- C_IN + -> Signal Bit -- A3 + -> Signal Bit -- A2 + -> Signal Bit -- A1 + -> Signal Bit -- A0 + -> Signal Bit -- B3 + -> Signal Bit -- B2 + -> Signal Bit -- B1 + -> Signal Bit -- B0 + -> (Signal Bit, -- C_OUT + Signal Bit, -- SUM3 + Signal Bit, -- SUM2 + Signal Bit, -- SUM1 + Signal Bit) -- SUM0 +fourBitAdder c_in a3 a2 a1 a0 b3 b2 b1 b0 + = (c_out, sum3, sum2, sum1, sum0) + where (c_out, sum3) = (instantiate "add3" fullAddSys) a3 b3 c2 + (c2, sum2) = (instantiate "add2" fullAddSys) a2 b2 c1 + (c1, sum1) = (instantiate "add1" fullAddSys) a1 b1 c0 + (c0, sum0) = (instantiate "add0" fullAddSys) a0 b0 c_in + +fourBitAdderSys :: SysDef (Signal Bit -- C_IN + -> Signal Bit -- A3 + -> Signal Bit -- A2 + -> Signal Bit -- A1 + -> Signal Bit -- A0 + -> Signal Bit -- B3 + -> Signal Bit -- B2 + -> Signal Bit -- B1 + -> Signal Bit -- B0 + -> (Signal Bit, -- C_OUT + Signal Bit, -- SUM3 + Signal Bit, -- SUM2 + Signal Bit, -- SUM1 + Signal Bit)) -- SUM0 +fourBitAdderSys = newSysDef fourBitAdder "fourBitAdder" ["C_IN", "A3", "A2", "A1", "A0", + "B3", "B2", "B1", "B0"] + ["C_OUT", "SUM3", "SUM2", "SUM1", "SUM0"] + +simFourBitAdder = simulate fourBitAdderSys + +vhdlFourBitAdder = writeVHDL fourBitAdderSys + +a0 = [L,L,L,L,L,L,L,L,H,H,H,H,H,H,H,H] +a1 = [L,L,L,L,H,H,H,H,L,L,L,L,H,H,H,H] +a2 = [L,L,H,H,L,L,H,H,L,L,H,H,L,L,H,H] +a3 = [L,H,L,H,L,H,L,H,L,H,L,H,L,H,L,H] +zero = [L,L,L,L,L,L,L,L,L,L,L,L,L,L,L,L] +one = [H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H] + + +simAdd_0 = simFourBitAdder zero a3 a2 a1 a0 a3 a2 a1 a0 +simAdd_1 = simFourBitAdder one a3 a2 a1 a0 a3 a2 a1 a0 + +----- fourBitCarrySelectAdder + + +fourBitCSAdder :: Signal Bit -- C_IN + -> Signal Bit -- A3 + -> Signal Bit -- A2 + -> Signal Bit -- A1 + -> Signal Bit -- A0 + -> Signal Bit -- B3 + -> Signal Bit -- B2 + -> Signal Bit -- B1 + -> Signal Bit -- B0 + -> (Signal Bit, -- C_OUT + Signal Bit, -- SUM3 + Signal Bit, -- SUM2 + Signal Bit, -- SUM1 + Signal Bit) -- SUM0fourBitCSAdder :: +fourBitCSAdder c_in a3 a2 a1 a0 b3 b2 b1 b0 + = (c_out, sum3, sum2, sum1, sum0) + where c_out = (instantiate "mux4" mux21Sys) c_in c_out_1 c_out_0 + sum3 = (instantiate "mux3" mux21Sys) c_in sum3_1 sum3_0 + sum2 = (instantiate "mux2" mux21Sys) c_in sum2_1 sum2_0 + sum1 = (instantiate "mux1" mux21Sys) c_in sum1_1 sum1_0 + sum0 = (instantiate "mux0" mux21Sys) c_in sum0_1 sum0_0 + (c_out_1, sum3_1, sum2_1, sum1_1, sum0_1) + = (instantiate "Adder_1" fourBitAdderSys) + one a3 a2 a1 a0 b3 b2 b1 b0 + (c_out_0, sum3_0, sum2_0, sum1_0, sum0_0) + = (instantiate "Adder_1" fourBitAdderSys) + zero a3 a2 a1 a0 b3 b2 b1 b0 + one = instantiate "One" oneSys + zero = instantiate "Zero" zeroSys + +fourBitCSAdderSys = newSysDef fourBitCSAdder "fourBitCSAdder" ["C_IN", "A3", "A2", "A1", "A0", + "B3", "B2", "B1", "B0"] + ["C_OUT", "SUM3", "SUM2", "SUM1", "SUM0"] + + +simFourBitCSAdder = simulate fourBitCSAdderSys + +vhdlFourBitCSAdder = writeVHDL fourBitCSAdderSys + +simCSAdd_0 = simFourBitAdder zero a3 a2 a1 a0 a3 a2 a1 a0 +simCSAdd_1 = simFourBitAdder one a3 a2 a1 a0 a3 a2 a1 a0 + +----- Convert Output to FSVec + +convertToFSVec5 :: a -> a -> a -> a -> a -> FSVec D5 a +convertToFSVec5 x4 x3 x2 x1 x0 = x4 +> x3 +> x2 +> x1 +> (singleton x0) + +convOutput :: ProcFun (Bit -> Bit -> Bit -> Bit -> Bit -> FSVec D5 Bit) +convOutput = $(newProcFun [d|convOutput :: Bit -> Bit -> Bit -> Bit -> Bit -> FSVec D5 Bit + convOutput x4 x3 x2 x1 x0 + = convertToFSVec5 x4 x3 x2 x1 x0 |]) + +convOutputProc :: Signal Bit -> Signal Bit -> Signal Bit -> Signal Bit -> Signal Bit -> Signal (FSVec D5 Bit) +convOutputProc = zipWith5SY "toVector5" convOutput + +convOutputSys :: SysDef (Signal Bit -> Signal Bit -> Signal Bit -> Signal Bit -> Signal Bit -> Signal (FSVec D5 Bit)) +convOutputSys = newSysDef convOutputProc "convOutput" ["x4", "x3", "x2", "x1", "x0"] ["vec5"] + +fourBitCSAdder' :: Signal Bit -- C_IN + -> Signal Bit -- A3 + -> Signal Bit -- A2 + -> Signal Bit -- A1 + -> Signal Bit -- A0 + -> Signal Bit -- B3 + -> Signal Bit -- B2 + -> Signal Bit -- B1 + -> Signal Bit -- B0 + -> Signal (FSVec D5 Bit) -- +fourBitCSAdder' c_in a3 a2 a1 a0 b3 b2 b1 b0 = out5 + where + out5 = (instantiate "toVector5" convOutputSys) c_out sum3 sum2 sum1 sum0 + (c_out, sum3, sum2, sum1, sum0) = (instantiate "Adder" fourBitCSAdderSys) c_in a3 a2 a1 a0 b3 b2 b1 b0 + +fourBitCSAdderSys2 :: SysDef (Signal Bit -- C_IN + -> Signal Bit -- A3 + -> Signal Bit -- A2 + -> Signal Bit -- A1 + -> Signal Bit -- A0 + -> Signal Bit -- B3 + -> Signal Bit -- B2 + -> Signal Bit -- B1 + -> Signal Bit -- B0 + -> Signal (FSVec D5 Bit)) +fourBitCSAdderSys2 = newSysDef fourBitCSAdder' "fourBitCSAdder" ["C_IN", "A3", "A2", "A1", "A0", + "B3", "B2", "B1", "B0"] + ["vect5"] + +simFourBitCSAdder2 = simulate fourBitCSAdderSys2 + +vhdlFourBitCSAdder2 = writeVHDL fourBitCSAdderSys2 + +simCSAdd_0' = simFourBitCSAdder2 zero a3 a2 a1 a0 a3 a2 a1 a0 +simCSAdd_1' = simFourBitCSAdder2 one a3 a2 a1 a0 a3 a2 a1 a0 + + +----- Four Bit Adder +-- +-- The four bit adder is modelled as a set of equations. +-- It uses fixed-size vectors for the 4-bit input and output values. + +adder4BitFun :: ProcFun (Bit -> FSVec D4 Bit -> FSVec D4 Bit -> (Bit, FSVec D4 Bit)) +adder4BitFun = $(newProcFun [d|adder4BitFun :: Bit -> FSVec D4 Bit -> FSVec D4 Bit -> (Bit, FSVec D4 Bit) + adder4BitFun cin a b = (cout, sum) where + cout :: Bit + cout = (a!d3 .&. b!d3) .|. (a!d3 .&. c2) .|. (b!d3 .&. c2) + c2 :: Bit + c2 = (a!d2 .&. b!d2) .|. (a!d2 .&. c1) .|. (b!d2 .&. c1) + c1 :: Bit + c1 = (a!d1 .&. b!d1) .|. (a!d1 .&. c0) .|. (b!d1 .&. c0) + c0 :: Bit + c0 = (a!d0 .&. b!d0) .|. (a!d0 .&. cin) .|. (b!d0 .&. cin) + s3 :: Bit + s3 = (a!d3 `xor` b!d3) `xor` c2 + s2 :: Bit + s2 = (a!d2 `xor` b!d2) `xor` c1 + s1 :: Bit + s1 = (a!d1 `xor` b!d1) `xor` c0 + s0 :: Bit + s0 = (a!d0 `xor` b!d0) `xor` cin + sum :: FSVec D4 Bit + sum = s0 +> s1 +> s2 +> s3 +> empty |]) + +adder4BitProc :: Signal Bit -> Signal (FSVec D4 Bit) -> Signal (FSVec D4 Bit) -> (Signal Bit, Signal (FSVec D4 Bit)) +adder4BitProc cin a b = (unzipSY "unzip") $ (zipWith3SY "4BitAdder" adder4BitFun cin a b) + +adder4BitSys :: SysDef (Signal Bit -> Signal (FSVec D4 Bit) -> Signal (FSVec D4 Bit) -> (Signal Bit, Signal (FSVec D4 Bit))) +adder4BitSys = newSysDef adder4BitProc "adder4Bit" ["cin", "a", "b"] ["cout", "sum"] + +simAdder4Bit = simulate adder4BitSys + +vhdlAdder4Bit = writeVHDL adder4BitSys + +----- 4-Bit 2/1 Multiplexer +-- +-- The multiplexer uses fixed size vectors for input and output values. + +mux21Fun :: ProcFun (Bit -> a -> a -> a) +mux21Fun = $(newProcFun [d|mux21Fun :: Bit -> a -> a -> a + mux21Fun sel d1 d0 = if (sel == L) then + d0 + else + d1 |]) + +mux21_4BitProc :: Signal Bit -> Signal (FSVec D4 Bit) -> Signal (FSVec D4 Bit) -> Signal (FSVec D4 Bit) +mux21_4BitProc = zipWith3SY "mux21" mux21Fun + +mux21_4BitSys :: SysDef (Signal Bit -> Signal ( FSVec D4 Bit) -> Signal (FSVec D4 Bit) -> Signal (FSVec D4 Bit)) +mux21_4BitSys = newSysDef mux21_4BitProc "mux21_4Bit" ["sel", "d1", "d0"] ["out"] + +simMux21_4Bit :: [Bit] -> [FSVec D4 Bit] -> [FSVec D4 Bit] -> [FSVec D4 Bit] +simMux21_4Bit = simulate mux21_4BitSys + +vhdlMux21_4Bit = writeVHDL mux21_4BitSys + + +----- 4-Bit Carry Select Adder + +-- The carry select adder has two input that are connected to 'H' or 'L' respectively + +-- Constant input 'H' modeled with constSY +oneProc :: Signal Bit +oneProc = constSY "high" H + +oneSys :: SysDef (Signal Bit) +oneSys = newSysDef oneProc "one" [] ["one"] + +-- Constant input 'L' modeled with constSY +zeroProc :: Signal Bit +zeroProc = constSY "low" L + +zeroSys :: SysDef (Signal Bit) +zeroSys = newSysDef zeroProc "zero" [] ["zero"] + +-- The 4-Bit carry select adder is implemented as a composition of components +csAdder4BitProc :: Signal Bit -> Signal (FSVec D4 Bit) -> Signal (FSVec D4 Bit) -> (Signal Bit, Signal (FSVec D4 Bit)) +csAdder4BitProc cin a b = (cout, sum) where + cout = (instantiate "mux" mux21Sys) cin cout_1 cout_0 + sum = (instantiate "mux4Bit" mux21_4BitSys) cin sum_1 sum_0 + (cout_1, sum_1) = (instantiate "adder1" adder4BitSys) one a b + (cout_0, sum_0) = (instantiate "adder0" adder4BitSys) zero a b + one = instantiate "One" oneSys + zero = instantiate "Zero" zeroSys + +csAdder4BitSys :: SysDef (Signal Bit -> Signal (FSVec D4 Bit) -> Signal (FSVec D4 Bit) -> (Signal Bit, Signal (FSVec D4 Bit))) +csAdder4BitSys = newSysDef csAdder4BitProc "csAdder4Bit" ["cin", "a", "b"] ["cout", "sum"] + +simCSAdder4Bit = simulate csAdder4BitSys + +vhdlCSAdder4Bit = writeVHDL csAdder4BitSys + +----- 16 Bit Adder + +csAdder16BitProc :: Signal (FSVec D16 Bit) -> Signal (FSVec D16 Bit) -> (Signal Bit, Signal (FSVec D16 Bit)) +csAdder16BitProc a b = (cout, sum) where + sum = zipWith4SY "concat4" concat4Fun sum3_0 sum7_4 sum11_8 sum15_12 + (cout, sum15_12) = (instantiate "csadder1" csAdder4BitSys) c11 a15_12 b15_12 + (c11, sum11_8) = (instantiate "csadder2" csAdder4BitSys) c7 a11_8 b11_8 + (c7, sum7_4) = (instantiate "csadder3" csAdder4BitSys) c3 a7_4 b7_4 + (c3, sum3_0) = (instantiate "csadder4" csAdder4BitSys) zero a3_0 b3_0 + a15_12 = mapSY "a15_12" select15_12Fun a + a11_8 = mapSY "a11_8" select11_8Fun a + a7_4 = mapSY "a7_4" select7_4Fun a + a3_0 = mapSY "a3_0" select3_0Fun a + b15_12 = mapSY "b15_12" select15_12Fun b + b11_8 = mapSY "b11_8" select11_8Fun b + b7_4 = mapSY "b7_4" select7_4Fun b + b3_0 = mapSY "b3 _0" select3_0Fun b + zero = instantiate "Zero" zeroSys + + +csAdder16BitSys = newSysDef csAdder16BitProc "csAdder16Bit" ["a", "b"] ["cout", "sum"] + +simCSAdder16Bit = simulate csAdder16BitSys + +vhdlCSAdder16Bit = writeVHDL csAdder16BitSys + +-- Helper functions + +select15_12Fun :: ProcFun (FSVec D16 Bit -> FSVec D4 Bit) +select15_12Fun = $(newProcFun [d|select15_12 :: FSVec D16 Bit -> FSVec D4 Bit + select15_12 v = select d12 d1 d4 v |]) + +select11_8Fun :: ProcFun (FSVec D16 Bit -> FSVec D4 Bit) +select11_8Fun = $(newProcFun [d|select11_8 :: FSVec D16 Bit -> FSVec D4 Bit + select11_8 v = select d8 d1 d4 v |]) + +select7_4Fun :: ProcFun (FSVec D16 Bit -> FSVec D4 Bit) +select7_4Fun = $(newProcFun [d|select7_4 :: FSVec D16 Bit -> FSVec D4 Bit + select7_4 v = select d4 d1 d4 v |]) + +select3_0Fun :: ProcFun (FSVec D16 Bit -> FSVec D4 Bit) +select3_0Fun = $(newProcFun [d|select3_0 :: FSVec D16 Bit -> FSVec D4 Bit + select3_0 v = select d0 d1 d4 v |]) + +concat4Fun :: ProcFun (FSVec D4 Bit -> FSVec D4 Bit -> FSVec D4 Bit -> FSVec D4 Bit -> FSVec D16 Bit) +concat4Fun = $(newProcFun [d|concat4Fun :: FSVec D4 Bit -> FSVec D4 Bit -> FSVec D4 Bit -> FSVec D4 Bit -> FSVec D16 Bit + concat4Fun v1 v2 v3 v4 = v1 Data.Param.FSVec.++ + v2 Data.Param.FSVec.++ + v3 Data.Param.FSVec.++ + v4 |]) + +-- 16 Bit Test Values + +v_0000 = reallyUnsafeVector [L,L,L,L, L,L,L,L, L,L,L,L, L,L,L,L] +v_8000 = reallyUnsafeVector [L,L,L,L, L,L,L,L, L,L,L,L, L,L,L,H] -- H is MSB +v_0001 = reallyUnsafeVector [H,L,L,L, L,L,L,L, L,L,L,L, L,L,L,L] +v_ffff = reallyUnsafeVector [H,H,H,H, H,H,H,H, H,H,H,H, H,H,H,H] + +a16 = v_0000 : v_0000 : v_0001 : v_8000 : v_ffff : v_ffff : [] +b16 = v_0000 : v_0001 : v_0001 : v_8000 : v_ffff : v_0001 : [] + +test16Bit = simCSAdder16Bit a16 b16 + +-- 4 Bit Test Values + +v_0 = reallyUnsafeVector [L,L,L,L] +v_1 = reallyUnsafeVector [H,L,L,L] +v_8 = reallyUnsafeVector [L,L,L,H] +v_f = reallyUnsafeVector [H,H,H,H] + +a4 = v_0 : v_0 : v_1 : v_8 : v_f : v_1 : [] +b4 = v_0 : v_1 : v_1 : v_8 : v_f : v_f : [] + +c_low = [L,L,L,L,L,L] +c_high = [H,H,H,H,H,H] + +test4Bit = simCSAdder4Bit c_low a4 b4 + +-- Test FSVector + +fv = 0 +> 1 +> 2 +> 3 +> empty -- LSB fv!d0 = 0, MSB fv!d3 = 3 diff --git a/examples/Counter.hs b/examples/Counter.hs new file mode 100644 --- /dev/null +++ b/examples/Counter.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- A counter, the simplest system with which to test netlist loops + +module Counter where + +import ForSyDe.Deep +import Data.Int + +counter :: Signal Int32 +counter = sourceSY "counterSource" add1 (0 :: Int32) + where add1 = $(newProcFun [d| add1 :: Int32 -> Int32 + add1 a = a + 1 |]) + + +counterSys :: SysDef (Signal Int32) +counterSys = $(newSysDefTHName 'counter [] ["countVal"]) + +simCounter :: [Int32] +simCounter = simulate counterSys diff --git a/examples/DeepShallow.hs b/examples/DeepShallow.hs new file mode 100644 --- /dev/null +++ b/examples/DeepShallow.hs @@ -0,0 +1,22 @@ +-- This example shows how to mix shallow-embedded and +-- deep-embedded signals by building an heterogeneous +-- system which adds five to its input +module DeepShallow where + +import SeqAddFour (addFourSys) +import ForSyDe.Deep(simulate) +import ForSyDe.Shallow +import Data.Int + +-- addOne using shallow-embedded signals +addOne :: Signal Int32 -> Signal Int32 +addOne = mapSY (+1) + +-- addFourSys uses deep-embedded signals, but we can transform them to lists +-- using simulate +addFourLists :: [Int32] -> [Int32] +addFourLists = simulate addFourSys + +-- addFive uses addOne and addFourLists +addFive :: Signal Int32 -> Signal Int32 +addFive = signal.addFourLists.fromSignal.addOne diff --git a/examples/LFSR.hs b/examples/LFSR.hs new file mode 100644 --- /dev/null +++ b/examples/LFSR.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- This modules implements an Linear Feedback Shiftregister + +-- Source: +-- Ben Cohen. VHDL Answers to Frequently Answered Questions. Kluwer. 1998 + +module LFSR where + +import ForSyDe.Deep -- Definition of Bit data type +import Data.Bits -- Operations for Bit data type +import Data.List + +-- ******************** +-- +-- Naive Implementation +-- +-- ******************** + +-- Design has one XOR-component +xor2f :: ProcFun (Bit -> Bit -> Bit) +xor2f = $(newProcFun [d|xor2f :: Bit -> Bit -> Bit + xor2f x1 x0 = xor x1 x0 |]) + +xor2Proc :: Signal Bit -> Signal Bit -> Signal Bit +xor2Proc = zipWithSY "xor2" xor2f + +xor2Sys :: SysDef (Signal Bit -> Signal Bit -> Signal Bit) +xor2Sys = newSysDef xor2Proc "xor2" ["in1", "in0"] ["out0"] + + +-- Design has four D-Flip-Flops +dffProc :: Signal Bit -> Signal Bit +dffProc = delaySY "delayDFF" H -- Starting Sequence must not be LL...L + +dffSys :: SysDef (Signal Bit -> Signal Bit) +dffSys = newSysDef dffProc "DelayFF" ["in1"] ["in0"] + +-- Netlist of LFSR +lfsr :: (Signal Bit, Signal Bit, Signal Bit, Signal Bit) +lfsr = (s1, s2, s3, s4) + where s5 = instantiate "xor2" xor2Sys s1 s4 + s1 = instantiate "dff1" dffSys s5 + s2 = instantiate "dff2" dffSys s1 + s3 = instantiate "dff3" dffSys s2 + s4 = instantiate "dff4" dffSys s3 + +lfsrSys :: SysDef ((Signal Bit, Signal Bit, Signal Bit, Signal Bit)) +lfsrSys = newSysDef lfsr "lfsr" [] ["s1", "s2", "s3", "s4"] + +simlfsr :: ([Bit], [Bit], [Bit], [Bit]) +simlfsr = simulate lfsrSys + +zip4tuple (a, b, c, d) = zip4 a b c d + +createVHDL = writeVHDL lfsrSys + +myLFSRtest = (take 20 . zip4tuple) (simlfsr) diff --git a/examples/Multiplexer.hs b/examples/Multiplexer.hs new file mode 100644 --- /dev/null +++ b/examples/Multiplexer.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE TemplateHaskell #-} +-- multiplexer +module Multiplexer where + +import ForSyDe.Deep +import Language.Haskell.TH.Lift + +-- I used tuples, but a vector of bits is what I would like to have +selectf :: ProcFun((Bit, Bit) -> (Bit, Bit, Bit, Bit) -> Bit) +selectf = $(newProcFun [d| select1 :: (Bit, Bit) + -> (Bit, Bit, Bit, Bit) -> Bit + select1 (s1, s0) (x3, x2, x1, x0) = + if (s1 == L) && (s0 == L) then + x0 + else + if (s1 == L) && (s0 == H) then + x1 + else + if (s1 == H) && (s0 == L) then + x2 + else + x3 |]) + + +-- System function (or process) which uses 'selectf' +selectProc :: Signal (Bit, Bit) -> Signal (Bit, Bit, Bit, Bit) -> Signal Bit +selectProc = zipWithSY "select1" selectf + +-- System definition associated to the system process 'selectProc' +muxSysDef :: SysDef (Signal (Bit, Bit) -> Signal (Bit, Bit, Bit, Bit) -> Signal Bit) +muxSysDef = newSysDef selectProc "muxSys" ["sel", "data"] ["out1"] + +-- we simulate the system +simMux :: [(Bit, Bit)] -> [(Bit, Bit, Bit, Bit)] -> [Bit] +simMux = simulate muxSysDef + + +selIn = [(L,L),(L,H),(H,L)] +dataIn = [(L,L,L,H), (L,L,L,H), (L,H,L,L)] + + +-- translate to VHDL, write output and run in QUartus +vhdlMux :: IO () +vhdlMux = writeVHDLOps defaultVHDLOps{execQuartus=Just quartusOps} muxSysDef + where quartusOps = QuartusOps FullCompilation + (Just 50) + (Just ("CycloneII", Just "EP2C35F672C6")) + [("sel.tup_1","PIN_AF14"), + ("sel.tup_2","PIN_AD13"), + ("data.tup_1","PIN_N25"), + ("data.tup_2","PIN_N26"), + ("data.tup_3","PIN_P25"), + ("data.tup_4","PIN_AE14"), + ("out1","PIN_AE23")] + + + diff --git a/examples/Multiplexer_FSVector.hs b/examples/Multiplexer_FSVector.hs new file mode 100644 --- /dev/null +++ b/examples/Multiplexer_FSVector.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE TemplateHaskell #-} +-- multiplexer +module Multiplexer_FSVector where + +import ForSyDe.Deep +import Language.Haskell.TH.Lift +import Data.Param.FSVec +import Data.TypeLevel.Num.Reps +import Data.TypeLevel.Num.Aliases + +-- I used tuples, but a vector of bits is what I would like to have +selectf :: ProcFun(FSVec D2 Bit -> FSVec D4 Bit -> Bit) +selectf = $(newProcFun [d| select1 :: FSVec D2 Bit + -> FSVec D4 Bit -> Bit + select1 sel input = + if (sel!d1 == L) && (sel!d0 == L) then + input!d0 + else + if (sel!d1 == L) && (sel!d0 == H) then + input!d1 + else + if (sel!d1 == H) && (sel!d0 == L) then + input!d2 + else + input!d3 |]) + + +-- System function (or process) which uses 'selectf' +selectProc :: Signal (FSVec D2 Bit) -> Signal (FSVec D4 Bit) -> Signal Bit +selectProc = zipWithSY "select1" selectf + +-- System definition associated to the system process 'selectProc' +muxSysDef :: SysDef (Signal (FSVec D2 Bit) -> Signal (FSVec D4 Bit) -> Signal Bit) +muxSysDef = $(newSysDefTHName 'selectProc ["sel", "data"] ["out1"]) + +-- we simulate the system +simMux :: [FSVec D2 Bit] -> [FSVec D4 Bit] -> [Bit] +simMux = simulate muxSysDef + +selIn = [$(vectorTH [L,L]), $(vectorTH [H,L]), $(vectorTH [L,H]) ] +dataIn = [$(vectorTH [L,H,H,H]), $(vectorTH [H,L,H,H]), $(vectorTH [H,H,L,H])] + +-- Create VHDL +createVHDL = writeVHDL muxSysDef + diff --git a/examples/Null.hs b/examples/Null.hs new file mode 100644 --- /dev/null +++ b/examples/Null.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- This module is aimed at testing the, normally useless but possible, +-- null system + +module Null where + +import ForSyDe.Deep + +nullSysF :: () +nullSysF = () + +nullSysDef :: SysDef () +nullSysDef = newSysDef nullSysF "null" [] [] + +nullIns0 :: () +nullIns0 = instantiate "null0" nullSysDef + +simNull :: () +simNull = simulate nullSysDef diff --git a/examples/ParAddFour.hs b/examples/ParAddFour.hs new file mode 100644 --- /dev/null +++ b/examples/ParAddFour.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE TemplateHaskell #-} +-- Naive example to test instances working in paralell +-- Adds a signal to four signals +module ParAddFour where + +import ForSyDe.Deep +import Data.Int + + +add :: ProcFun (Int32 -> Int32 -> Int32) +add = $(newProcFun [d| add :: Int32 -> Int32 -> Int32 + add a b = a + b |]) + +addProc :: Signal Int32 -> Signal Int32 -> Signal Int32 +addProc s1 s2 = zipWithSY "zip1" add s1 s2 + + +addSys :: SysDef (Signal Int32 -> Signal Int32 -> Signal Int32) +addSys = newSysDef addProc "add" ["in1","in2"] ["sum"] + +simAdd :: [Int32] -> [Int32] -> [Int32] +simAdd = simulate addSys + +parAddFour :: Signal Int32 + -> Signal Int32 -> Signal Int32 -> Signal Int32 -> Signal Int32 + -> (Signal Int32, Signal Int32, Signal Int32, Signal Int32) +parAddFour toAdd s1 s2 s3 s4 = (sum1, sum2, sum3, sum4) + where sum1 = (instantiate "adder1" addSys) toAdd s1 + sum2 = (instantiate "adder2" addSys) toAdd s2 + sum3 = (instantiate "adder3" addSys) toAdd s3 + sum4 = (instantiate "adder4" addSys) toAdd s4 + +parAddFourSys :: SysDef (Signal Int32 + -> Signal Int32 -> Signal Int32 -> Signal Int32 -> Signal Int32 + -> (Signal Int32, Signal Int32, Signal Int32, Signal Int32)) +parAddFourSys = newSysDef parAddFour "parAddFour" ["toAdd","s1","s2","s3","s4"] + ["sum1","sum2","sum3","sum4"] + + +simParAddFour :: [Int32] + -> [Int32] -> [Int32] -> [Int32] -> [Int32] + -> ([Int32], [Int32], [Int32], [Int32]) +simParAddFour = simulate parAddFourSys diff --git a/examples/SeqAddFour.hs b/examples/SeqAddFour.hs new file mode 100644 --- /dev/null +++ b/examples/SeqAddFour.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- This module is aimed at testing a naive use-case of +-- the instantiation mechanism + +-- We'll build a system which uses four single-adder components connected +-- sequentially to add four units to the values of the input signal + +module SeqAddFour where + +import ForSyDe.Deep +import Data.Int + +-- A process function which adds one to its input +addOnef :: ProcFun (Int32 -> Int32) +addOnef = $(newProcFun [d|addOnef :: Int32 -> Int32 + addOnef n = n + 1 |]) + +-- System function (or process) which uses addOnef +addOneProc :: Signal Int32 -> Signal Int32 +addOneProc = mapSY "addOne" addOnef + + +-- System definition associated to the system function +addOneSysDef :: SysDef (Signal Int32 -> Signal Int32) +addOneSysDef = newSysDef addOneProc "addOne" ["in1"] ["out1"] + + +-- Finally, we create the sequential add four system function +addFour :: Signal Int32 -> Signal Int32 +addFour = instantiate "addOne3" addOneSysDef . + instantiate "addOne2" addOneSysDef . + instantiate "addOne1" addOneSysDef . + instantiate "addOne0" addOneSysDef + +-- We build the system +addFourSys :: SysDef (Signal Int32 -> Signal Int32) +addFourSys = newSysDef addFour "addFour" ["in1"] ["out1"] + +-- we simulate the system +simAddFour :: [Int32] -> [Int32] +simAddFour = simulate addFourSys + +-- we generate VHDL +createVHDL = writeVHDL addFourSys diff --git a/examples/ZipTwist.hs b/examples/ZipTwist.hs new file mode 100644 --- /dev/null +++ b/examples/ZipTwist.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE TemplateHaskell #-} +-- An identity system of six inputs formed by various zipping and unzipping +-- processes +module ZipTwist where + +import ForSyDe.Deep +import Data.Param.FSVec +import Data.TypeLevel.Num.Reps +import Data.Int + +zip6xSY :: ProcId -> FSVec D6 (Signal Int32) -> Signal (FSVec D6 Int32) +zip6xSY = zipxSY + +zipTwistFun :: Signal Int32 -> Signal Int32 -> Signal Int32 + -> Signal Int32 -> Signal Int32 -> Signal Int32 + -> (Signal Int32, Signal Int32, Signal Int32, + Signal Int32, Signal Int32, Signal Int32) +zipTwistFun i1 i2 i3 i4 i5 i6 = (o1,o2,o3,o4,o5,o6) + where [i1',i2',i3',i4',i5',i6'] = (fromVector.unzipxSY "unzipxSY" . zip6xSY "zip6xsy") + $ reallyUnsafeVector [i1,i2,i3,i4,i5,i6] + zip13 = zip3SY "zip13" i1' i2' i3' + zip46 = zip3SY "zip46" i4' i5' i6' + (o1,o2,o3) = unzip3SY "unzip13" zip13 + (o4,o5,o6) = unzip3SY "unzip46" zip46 + +zipTwistSys :: SysDef (Signal Int32 -> Signal Int32 -> Signal Int32 + -> Signal Int32 -> Signal Int32 -> Signal Int32 + -> (Signal Int32, Signal Int32, Signal Int32, + Signal Int32, Signal Int32, Signal Int32)) +zipTwistSys = newSysDef zipTwistFun "zipTwist" + ["in1","in2","in3","in4","in5","in6"] + ["out1","out2","out3","out4","out5","out6"] + +simZipTwist = simulate zipTwistSys + +writeVHDLZipTwist = writeVHDL zipTwistSys diff --git a/forsyde-deep.cabal b/forsyde-deep.cabal new file mode 100644 --- /dev/null +++ b/forsyde-deep.cabal @@ -0,0 +1,168 @@ +name: forsyde-deep +version: 0.2.0 +cabal-version: >= 1.9.2 +build-type: Custom +license: BSD3 +license-file: LICENSE +author: Alfonso Acosta, Hendrik Woidt +copyright: Copyright (c) 2003-2018 ForSyDe Group, KTH/EECS/ES +maintainer: forsyde-dev@eecs.kth.se +homepage: https://forsyde.github.io/ +stability: alpha +synopsis: + ForSyDe's Haskell-embedded Domain Specific Language. +description: + The ForSyDe (Formal System Design) methodology has been developed with the objective to move system design to a higher level of abstraction and to bridge the abstraction gap by transformational design refinement. + + This library provides ForSyDe's implementation as a Haskell-embedded Domain Specific Language (DSL). For more information, please see ForSyDe's website: . + + This library provides the deep implementation of ForSyDe in Haskell. +category: Language, Hardware +tested-with: GHC==7.10.3 GHC==8.0.1 +data-files: lib/forsyde.vhd +-- In order to include all this files with sdist +extra-source-files: LICENSE, + README.md, + examples/ALU.hs, + examples/ALU_Shallow.hs, + examples/BitVector.hs, + examples/ButtonEncoder.hs, + examples/CarrySelectAdder.hs, + examples/Counter.hs, + examples/DeepShallow.hs, + examples/LFSR.hs, + examples/Multiplexer.hs, + examples/Multiplexer_FSVector.hs, + examples/Null.hs, + examples/ParAddFour.hs, + examples/SeqAddFour.hs, + examples/ZipTwist.hs, + tests/Install.hs, + tests/examples/Main.hs, + tests/examples/VHDLBackend.hs, +-- due to a bug in cabal 1.2, sdist does not include hs-boot files + src/ForSyDe/Deep/Backend/VHDL/GlobalNameTable.hs-boot, + src/ForSyDe/Deep/System/SysDef.hs-boot + + +Flag developer + Description: Shorten build time for more fluent development + Default: False + +Test-Suite examples + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: tests/examples, + examples/ + build-depends: base>= 4.8.2 && < 4.9.2, + parameterized-data >= 0.1.5, + type-level, + forsyde-deep, + HUnit, + random, + syb, + directory, + QuickCheck + +Library + build-depends: type-level, + parameterized-data >= 0.1.5, + containers, + base>= 4.8.2 && < 4.9.2, + regex-posix, + mtl, + syb, + pretty, + template-haskell, + process, + directory, + filepath, + random + + + hs-source-dirs: src + exposed-modules: Language.Haskell.TH.Lift, + Language.Haskell.TH.LiftInstances, + ForSyDe.Deep, + ForSyDe.Deep.Ids, + ForSyDe.Deep.System, + ForSyDe.Deep.AbsentExt, + ForSyDe.Deep.Bit, + ForSyDe.Deep.DFT, + ForSyDe.Deep.FIR, + ForSyDe.Deep.Signal, + ForSyDe.Deep.Process, + ForSyDe.Deep.Process.SynchProc, + ForSyDe.Deep.Backend, + ForSyDe.Deep.Backend.Simulate, + ForSyDe.Deep.Backend.VHDL, + ForSyDe.Deep.Backend.GraphML + + other-modules: Paths_forsyde_deep, + Language.Haskell.TH.TypeLib, + Data.Typeable.TypeRepLib, + Data.Typeable.FSDTypeRepLib, + Data.Traversable.GenericZipWith, + ForSyDe.Deep.Config, + ForSyDe.Deep.Version, + ForSyDe.Deep.ForSyDeErr, + ForSyDe.Deep.Netlist, + ForSyDe.Deep.Netlist.Traverse, + ForSyDe.Deep.OSharing, + ForSyDe.Deep.OSharing.UDynamic, + ForSyDe.Deep.System.SysFun, + ForSyDe.Deep.System.SysFun.Instances, + ForSyDe.Deep.System.SysDef, + ForSyDe.Deep.System.Instantiate, + ForSyDe.Deep.Process.ProcFun, + ForSyDe.Deep.Process.Desugar, + ForSyDe.Deep.Process.ProcVal, + ForSyDe.Deep.Process.ProcType, + ForSyDe.Deep.Process.ProcType.Instances, + ForSyDe.Deep.Backend.Ppr, + ForSyDe.Deep.Backend.VHDL.GlobalNameTable, + ForSyDe.Deep.Backend.VHDL.AST, + ForSyDe.Deep.Backend.VHDL.Ppr, + ForSyDe.Deep.Backend.VHDL.Constants, + ForSyDe.Deep.Backend.VHDL.FileIO, + ForSyDe.Deep.Backend.VHDL.Traverse, + ForSyDe.Deep.Backend.VHDL.Traverse.VHDLM, + ForSyDe.Deep.Backend.VHDL.Translate, + ForSyDe.Deep.Backend.VHDL.Translate.HigherOrderFunctions, + ForSyDe.Deep.Backend.VHDL.Generate, + ForSyDe.Deep.Backend.VHDL.TestBench, + ForSyDe.Deep.Backend.VHDL.Quartus, + ForSyDe.Deep.Backend.VHDL.Modelsim, + ForSyDe.Deep.Backend.VHDL.Ghdl, + ForSyDe.Deep.Backend.GraphML.AST, + ForSyDe.Deep.Backend.GraphML.Ppr, + ForSyDe.Deep.Backend.GraphML.FileIO, + ForSyDe.Deep.Backend.GraphML.Traverse, + ForSyDe.Deep.Backend.GraphML.Traverse.GraphMLM + + ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-orphans + if flag(developer) + cpp-options: -DDEVELOPER + +custom-setup + setup-depends: base >=4.8.2 && <4.9.2, + Cabal >= 1.22 && < 1.25, + parameterized-data >= 0.1.5, + containers, + base>= 4.8.2 && < 4.9.2, + regex-posix, + mtl, + syb, + pretty, + template-haskell, + process, + directory, + filepath, + random, + type-level, + HUnit, + QuickCheck + +source-repository head + type: git + location: git://github.com/forsyde/forsyde-deep.git diff --git a/lib/forsyde.vhd b/lib/forsyde.vhd new file mode 100644 --- /dev/null +++ b/lib/forsyde.vhd @@ -0,0 +1,172 @@ +library ieee; +use ieee.numeric_std.all; +use ieee.std_logic_1164.all; + +package types is + + function default return integer; + function show (i : integer) return string; + +-- Commented out due to representation overflow (modelsim integers +-- are 32bits long) +-- subtype int64 is integer range -(2**(64-1)) to +(2**(64-1)-1); + +-- Commented out due to a overflow in 2**32: +-- subtype int32 is integer range -(2**(32-1)) to +(2**(32-1)-1); + +-- Note the lower bound is not -2147483648 because the LRM doesn't +-- force to include it. + subtype int32 is integer range -2147483647 to +2147483647; + + subtype int16 is integer range -(2**(16-1)) to +(2**(16-1)-1); + + subtype int8 is integer range -(2**(8-1)) to +(2**(8-1)-1); + + function default return std_logic; + function show (s : std_logic) return string; + + function default return boolean; + function show (b : boolean) return string; + + -- Indexes for unconstrained fsvecs: + -- -1 is used to express the null vector, with bounds (0 to -1) + subtype fsvec_index is integer range -1 to integer'high; + + -- Unconstrained translation of "FSVec _ Bit" + -- needed for toBitVector and fromBitVector + type fsvec_std_logic is array (fsvec_index range <>) of std_logic; + + function toBitVector8 (i : int8) return fsvec_std_logic; + function toBitVector16 (i : int16) return fsvec_std_logic; + function toBitVector32 (i : int32) return fsvec_std_logic; + + function fromBitVector8 (v : fsvec_std_logic) return int8; + function fromBitVector16 (v : fsvec_std_logic) return int16; + function fromBitVector32 (v : fsvec_std_logic) return int32; + + function fixmul8 (a : int8; b: int8) return int8; + +end types; + +package body types is + +-- Commented out due to representation overflow +-- function default return int64 is +-- begin +-- return 0; +-- end default; + function fixmul8 (a : int8; b: int8) return int8 is + variable res : int16; + variable a16 : int16; + variable b16 : int16; + variable result_signed : signed (0 to 15); + begin + a16 := a; + b16 := b; + res := a16 * b16; + result_signed := to_signed (res, 16); + return to_integer(result_signed (8 to 15)); + end fixmul8; + + function default return integer is + begin + return 0; + end default; + + function show (i : integer) return string is + begin + return integer'image(i); + end show; + + function default return std_logic is + begin + return '0'; + end default; + + function show (s : std_logic) return string is + begin + if s = '1' then + return "H"; + else + return "L"; + end if; + end show; + + + function default return boolean is + begin + return true; + end default; + + function show (b : boolean) return string is + begin + if b then + return "True"; + else + return "False"; + end if; + end show; + + function toBitVector8 (i : int8) return fsvec_std_logic is + variable inter : signed (0 to 7) := to_signed (i, 8); + variable ret : fsvec_std_logic (0 to 7); + begin + for index in ret'range loop + ret(index) := inter(index); + end loop; + return ret; + end toBitVector8; + + + function toBitVector16 (i : int16) return fsvec_std_logic is + variable inter : signed (0 to 15) := to_signed (i, 16); + variable ret : fsvec_std_logic (0 to 15); + begin + for index in ret'range loop + ret(index) := inter(index); + end loop; + return ret; + end toBitVector16; + + + function toBitVector32 (i : int32) return fsvec_std_logic is + variable inter : signed (0 to 31) := to_signed (i, 32); + variable ret : fsvec_std_logic (0 to 31); + begin + for index in ret'range loop + ret(index) := inter(index); + end loop; + return ret; + end toBitVector32; + + + function fromBitVector8 (v : fsvec_std_logic) return int8 is + variable inter : signed (0 to 7); + begin + for index in inter'range loop + inter(index) := v(index); + end loop; + return to_integer(inter); + end frombitVector8; + + function fromBitVector16 (v : fsvec_std_logic) return int16 is + variable inter : signed (0 to 15); + begin + for index in inter'range loop + inter(index) := v(index); + end loop; + return to_integer(inter); + end frombitVector16; + + + function fromBitVector32 (v : fsvec_std_logic) return int32 is + variable inter : signed (0 to 31); + begin + for index in inter'range loop + inter(index) := v(index); + end loop; + return to_integer(inter); + end frombitVector32; + + +end types; diff --git a/src/Data/Traversable/GenericZipWith.hs b/src/Data/Traversable/GenericZipWith.hs new file mode 100644 --- /dev/null +++ b/src/Data/Traversable/GenericZipWith.hs @@ -0,0 +1,69 @@ +--------------------------------------------------------------------------- +-- | +-- Module : Data.Traversable.GenericZipWith +-- Copyright : (c) SAM Group, KTH/ICT/ECS 2007-2008 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : forsyde-dev@ict.kth.se +-- Stability : experimental +-- Portability : portable +-- +-- This module provides generalized zipWith functions. +-- +----------------------------------------------------------------------------- +module Data.Traversable.GenericZipWith + (zipWithTF, + zipTF, + zipWithTFA, + zipWithTFM) where + + +import Data.Foldable +import qualified Data.Traversable as T +import Control.Monad.State + +-- | The state contains the list of values obtained form the foldable container +-- and a String indicating the name of the function currectly being executed +data ZipState a = ZipState {fName :: String, + list :: [a]} + +-- | State monad containing ZipState +type ZipM l a = State (ZipState l) a + +-- | pops the first element of the list inside the state +pop :: ZipM l l +pop = do + st <- get + let xs = list st + n = fName st + case xs of + (a:as) -> do put st{list=as} + return a + [] -> error $ n ++ ": insufficient input" + +-- | pop a value form the state and supply it to the second +-- argument of a binary function +supplySecond :: (a -> b -> c) -> a -> ZipM b c +supplySecond f a = do b <- pop + return $ f a b + +zipWithTFError :: (Traversable t,Foldable f) => + String -> (a -> b -> c) -> t a -> f b -> t c +zipWithTFError str g t f = evalState (T.mapM (supplySecond g) t) + (ZipState str (toList f)) + + +zipWithTF :: (Traversable t,Foldable f) => (a -> b -> c) -> t a -> f b -> t c +zipWithTF = zipWithTFError "GenericZip.zipWithTF" + +zipTF :: (Traversable t, Foldable f) => t a -> f b -> t (a,b) +zipTF = zipWithTFError "GenericZip.zipTF" (,) + + +zipWithTFM :: (Traversable t,Foldable f,Monad m) => + (a -> b -> m c) -> t a -> f b -> m (t c) +zipWithTFM g t f = T.sequence (zipWithTFError "GenericZip.zipWithTFM" g t f) + +zipWithTFA :: (Traversable t,Foldable f,Applicative m) => + (a -> b -> m c) -> t a -> f b -> m (t c) +zipWithTFA g t f = sequenceA (zipWithTFError "GenericZip.zipWithTFA" g t f) diff --git a/src/Data/Typeable/FSDTypeRepLib.hs b/src/Data/Typeable/FSDTypeRepLib.hs new file mode 100644 --- /dev/null +++ b/src/Data/Typeable/FSDTypeRepLib.hs @@ -0,0 +1,97 @@ +module Data.Typeable.FSDTypeRepLib ( + FSDType, + FSDTypeRep, + FSDTypeCon, + fsdTy, + fsdTyCon, + fsdTyConApp, + fsdTupleTyCon, + fsdTyConName, + fsdUnArrowT, + fsdTyRep, + fsdTyConOf, + fsdTypeOf, + fsdSplitTyConApp, + type2FSDTypeRep +) where + +import Data.Typeable +import Data.Typeable.TypeRepLib +import Data.Typeable.Internal +import Language.Haskell.TH (Type) +import Language.Haskell.TH.TypeLib (type2TypeRep) + +newtype FSDTypeRep = FSDTypeRep' TypeRep deriving (Eq, Ord, Show) +newtype FSDTypeCon = FSDTypeCon' TyCon deriving (Eq, Ord, Show) + +class FSDType a where + fsdTy :: a -> FSDTypeRep + +-- | e.g. use as fsd.typeOf (undefined :: FSVec) +instance FSDType TypeRep where + fsdTy tr = FSDTypeRep' $ typeRepNormalize tr + +--instance FSDType Type where +-- fsdTy ty = FSDTypeRep' typeRepNormalize $ type2TypeRep ty + + +fsdTyRep :: FSDTypeRep -> TypeRep +fsdTyRep (FSDTypeRep' tr) = tr + +fsdTyCon :: FSDTypeRep -> FSDTypeCon +fsdTyCon (FSDTypeRep' tr) = FSDTypeCon' $ typeRepTyCon tr + +fsdUnTyCon :: FSDTypeCon -> TyCon +fsdUnTyCon (FSDTypeCon' tc) = tc + +fsdSplitTyConApp :: FSDTypeRep -> (FSDTypeCon, [FSDTypeRep]) +fsdSplitTyConApp (FSDTypeRep' fsdtr) = (FSDTypeCon' tc, map FSDTypeRep' tr) where + (tc, tr) = splitTyConApp fsdtr + +fsdTyConOf :: (Typeable a) => a -> FSDTypeCon +fsdTyConOf = fsdTyCon.fsdTy.typeOf + +fsdTypeOf :: (Typeable a) => a -> FSDTypeRep +fsdTypeOf = fsdTy.typeOf + +fsdTyConApp :: FSDTypeCon -> [FSDTypeRep] -> FSDTypeRep +fsdTyConApp c trs = FSDTypeRep' $ mkTyConApp tc targs where + tc = fsdUnTyCon c + targs = map fsdTyRep trs + +fsdTupleTyCon :: Int -> FSDTypeCon +fsdTupleTyCon nOuts = FSDTypeCon' $ mkTyCon3 "" "GHC.Tuple" $ '(':replicate (nOuts-1) ','++")" + +fsdTyConName (FSDTypeCon' tc) = tyConName tc + +fsdUnArrowT :: FSDTypeRep -- ^ TypeRep to observe + -> ([FSDTypeRep], FSDTypeRep) -- ^ (args 'TypeRep', ret 'TypeRep') +fsdUnArrowT rep + | repCon == arrowTyCon = let (args', ret') = fsdUnArrowT arrowArg2 + in (arrowArg1:args', ret') + | otherwise = ([], rep) + where (repCon,~[arrowArg1,arrowArg2]) = fsdSplitTyConApp rep + +arrowTyCon :: FSDTypeCon +arrowTyCon = fsdTyConOf (undefined :: () -> ()) + +type2FSDTypeRep :: Type -> Maybe FSDTypeRep +type2FSDTypeRep ftr = do + tr <- type2TypeRep ftr + Just $ fsdTy tr + +-- +-- Strip the package names out of the TypeRep for correct comparison +-- +tyConNormalize :: TyCon -> TyCon +tyConNormalize tc = mkTyCon3 "" (tyConModule tc) (tyConName tc) + +typeRepNormalize :: TypeRep -> TypeRep +typeRepNormalize tr = mkPolyTyConApp tcN kindsN argsN + where + tc = typeRepTyCon tr + kinds = typeRepKinds tr + args = typeRepArgs tr + tcN = tyConNormalize tc + kindsN = map typeRepNormalize kinds + argsN = map typeRepNormalize args diff --git a/src/Data/Typeable/TypeRepLib.hs b/src/Data/Typeable/TypeRepLib.hs new file mode 100644 --- /dev/null +++ b/src/Data/Typeable/TypeRepLib.hs @@ -0,0 +1,31 @@ +--------------------------------------------------------------------------- +-- | +-- Module : Data.Typeable.TypeRepLib +-- Copyright : (c) SAM Group, KTH/ICT/ECS 2007-2008 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : forsyde-dev@ict.kth.se +-- Stability : experimental +-- Portability : portable +-- +-- This module provides basic functions related to Data.Typeables's 'TypeRep'. +-- +----------------------------------------------------------------------------- +module Data.Typeable.TypeRepLib (unArrowT) where + +import Data.Typeable + + +-- | Obtains the arguments and return type of a given 'TypeRep' +-- (normally a function) +-- together with its 'Context' (non-empty if the type is polymorphic) +unArrowT :: TypeRep -- ^ TypeRep to observe + -> ([TypeRep], TypeRep) -- ^ (args 'TypeRep', ret 'TypeRep') +unArrowT rep + | repCon == arrowTyCon = let (args', ret') = unArrowT arrowArg2 + in (arrowArg1:args', ret') + | otherwise = ([], rep) + where (repCon,~[arrowArg1,arrowArg2]) = splitTyConApp rep + +arrowTyCon :: TyCon +arrowTyCon = (typeRepTyCon.typeOf) (undefined :: () -> ()) diff --git a/src/ForSyDe/Deep.hs b/src/ForSyDe/Deep.hs new file mode 100644 --- /dev/null +++ b/src/ForSyDe/Deep.hs @@ -0,0 +1,38 @@ +----------------------------------------------------------------------------- +-- | +-- Module : ForSyDe +-- Copyright : (c) ES Group (KTH) 2007-2013 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : forsyde-dev@ict.kth.se +-- Stability : experimental +-- Portability : portable +-- +-- This module is a wrapper for all the publicly usable types and +-- functions of ForSyDe's deep-embedded Domain Specific Language +-- (DSL). For the shallow-embedded DSL, please see "ForSyDe.Shallow". +-- +-- +----------------------------------------------------------------------------- +module ForSyDe.Deep +(module ForSyDe.Deep.Ids, + module ForSyDe.Deep.Signal, + module ForSyDe.Deep.System, + module ForSyDe.Deep.Process, + module ForSyDe.Deep.Backend, + module ForSyDe.Deep.Bit, + module ForSyDe.Deep.AbsentExt, + module ForSyDe.Deep.DFT, + module ForSyDe.Deep.FIR, + forsydeVersion) where + +import ForSyDe.Deep.Ids +import ForSyDe.Deep.Signal (Signal) +import ForSyDe.Deep.Bit +import ForSyDe.Deep.Process +import ForSyDe.Deep.System +import ForSyDe.Deep.Backend +import ForSyDe.Deep.AbsentExt +import ForSyDe.Deep.DFT +import ForSyDe.Deep.FIR +import ForSyDe.Deep.Config (forsydeVersion) diff --git a/src/ForSyDe/Deep/AbsentExt.hs b/src/ForSyDe/Deep/AbsentExt.hs new file mode 100644 --- /dev/null +++ b/src/ForSyDe/Deep/AbsentExt.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE TemplateHaskell, DeriveDataTypeable #-} +----------------------------------------------------------------------------- +-- | +-- Module : ForSyDe.AbsentExt +-- Copyright : (c) ES Group, KTH/ICT/ES 2007-2013 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : forsyde-dev@ict.kth.se +-- Stability : experimental +-- Portability : portable +-- +-- The 'AbstExt' is used to extend existing data types with the value +-- \'absent\', which models the absence of a value. +-- +----------------------------------------------------------------------------- + +module ForSyDe.Deep.AbsentExt( + AbstExt (Abst, Prst), fromAbstExt, unsafeFromAbstExt, + abstExt, psi, + isAbsent, isPresent, abstExtFunc) + where + +import Data.Data +import Language.Haskell.TH.Lift + + +-- |The data type 'AbstExt' has two constructors. The constructor 'Abst' is used to model the absence of a value, while the constructor 'Prst' is used to model present values. +data AbstExt a = Abst + | Prst a + deriving (Eq, Data, Typeable) +$(deriveLift1 ''AbstExt) + + + +-- |The function 'fromAbstExt' extracts the inner value contained in 'AbstExt' +fromAbstExt :: a -- ^ Default value returned if the input is 'Abst' + -> AbstExt a -> a +-- |Similar to 'fromAbstExt', but without default value +unsafeFromAbstExt :: AbstExt a -> a +-- |The functions 'isPresent' checks for the presence of a value. +isPresent :: AbstExt a -> Bool +-- |The functions 'isAbsent' checks for the absence of a value. +isAbsent :: AbstExt a -> Bool +-- |The function 'abstExtFunc' extends a function in order to process absent extended values. If the input is (\"bottom\"), the output will also be (\"bottom\"). +abstExtFunc :: (a -> b) -> AbstExt a -> AbstExt b +-- | The function 'psi' is identical to 'abstExtFunc' and should be used in future. +psi :: (a -> b) -> AbstExt a -> AbstExt b +-- | The function 'abstExt' converts a usual value to a present value. +abstExt :: a -> AbstExt a + + + + + + +-- Implementation of Library Functions + +-- | The data type 'AbstExt' is defined as an instance of 'Show' and 'Read'. \'_\' represents the value 'Abst' while a present value is represented with its value, e.g. 'Prst' 1 is represented as \'1\'. +instance Show a => Show (AbstExt a) where + showsPrec _ x = showsAbstExt x + +showsAbstExt :: Show a => AbstExt a -> [Char] -> [Char] +showsAbstExt Abst = (++) "_" +showsAbstExt (Prst x) = (++) (show x) + +instance Read a => Read (AbstExt a) where + readsPrec _ x = readsAbstExt x + +readsAbstExt :: (Read a) => ReadS (AbstExt a) +readsAbstExt s = [(Abst, r1) | ("_", r1) <- lex s] + ++ [(Prst x, r2) | (x, r2) <- reads s] + +abstExt v = Prst v + +fromAbstExt x Abst = x +fromAbstExt _ (Prst y) = y + +unsafeFromAbstExt (Prst x) = x +unsafeFromAbstExt Abst = error "AbsentExt.unsafeFromAbstExt: Abst" + +isPresent Abst = False +isPresent (Prst _) = True + +isAbsent = not . isPresent + +abstExtFunc f = f' + where f' Abst = Abst + f' (Prst x) = Prst (f x) + + +psi = abstExtFunc diff --git a/src/ForSyDe/Deep/Backend.hs b/src/ForSyDe/Deep/Backend.hs new file mode 100644 --- /dev/null +++ b/src/ForSyDe/Deep/Backend.hs @@ -0,0 +1,24 @@ +----------------------------------------------------------------------------- +-- | +-- Module : ForSyDe.Deep.Backend +-- Copyright : (c) ES Group, KTH/ICT/ES 2007-2013 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : forsyde-dev@ict.kth.se +-- Stability : experimental +-- Portability : portable +-- +-- Wrapper module exporting all the backends +-- +----------------------------------------------------------------------------- +module ForSyDe.Deep.Backend + (module ForSyDe.Deep.Backend.Simulate, + module ForSyDe.Deep.Backend.VHDL, + module ForSyDe.Deep.Backend.GraphML) where + +import ForSyDe.Deep.Backend.Simulate +import ForSyDe.Deep.Backend.VHDL +import ForSyDe.Deep.Backend.GraphML + + + diff --git a/src/ForSyDe/Deep/Backend/GraphML.hs b/src/ForSyDe/Deep/Backend/GraphML.hs new file mode 100644 --- /dev/null +++ b/src/ForSyDe/Deep/Backend/GraphML.hs @@ -0,0 +1,45 @@ +----------------------------------------------------------------------------- +-- | +-- Module : ForSyDe.Deep.Backend.GraphML +-- Copyright : (c) ES Group, KTH/ICT/ES 2013 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : forsyde-dev@ict.kth.se +-- Stability : experimental +-- Portability : portable +-- +-- This module provides the GraphML backend of ForSyDe's embedded compiler +-- +----------------------------------------------------------------------------- +-- FIXME: factorize code shared between backends, and create a common interface for +-- backends (maybe based on a MPTC) + +module ForSyDe.Deep.Backend.GraphML + (writeGraphML, + writeGraphMLOps, + GraphMLOps(..), + GraphMLDebugLevel(..), + GraphMLRecursivity(..), + defaultGraphMLOps) where + +import Control.Monad.State (evalStateT) +import ForSyDe.Deep.ForSyDeErr +import ForSyDe.Deep.OSharing (readURef) +import ForSyDe.Deep.System.SysDef +import ForSyDe.Deep.Backend.GraphML.Traverse + +-- | Given a System Definition whose name is A generate @A.graphml@ in current +-- working directory using the default compilation options. +writeGraphML :: SysDef a -> IO () +writeGraphML = writeGraphMLOps defaultGraphMLOps + +-- | 'writeGraphML'-alternative which allows setting GraphML compilation +-- options. +writeGraphMLOps :: GraphMLOps -> SysDef a -> IO () +writeGraphMLOps ops sysDef = do + -- initiate the compilation State + let s = initGraphMLTravST $ (readURef.unPrimSysDef.unSysDef) sysDef + -- Translate the code + res <- runErrorT $ evalStateT (setGraphMLOps ops >> writeGraphMLM) s + -- Check if the compilation went well and print an error in case it didn't + either printGraphMLError return res diff --git a/src/ForSyDe/Deep/Backend/GraphML/AST.hs b/src/ForSyDe/Deep/Backend/GraphML/AST.hs new file mode 100644 --- /dev/null +++ b/src/ForSyDe/Deep/Backend/GraphML/AST.hs @@ -0,0 +1,44 @@ +----------------------------------------------------------------------------- +-- | +-- Module : ForSyDe.Deep.Backend.GraphML.AST +-- Copyright : (c) ES Group, KTH/ICT/ES 2007-2013 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : forsyde-dev@ict.kth.se +-- Stability : experimental +-- Portability : portable +-- +-- AST covering the GraphML subset we are interested in for this backend +----------------------------------------------------------------------------- + +--FIXME: the design of this module is ugly + +module ForSyDe.Deep.Backend.GraphML.AST where + +import ForSyDe.Deep.Netlist + +type GraphMLGraphId = String +type GraphMLPortId = String +type GraphMLNodeId = String + +-- | Main AST type, a graph +data GraphMLGraph = GraphMLGraph + GraphMLGraphId -- Graph id + [GraphMLNode] -- Nodes + [GraphMLEdge] -- Edges + + +-- | Edge +data GraphMLEdge = GraphMLEdge + GraphMLNode -- Origin node + GraphMLPortId -- Origin port id + GraphMLNode -- Target node + GraphMLPortId -- Target port id + +-- | Node +data GraphMLNode = + ProcNode (NlNode GraphMLPortId) -- Netlist node indicating the input ports + [GraphMLPortId] -- Output ports + -- FIXME: This representation is ugly + | + OutNode GraphMLNodeId GraphMLPortId -- the special output node diff --git a/src/ForSyDe/Deep/Backend/GraphML/FileIO.hs b/src/ForSyDe/Deep/Backend/GraphML/FileIO.hs new file mode 100644 --- /dev/null +++ b/src/ForSyDe/Deep/Backend/GraphML/FileIO.hs @@ -0,0 +1,27 @@ +----------------------------------------------------------------------------- +-- | +-- Module : ForSyDe.Deep.Backend.GraphML.FileIO +-- Copyright : (c) ES Group, KTH/ICT/ES 2007-2013 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : forsyde-dev@ict.kth.se +-- Stability : experimental +-- Portability : portable +-- +-- Functions working with files in the GraphML backend. +-- +----------------------------------------------------------------------------- +module ForSyDe.Deep.Backend.GraphML.FileIO where + +import ForSyDe.Deep.Backend.GraphML.AST +import ForSyDe.Deep.Backend.GraphML.Ppr(YFilesMarkup, pprGraphWithHeaders) + +import System.IO +import Text.PrettyPrint.HughesPJ + +-- | Write a design file to a file in disk +writeGraph :: YFilesMarkup -> GraphMLGraph -> FilePath -> IO () +writeGraph yFiles graph fp = do + handle <- openFile fp WriteMode + hPutStr handle $ (render . pprGraphWithHeaders yFiles) graph + hClose handle diff --git a/src/ForSyDe/Deep/Backend/GraphML/Ppr.hs b/src/ForSyDe/Deep/Backend/GraphML/Ppr.hs new file mode 100644 --- /dev/null +++ b/src/ForSyDe/Deep/Backend/GraphML/Ppr.hs @@ -0,0 +1,325 @@ +{-# LANGUAGE TypeSynonymInstances, MultiParamTypeClasses #-} +----------------------------------------------------------------------------- +-- | +-- Module : ForSyDe.Deep.Backend.GraphML.Ppr +-- Copyright : (c) ES Group, KTH/ICT/ES 2007-2013 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : forsyde-dev@ict.kth.se +-- Stability : experimental +-- Portability : non-portable (Template Haskell) +-- +-- GraphML pretty printing instances. +-- +----------------------------------------------------------------------------- +module ForSyDe.Deep.Backend.GraphML.Ppr where + +import ForSyDe.Deep.Backend.Ppr +import ForSyDe.Deep.Ids +import ForSyDe.Deep.Process.ProcVal +import ForSyDe.Deep.Process.ProcFun +import ForSyDe.Deep.Backend.GraphML.AST +import ForSyDe.Deep.Netlist +import ForSyDe.Deep.Netlist.Traverse +import ForSyDe.Deep.System.SysDef +import ForSyDe.Deep.OSharing + +import Data.Maybe (fromJust) +import Data.List (findIndex) +import qualified Data.Foldable as DF (foldr, toList) +import Language.Haskell.TH (pprint, Dec(FunD), Exp, nameBase) +import Text.PrettyPrint.HughesPJ + + +-- | The only accepted pretyprinting option +type YFilesMarkup = Bool + +-- | Number of spaces used for indentation +nestVal :: Int +nestVal = 5 + + +instance PprOps YFilesMarkup GraphMLGraph where + pprOps yFiles (GraphMLGraph id nodes edges) = + text " text ("id=\"" ++ id ++ "\"") <+> + text "edgedefault=\"directed\" >" $+$ + nest nestVal (vSpace $+$ + pprOps_list yFiles (vNSpaces 1) nodes $+$ + vSpace $+$ + pprOps_list yFiles (vNSpaces 1) edges $+$ + vSpace) $+$ + text "" + +instance PprOps YFilesMarkup GraphMLNode where + pprOps yFiles node = + text " text ("id=\"" ++ id ++ "\"") <> text ">" $+$ + nest nestVal ( + (case node of + ProcNode ins _ -> + case ins of + InPort _ -> + process_type "InPort" $+$ + yFilesNodeTags dim "#000000" "rectangle" (Just "w") id + Proc _ (Const pval) -> + let arg = (expVal.valAST) pval + in process_type "ConstSY" $+$ + value_arg arg $+$ + yFilesNodeTags dim "#FFFFFF" "ellipse" Nothing ("ConstSY\n" ++ show id ++ "\nval=" ++ pprint arg) + Proc _ (ZipWithNSY tpf i) -> + let nins = length i + typ = case nins of + 1 -> "MapSY" + _ -> "ZipWith" ++ show nins ++ "SY" + pfAST = (tpast.tast) tpf + in process_type "ZipWithNSY" $+$ + procfun_arg pfAST $+$ + yFilesNodeTags dim "#6F7DBC" "roundrectangle" Nothing (typ ++ "\n" ++ show id ++ "\nfName=" ++ nameBase (name pfAST)) + Proc _ (ZipWithxSY tpf _) -> + process_type "ZipWithxSY" $+$ + procfun_arg ((tpast.tast) tpf) $+$ + yFilesNodeTags dim "#AFADFC" "rectangle" Nothing ("ZipWithxSY\n" ++ show id) + Proc _ (UnzipNSY t _ _) -> + let typ = "Unzip" ++ show (length t) ++ "SY" + in process_type "UnzipNSY" $+$ + yFilesNodeTags dim "#5993A3" "roundrectangle" Nothing (typ ++ "\n" ++ show id) + Proc _ (UnzipxSY _ _ _ _) -> + process_type "UnzipxSY" $+$ + yFilesNodeTags dim "#99D3E3" "rectangle" Nothing ("UnzipxSY\n" ++ show id ) + Proc _ (DelaySY pval _) -> + let arg = (expVal.valAST) pval + in process_type "DelaySY" $+$ + value_arg arg $+$ + yFilesNodeTags dim "#FF934C" "diamond" Nothing ("DelaySY\n" ++ show id ++ "\nval=" ++ pprint arg) + Proc _ (SysIns psd _) -> + let parId = (sid.readURef.unPrimSysDef) psd + in process_type "SysIns" $+$ + instance_parent parId $+$ + yFilesNodeTags dim "#FF934C" "rectangle" Nothing ("SysIns\n" ++ show id ++ "\nparent=" ++ parId) + OutNode _ _ -> + process_type "OutPort" $+$ + yFilesNodeTags dim "#000000" "rectangle" (Just "e") id + ) $+$ vcat (map port portIds) + ) $+$ + text "" + where + (id, portIds) = + case node of + ProcNode ins outs -> + let pids = arguments ins ++ outs + in case ins of + InPort id -> (id, pids) + Proc id _ -> (id, pids) + OutNode id portid -> (id,[portid]) + dim = nodeDims node + -- write the yFiles specific markup for the node + yFilesNodeTags (xsize, ysize) color shape mSide label = + let labelLocation = maybe "modelName=\"internal\" modelPosition=\"c\"" + (\s -> "modelName=\"sides\" modelPosition=\""++ + s ++ "\"") + mSide in + if yFiles + then + text "" $+$ + nest nestVal + (text "" $+$ + nest nestVal + (text " float ysize <> text "\" width=\"" <> float xsize <> text "\" x=\"0.0\" y=\"0.0\"/>" $+$ + text " text color <> text "\" transparent=\"false\"/>" $+$ + text " text labelLocation <+> text "textColor=\"#000000\" visible=\"true\">" <> text label <> text "" $+$ + text " text shape <> text "\"/>" + ) $+$ + text "" + ) $+$ + text "" + else empty + +instance PprOps YFilesMarkup GraphMLEdge where + pprOps yFiles (GraphMLEdge origN origP targetN targetP) = + text " text ("source=\"" ++ origId ++ "\"") <+> + text ("sourceport=\"" ++ origP ++ "\"") <+> + text ("target=\"" ++ targetId ++ "\"") <+> + text ("targetport=\"" ++ targetP ++ "\"") <> + if not yFiles + then text "/>" + else char '>' $+$ + nest nestVal + (text "" $+$ + nest nestVal + (text "" $+$ + nest nestVal + (text " float edgeOrigX <> text "\" sy=\"" <> float edgeOrigY <> text "\" tx=\"" <> float edgeTargetX <> text "\" ty=\""<> float edgeTargetY <> text "\"/>" $+$ + text "" $+$ + text "" $+$ + text "" + ) $+$ + text "") $+$ + text "") $+$ + text "" + where -- Origin Node identifier + origId = getId origN + -- Target Node Identifier + targetId = getId targetN + -- Calculate the edge connection point for yFiles markup + (edgeOrigX, edgeOrigY) = edgeConnection True + origNodeDims nOPortsOrig + (findOutOrder origN origP) + (edgeTargetX, edgeTargetY) = edgeConnection False + targetNodeDims nIPortsTarget + (findInOrder targetN targetP) + (_, nOPortsOrig) = nIOPorts origN + origNodeDims = nodeDims origN + (nIPortsTarget, _) = nIOPorts targetN + targetNodeDims = nodeDims targetN + -- Function to calculate where to connect an edge to a node + -- note that in yfiles the coordinates origin of a node + -- is located in the center, but the Y axis is inverted + -- (negative values are in the upper side) + edgeConnection isSource (nodeXSize, nodeYSize) totalPorts portOrder = + (x,y) + where x = if isSource then nodeXSize / 2 else -(nodeXSize/2) + ySep = nodeYSize/(fromIntegral totalPorts) + -- Absolut value of y measure from the top + yAbs = ySep/2 + (fromIntegral portOrder) * ySep + y = yAbs - (nodeYSize / 2) + + -- helper functions + ------------------- + -- Find the order (starting at 0) of a input Port in a node + findInOrder node portid = findList list + where findList = fromJust . findIndex (==portid) + list = case node of + OutNode _ pid -> [pid] + ProcNode ins _ -> DF.toList ins + -- Find the order (starting at 0) of an output Port in a node + findOutOrder node portid = findList list + where findList = fromJust . findIndex (==portid) + list = case node of + OutNode _ pid -> [pid] + ProcNode _ outs -> outs + -- Get the identifier of a node + getId node = case node of + OutNode id _ -> id + ProcNode n _ -> case n of + InPort pid -> pid + Proc pid _ -> pid + +-- | pretty print a Graph with XML headers and key definitions +pprGraphWithHeaders :: YFilesMarkup -> GraphMLGraph -> Doc +pprGraphWithHeaders yFiles graph = + text "" $+$ + text "" $+$ + text " xmlns <+> + text "xmlns:xsi=\"http://www.w3.org/2001/XMLSchema-instance\"" <+> + xmlns_y <+> + + xsi_schemaLocation <> + char '>' $+$ + nest nestVal ( + text "" $+$ + text "" $+$ + text "" $+$ + text "" $+$ + yFilesAttribs $+$ + pprOps yFiles graph) $+$ + text "" + where + -- For some silly reason, yFiles uses a different GraphML target namesapce + -- different to the one used in grapdrawing.org's GraphML primer + xmlns = if yFiles + then text "xmlns=\"http://graphml.graphdrawing.org/xmlns/graphml\"" + else text "xmlns=\"http://graphml.graphdrawing.org/xmlns\"" + xmlns_y = if not yFiles then empty else + text "xmlns:y=\"http://www.yworks.com/xml/graphml\"" + xsi_schemaLocation = if yFiles + then text "xsi:schemaLocation=\"http://graphml.graphdrawing.org/xmlns/graphml http://www.yworks.com/xml/schema/graphml/1.0/ygraphml.xsd\"" + else text "xsi:schemaLocation=\"http://graphml.graphdrawing.org/xmlns http://graphml.graphdrawing.org/xmlns/1.0/graphml.xsd\"" + yFilesAttribs = if not yFiles then empty else + text "" $+$ + text "" $+$ + text "" $+$ + text "" + +------------------------- +-- Tag printing functions +------------------------- + +port :: GraphMLPortId -> Doc +port id = text " text ("name=\"" ++ id ++ "\"") <> text "/>" + + +process_type :: String -> Doc +process_type str = + text "" <> text str <> text "" + + +value_arg :: Exp -> Doc +value_arg exp = + text "" <> text (pprint exp) <> text "" + +procfun_arg :: ProcFunAST -> Doc +-- FIXME: support default parameters +procfun_arg (ProcFunAST n cls _) = + text "" $+$ + nest nestVal (text $ pprint (FunD n cls)) $+$ + text "" + + +instance_parent :: SysId -> Doc +instance_parent id = + text "" <> text id <> text "" + +------------------------- +-- Other helper functions +------------------------- + +-- Location of Edge connections and node size using yFiles Markup +-- ============================================================== +-- * All Nodes (except ports, of 7x7) have a constant width of 100 +-- * The height depends on the node: +-- * ConstSY has a constant height of 100 +-- * DelaySY has a constant height of 100 +-- * Nodes with three lines of text (ZipWithNSY, SysIns) have a minimum of 55 +-- * Nodes with two lines of text (the rest) have a minimum height of 40 +-- +-- ** The final height of nodes with minimum height is +-- Max(minheight, MaxS*ps) +-- where MaxS = Max(number of input signals, number of output signals) +-- ps = inter-port separation +-- ** The location where both ends of an edge is trivially calculated +-- using the order of the corresponding port, the final size of the +-- node, "bi" and "ps" + +-- | port separation space when connecting to a node which surpasses the +-- minimum height +portSep :: Float +portSep = 15 + +-- | Calculate the dimensions of a Node +nodeDims :: GraphMLNode -> (Float, Float) -- ^ Node dimensions (x,y) +nodeDims node = case node of + OutNode _ _ -> (7,7) + ProcNode n _ -> + case n of + InPort _ -> (7,7) + Proc _ n' -> + case n' of + Const _ -> (100,100) + DelaySY _ _ -> (100,100) + ZipWithNSY _ _ -> (100, height 55 maxio) + SysIns _ _ -> (100, height 55 maxio) + _ -> (100, height 40 maxio) + where height :: Float -- ^ Minimum height + -> Int -- ^ Max(input port number, output port number) + -> Float -- ^ Final height + height min maxio = max min + (portSep*(fromIntegral maxio)) + maxio :: Int -- ^ Max(input port number, output port number) + maxio = uncurry max $ nIOPorts node + + +-- | Calculate the number of input and output ports of a node +nIOPorts :: GraphMLNode -> (Int, Int) +nIOPorts node = + case node of + ProcNode ins outs -> (DF.foldr (\_ b -> b+1) 0 ins, length outs) + OutNode _ _ -> (1,0) diff --git a/src/ForSyDe/Deep/Backend/GraphML/Traverse.hs b/src/ForSyDe/Deep/Backend/GraphML/Traverse.hs new file mode 100644 --- /dev/null +++ b/src/ForSyDe/Deep/Backend/GraphML/Traverse.hs @@ -0,0 +1,139 @@ +----------------------------------------------------------------------------- +-- | +-- Module : ForSyDe.Deep.Backend.GraphML.Traverse +-- Copyright : (c) ES Group, KTH/ICT/ES 2007-2013 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : forsyde-dev@ict.kth.se +-- Stability : experimental +-- Portability : portable +-- +-- This module provides specialized Netlist traversing functions aimed at +-- GraphML compilation. +----------------------------------------------------------------------------- +module ForSyDe.Deep.Backend.GraphML.Traverse + (writeGraphMLM, + module ForSyDe.Deep.Backend.GraphML.Traverse.GraphMLM) where + +import ForSyDe.Deep.Backend.GraphML.Traverse.GraphMLM +import ForSyDe.Deep.Backend.GraphML.FileIO +import ForSyDe.Deep.Backend.GraphML.AST + + +import ForSyDe.Deep.System.SysDef +import ForSyDe.Deep.Netlist.Traverse +import ForSyDe.Deep.Netlist +import ForSyDe.Deep.OSharing + +import Data.Traversable.GenericZipWith + +import System.Directory +import System.FilePath +import Control.Monad.State + + +-- | Internal GraphML-Monad version of 'ForSyDe.Backend.writeGraphML +writeGraphMLM :: GraphMLM () +writeGraphMLM = do + -- create and change to systemName/graphml + rootDir <- gets (sid.globalSysDef.global) + let graphmlDir = rootDir "graphml" + liftIO $ createDirectoryIfMissing True graphmlDir + liftIO $ setCurrentDirectory graphmlDir + -- write the local results for the first-level entity + writeLocalGraphMLM + -- if we are in recursive mode, also write the local results + -- for the rest of the subsystems + rec <- isRecursiveSet + when rec $ do subs <- gets (subSys.globalSysDef.global) + let writeSub s = + withLocalST (initLocalST ((readURef.unPrimSysDef) s)) + writeLocalGraphMLM + mapM_ writeSub subs + -- go back to the original directory + liftIO $ setCurrentDirectory (".." "..") + + +-- | Traverse the netlist and write the local results (i.e. system graphs) +writeLocalGraphMLM :: GraphMLM () +writeLocalGraphMLM = do + lSysDefVal <- gets (currSysDef.local) + let lSysDefId = sid lSysDefVal + debugMsg $ "Compiling system definition `" ++ lSysDefId ++ "' ...\n" + -- Obtain the output Nodes of the system + -- Obtain the netlist of the system definition + let nl = netlist lSysDefVal + -- Traverse the netlist, and get the traversing results + intOutsInfo <- traverseGraphML nl + LocalTravResult nodes edges <- gets (localRes.local) + -- For each output signal, we need a node and an edge between its + -- intermediate signal and the final output signal declared in the system + -- interface. + let outIds = map fst (oIface lSysDefVal) + outNodes = map (\id -> OutNode id (id ++ "_in")) outIds + outEdges = + zipWith (\(IntSignalInfo n pId) id -> + GraphMLEdge n pId (OutNode id (id ++ "_in")) (id ++ "_in")) + intOutsInfo + outIds + -- Generate the final Graph + finalGraph = GraphMLGraph lSysDefId (nodes ++ outNodes) + (edges ++ outEdges) + -- and write it to disk + yFiles <- genyFilesMarkup + return () + liftIO $ writeGraph yFiles finalGraph (lSysDefId ++ ".graphml") + +-- | Traverse the netlist of a System Definition, +-- returning the (implicit) final traversing state and a list +-- containing the 'IntSignalInfo' of each output of the system +traverseGraphML :: Netlist [] -> GraphMLM [IntSignalInfo] +traverseGraphML = traverseSEIO newGraphML defineGraphML + +-- | \'new\' traversing function for the GraphML backend +newGraphML :: NlNode NlSignal -> GraphMLM [(NlNodeOut, IntSignalInfo)] +newGraphML node = do + let id = case node of + InPort id -> id + Proc pid _ -> pid + -- node inputs + insNode = zipWithTF (\_ n -> id ++ "_in" ++ show n) node [(1::Int)..] + -- node outputs tagged with the edge label + taggedOutsNode = zipWith (\t n -> (t, id ++ "_out" ++ show n)) + (outTags node) + [(1::Int)..] + -- graphml node + gMLNode = ProcNode insNode (map snd taggedOutsNode) + return $ map (\(t,out) -> (t, IntSignalInfo gMLNode out)) taggedOutsNode + + + + +-- | \'define\' traversing function for the GraphML backend +defineGraphML :: [(NlNodeOut, IntSignalInfo)] + -> NlNode IntSignalInfo + -> GraphMLM () +defineGraphML outs ins = do + let id = case ins of + InPort id -> id + Proc pid _ -> pid + -- Formal input signals of the proces + formalInL = [id ++ "_in" ++ show n | n <- [(1::Int)..]] + -- Generate the graph node + -- Formal output ports of the process + outPids = map (\(_, IntSignalInfo _ pid) -> pid) outs + -- Substitute actual inputs by formal inputs in "ins" + insFormal = zipWithTF (\_ n -> n) ins formalInL + node = ProcNode insFormal outPids + -- Generate the input edges of the node + -- Actual input signals of the process + actualInL = arguments ins + inEdges = zipWith (\(IntSignalInfo aN aPid) fPid -> + GraphMLEdge aN aPid node fPid ) actualInL formalInL + + mapM_ addEdge inEdges + addNode node + + + + diff --git a/src/ForSyDe/Deep/Backend/GraphML/Traverse/GraphMLM.hs b/src/ForSyDe/Deep/Backend/GraphML/Traverse/GraphMLM.hs new file mode 100644 --- /dev/null +++ b/src/ForSyDe/Deep/Backend/GraphML/Traverse/GraphMLM.hs @@ -0,0 +1,247 @@ +{-# LANGUAGE FlexibleContexts #-} +----------------------------------------------------------------------------- +-- | +-- Module : ForSyDe.Deep.Backend.GraphML.Traverse.GraphMLM +-- Copyright : (c) ES Group, KTH/ICT/ES 2007-2013 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : forsyde-dev@ict.kth.se +-- Stability : experimental +-- Portability : portable +-- +-- 'GraphMLM' (GraphML Monad), related types and functions +-- +----------------------------------------------------------------------------- +module ForSyDe.Deep.Backend.GraphML.Traverse.GraphMLM where + +import ForSyDe.Deep.Backend.GraphML.AST + +import ForSyDe.Deep.Ids +import ForSyDe.Deep.ForSyDeErr +import ForSyDe.Deep.System.SysDef (SysDefVal(..)) +import ForSyDe.Deep.Netlist.Traverse (TravSEIO) + +import Control.Monad.State + + +-------------- +-- GraphMLM -- +-------------- + +-- | GraphMLM backend monad +type GraphMLM a = TravSEIO GraphMLTravST ContextErr a + + +------------------- +-- GraphMLTravST -- +------------------- + +-- | GraphML traversing State. (see 'ForSyDe.Netlist.Traverse.traverseSIO') +data GraphMLTravST = GraphMLTravST + {local :: LocalGraphMLST, -- Local State (related to the system currently + -- compiled) + global :: GlobalGraphMLST} -- Global state (related to all systems being + -- recursively compiled) + +data LocalGraphMLST = LocalGraphMLST + {currSysDef :: SysDefVal, -- System definition which is currently + -- being compiled + context :: Context, -- Error Context + localRes :: LocalTravResult} -- Result accumulated during the + -- traversal of current System Definition + -- netlist + + + + +-- | initialize the local state +initLocalST :: SysDefVal -> LocalGraphMLST +initLocalST sysDefVal = + LocalGraphMLST sysDefVal (SysDefC (sid sysDefVal) (loc sysDefVal)) + emptyLocalTravResult + +-- | Execute certain operation with a concrete local state. +-- The initial local state is restored after the operation is executed +withLocalST :: LocalGraphMLST -> GraphMLM a -> GraphMLM a +withLocalST l' action = do + -- get the initial local state + st <- get + let l = local st + -- set the modified state + put st{local=l'} + -- execute the action + res <- action + -- restore the initial local state + st' <- get + put st'{local=l} + -- return the result + return res + +data GlobalGraphMLST = GlobalGraphMLST + {globalSysDef :: SysDefVal, + ops :: GraphMLOps, -- Compilation options + globalRes :: GlobalTravResult} -- Result accumulated during the + -- whole compilation + + + + +-- | Empty initial traversing state +initGlobalGraphMLST :: SysDefVal -> GlobalGraphMLST +initGlobalGraphMLST sysDefVal = + GlobalGraphMLST sysDefVal defaultGraphMLOps emptyGlobalTravResult + +-- | Empty initial traversing state +initGraphMLTravST :: SysDefVal -> GraphMLTravST +initGraphMLTravST sysDefVal = + GraphMLTravST (initLocalST sysDefVal) (initGlobalGraphMLST sysDefVal) + +------------- +-- TravResult +------------- + +-- | Local result accumulated during the traversal of a netlist +data LocalTravResult = LocalTravResult + {nodes :: [GraphMLNode], -- generated nodes + edges :: [GraphMLEdge]} -- generated edges + + + +-- | empty local GraphML compilation result +emptyLocalTravResult :: LocalTravResult +emptyLocalTravResult = LocalTravResult [] [] + + +-- | Global Results accumulated throughout the whole compilation +-- (empty right now) +type GlobalTravResult = () + + +-- | empty global GraphML compilation result +emptyGlobalTravResult :: GlobalTravResult +emptyGlobalTravResult = () + + +------------- +-- GraphMLOps +------------- + +-- | GraphML Compilation options +data GraphMLOps = GraphMLOps + {debugGraphML :: GraphMLDebugLevel, + recursivityGraphML :: GraphMLRecursivity, + yFilesMarkup :: Bool -- ^ Generate yFiles markup? + } + deriving (Eq, Show) + +-- | Debug level +data GraphMLDebugLevel = GraphMLNormal | GraphMLVerbose + deriving (Eq, Ord, Show) + +-- | Print a message to stdout if in verbose mode +debugMsg :: String -> GraphMLM () +debugMsg str = do + debugLevel <- gets (debugGraphML.ops.global) + when (debugLevel > GraphMLNormal) + (liftIO $ putStr ("DEBUG: " ++ str)) + +-- | Recursivity, should the parent systems of system instances be compiled as +-- well? +data GraphMLRecursivity = GraphMLRecursive | GraphMLNonRecursive + deriving (Eq, Show) + +-- | Check if we are in recursive mode +isRecursiveSet :: GraphMLM Bool +isRecursiveSet = do + recOp <- gets (recursivityGraphML.ops.global) + return $ recOp == GraphMLRecursive + +-- | Check if we want to generate yFiles markup +genyFilesMarkup :: GraphMLM Bool +genyFilesMarkup = gets (yFilesMarkup.ops.global) + + +-- | Default traversing options +defaultGraphMLOps :: GraphMLOps +defaultGraphMLOps = GraphMLOps GraphMLNormal GraphMLRecursive False + + +-- | Set GraphML options inside the GraphML monad +setGraphMLOps :: GraphMLOps -> GraphMLM () +setGraphMLOps options = modify (\st -> st{global=(global st){ops=options}}) + + +---------------------------------------- +-- Useful functions in the GraphML Monad +---------------------------------------- + +-- | Add a signal declaration to the 'LocalTravResult' in the State +addEdge :: GraphMLEdge -> GraphMLM () +addEdge e = modify addFun + -- FIXME: use a queue for the declarations + where addFun st = st{local=l{localRes=r{edges=edg ++ [e]}}} + where l = local st + r = localRes l + edg = edges r + + +-- | Add a statement to the 'LocalTravResult' in the State +addNode :: GraphMLNode -> GraphMLM () +addNode node = modify addFun + -- FIXME: use a queue for the statements + where addFun st = st{local=l{localRes=r{nodes= nds ++ [node]}}} + where l = local st + r = localRes l + nds = nodes r + + + +-- | Lift an 'EProne' value to the GraphML monad setting current error context +-- for the error +liftEProne :: EProne a -> GraphMLM a +liftEProne ep = do + cxt <- gets (context.local) + either (throwError.(ContextErr cxt)) return ep + +-- | Throw a ForSyDe error, setting current error context +throwFError :: ForSyDeErr -> GraphMLM a +throwFError = liftEProne.Left + + + +-- | Execute certain operation with a concrete process context. +-- The initial context is restored after the operation is executed +-- Note: the initial context must be a system context or 'InconsistenContexts' +-- will be raised. +withProcC :: ProcId -> GraphMLM a -> GraphMLM a +withProcC pid action = do + -- get the initial context + st <- get + let l = local st + c = context l + -- set the modified name context + put st{local=l{context=setProcC pid c}} + -- execute the action + res <- action + -- restore the initial name context + st' <- get + let l' = local st' + put st'{local=l'{context=c}} + -- return the result + return res + + + + +---------------- +-- IntSignalInfo +---------------- + +-- | Intermediate edge information. Tag generated for each output of each +-- node found during the traversal. +-- (see ForSyDe.Netlist.Traverse.traverseSIO). +-- It contains the GraphML node identifier +-- and port identifier associated with the process output. +data IntSignalInfo = IntSignalInfo GraphMLNode -- Source Node + GraphMLPortId -- Source Port Identifier + diff --git a/src/ForSyDe/Deep/Backend/Ppr.hs b/src/ForSyDe/Deep/Backend/Ppr.hs new file mode 100644 --- /dev/null +++ b/src/ForSyDe/Deep/Backend/Ppr.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} +----------------------------------------------------------------------------- +-- | +-- Module : ForSyDe.Deep.Backend.VHDL.Ppr +-- Copyright : (c) ES Group, KTH/ICT/ES 2007-2013 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : forsyde-dev@ict.kth.se +-- Stability : experimental +-- Portability : non-portable (Template Haskell) +-- +-- ForSyDe pretty-printing class and auxiliar functions. +-- +----------------------------------------------------------------------------- +module ForSyDe.Deep.Backend.Ppr where + +import Text.PrettyPrint.HughesPJ + +-- | Pretty printing class +class Ppr a where + ppr :: a -> Doc + +-- identity instantiation +instance Ppr Doc where + ppr = id + +-- | Pretty printing class with associated printing options +class PprOps ops toPpr | toPpr -> ops where + -- NOTE: Would it be better to use a State Monad? + -- i.e. pprOps :: toPpr -> State ops Doc + pprOps :: ops -> toPpr -> Doc + + +-- dot +dot :: Doc +dot = char '.' + +-- One line vertical space +vSpace :: Doc +vSpace = text "" + +-- Multi-line vertical space +multiVSpace :: Int -> Doc +multiVSpace n = vcat (replicate n (text "")) + +-- Pretty-print a list supplying the document joining function +ppr_list :: Ppr a => (Doc -> Doc -> Doc) -> [a] -> Doc +ppr_list _ [] = empty +ppr_list join (a1:rest) = go a1 rest + where go a1 [] = ppr a1 + go a1 (a2:rest) = ppr a1 `join` go a2 rest + +-- Pretty-print a list supplying the document joining function +-- (PprOps version) +pprOps_list :: PprOps ops toPpr => ops -> (Doc -> Doc -> Doc) -> [toPpr] -> Doc +pprOps_list _ _ [] = empty +pprOps_list ops join (a1:rest) = go a1 rest + where go a1 [] = pprOps ops a1 + go a1 (a2:rest) = pprOps ops a1 `join` go a2 rest + +-- | Join two documents vertically leaving n vertical spaces between them +vNSpaces :: Int -> Doc -> Doc -> Doc +vNSpaces n doc1 doc2 = doc1 $+$ + multiVSpace n $+$ + doc2 + +-- Join two documents vertically putting a semicolon in the middle +vSemi :: Doc -> Doc -> Doc +vSemi doc1 doc2 = doc1 <> semi $+$ doc2 + + +-- Join two documents vertically putting a comma in the middle +vComma :: Doc -> Doc -> Doc +vComma doc1 doc2 = doc1 <> comma $+$ doc2 + +-- Join two documents horizontally putting a comma in the middle +hComma :: Doc -> Doc -> Doc +hComma doc1 doc2 = doc1 <> comma <+> doc2 + + +-- | apply sep to a list of prettyprintable elements, +-- previously interspersing commas +commaSep :: Ppr a => [a] -> Doc +commaSep = sep.(punctuate comma).(map ppr) + + +-- | Only append if both of the documents are non-empty +($++$) :: Doc -> Doc -> Doc +d1 $++$ d2 + | isEmpty d1 || isEmpty d2 = empty + | otherwise = d1 $+$ d2 + + +-- | Only append if both of the documents are non-empty +(<++>) :: Doc -> Doc -> Doc +d1 <++> d2 + | isEmpty d1 || isEmpty d2 = empty + | otherwise = d1 <+> d2 + +-- | Enclose in parenthesis only if the document is non-empty +parensNonEmpty :: Doc -> Doc +parensNonEmpty doc | isEmpty doc = empty +parensNonEmpty doc = parens doc + +-- | Enclose in parenthesis only if the predicate is True +parensIf :: Bool -> Doc -> Doc +parensIf p d = if p then parens d else d diff --git a/src/ForSyDe/Deep/Backend/Simulate.hs b/src/ForSyDe/Deep/Backend/Simulate.hs new file mode 100644 --- /dev/null +++ b/src/ForSyDe/Deep/Backend/Simulate.hs @@ -0,0 +1,248 @@ +{-# LANGUAGE ScopedTypeVariables #-} +----------------------------------------------------------------------------- +-- | +-- Module : ForSyDe.Deep.Backend.Simulate +-- Copyright : (c) ES Group, KTH/ICT/ES 2007-2013 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : forsyde-dev@ict.kth.se +-- Stability : experimental +-- Portability : non-portable (Template Haskell, LSTV) +-- +-- This module provides the simulation backend of ForSyDe's embedded compiler +-- +-- /This module is based on Lava2000/: +-- +----------------------------------------------------------------------------- +module ForSyDe.Deep.Backend.Simulate (simulate) where + +import ForSyDe.Deep.OSharing +import ForSyDe.Deep.Netlist +import ForSyDe.Deep.Netlist.Traverse +import ForSyDe.Deep.System.SysDef +import ForSyDe.Deep.System.SysFun(SysFunToSimFun(..)) +import ForSyDe.Deep.ForSyDeErr +import ForSyDe.Deep.Process.ProcVal + +import Data.Maybe (fromJust) +import Control.Monad.ST +import qualified Control.Monad.ST.Unsafe as STU +import Data.STRef +import qualified Data.Traversable as DT +import Data.List (transpose) +import Data.Dynamic + +-- | 'simulate' takes a system definition and generates a function +-- able simulate a System using a list-based representation +-- of its signals. +simulate :: SysFunToSimFun sysFun simFun => SysDef sysFun -> simFun +simulate sysDef = fromDynSimFun (simulateDyn (unSysDef sysDef)) [] + +-- FIXME: clean and document the following horrible code! + +-------------------------------------- +-- The following was adapted from Lava +-------------------------------------- + +type Var s + = (STRef s Dynamic, STRef s (Wire s)) + +data Wire s + = Wire + { dependencies :: [Var s] + , kick :: ST s () + } + +---------------------------------------------------------------- +-- simulateDyn + + +simulateDyn :: PrimSysDef -> [[Dynamic]] -> [[Dynamic]] +simulateDyn pSysDef inps | any null inps = replicate outN [] + where outN = (length . oIface . readURef . unPrimSysDef) pSysDef +simulateDyn pSysDef inps = runST ( + do let sysDefVal = (readURef . unPrimSysDef) pSysDef + sysDefInIface = iIface sysDefVal + -- List where to store the Vars generated by delay processes + roots <- newSTRef [] + -- Input port ids paired with a reference to each input value list + inpPairs <- zipWithM (\(id,_) inputL -> + do {ref <- newSTRef inputL; return (id,ref)}) + sysDefInIface inps + + let -- Add a Var to the roots list + root r = + do rs <- readSTRef roots + writeSTRef roots (r:rs) + + -- Create an empty var + empty = do rval <- newSTRef (error "val?") + rwir <- newSTRef (error "wire?") + return (rval, rwir) + new node = + do mapM (\tag -> do {e <- empty; return (tag, e)}) (outTags node) + newInstance varPairs node = + let funName = "ForSyDe.Backend.Simulate.simulateDyn" + in case node of + InPort id -> + case lookup id varPairs of + -- FIXME: replace the Other error with a custom one + Nothing -> intError funName (Other "inconsistency") + Just var -> return [(InPortOut, var)] + _ -> new node + + -- define for the general traversal + define nodeVarPairs childVars = + case (nodeVarPairs,childVars) of + ([(InPortOut, var)], InPort name) -> do + let inputRef = fromJust $ lookup name inpPairs + relate var [] $ + do (curr:rest) <- readSTRef inputRef + writeSTRef inputRef rest + return curr + + _ -> defineShared nodeVarPairs childVars + + -- define for instances + defineInstance nodeVarPairs childVars = + case (nodeVarPairs,childVars) of + ([(InPortOut, _)], InPort _) -> return () + _ -> defineShared nodeVarPairs childVars + + -- Shared part of define define for instances and the main traversal + defineShared nodeVarPairs childVars = -- r s = + case (nodeVarPairs,childVars) of + ([(InPortOut, _)], InPort _) -> return () + + (nodeVarPairs, + Proc _ (SysIns pSysDef ins)) -> + -- FIXME: ugly ugly ugly + do let sysDefVal = (readURef . unPrimSysDef) pSysDef + taggedIns = zipWith (\(id,_) var -> (id,var)) + (iIface sysDefVal) ins + sr <- traverseST + (newInstance taggedIns) + defineInstance + (netlist sysDefVal) + + let relateIns prevVar@(prevValR,_) (_,nextVar) = + relate nextVar [prevVar] (readSTRef prevValR) + + zipWithM_ relateIns sr nodeVarPairs + + ([(DelaySYOut, nodeVar)], + Proc _ (DelaySY (ProcVal init _) sigVar)) -> + do valVar <- empty + relate valVar [] (return init) + delay nodeVar valVar sigVar + _ -> + do let evalPairs = eval `fmap` DT.mapM (readSTRef.fst) childVars + args = arguments childVars + relEval (tag, var) = + relate var args $ + -- FIXME: remove fromJust and write a proper error + liftM (fromJust.(lookup tag)) evalPairs + mapM_ relEval nodeVarPairs + where + delay r ri@(rinit,_) r1@(pre,_) = + do state <- newSTRef Nothing + r2 <- empty + root r2 + + relate r [ri] $ + do ms <- readSTRef state + case ms of + Just s -> return s + Nothing -> + do s <- readSTRef rinit + writeSTRef state (Just s) + return s + + relate r2 [r,r1] $ + do s <- readSTRef pre + writeSTRef state (Just s) + return s + + sr <- traverseST new define (netlist sysDefVal) + rs <- readSTRef roots + -- remove tags of the resulting vars (all the root nodes should only + -- have one output and thus a must return a unique list) + step <- drive (sr ++ rs) + + outs <- lazyloop $ + do step + s <- DT.mapM (readSTRef . fst) sr + return s + -- Since the simulation is done in a per-cycle basis + -- the results (outs) are transposed (not what we want) + -- e.g. + -- imagine a system whose outputs are its inputs plus 1 + -- then, for this these two inputs [[1,2,3],[4,5,6]] + -- outs would be [[2,5],[3,6],[4,7]] + -- + -- We need as well to check that all inputs are defined in + -- each simulation cycle e.g. [[1,2,3],[4,5,6,7]] as input + -- makes imposible to simulate cycle 4 + -- + -- NOTE: having to check this makes simulation really inneficient + -- a solution would providing a cycle-based simulation input/output + -- which wouldn't suffer from this problems + -- Or, even better, a simulation which showed a diffierent type of output + let inN = length sysDefInIface + res = if inN == 0 then + transpose outs + else transpose (checkIns inN (transpose inps) outs) + return res + ) + + +-- evaluation order + +relate :: Var s -> [Var s] -> ST s Dynamic -> ST s () +relate (rval, rwir) rs f = + do writeSTRef rwir $ + Wire{ dependencies = rs + , kick = do b <- f + writeSTRef rval b + } + +drive :: [Var s] -> ST s (ST s ()) +drive [] = + do return (return ()) + +drive ((_,rwir):rs) = + do wire <- readSTRef rwir + writeSTRef rwir (error "detected combinational loop") + driv1 <- drive (dependencies wire) + writeSTRef rwir $ + Wire { dependencies = [], kick = return () } + driv2 <- drive rs + return $ + do driv1 + kick wire + driv2 + +---------------------------------------------------------------- +-- helper functions + +lazyloop :: ST s a -> ST s [a] +lazyloop m = + do a <- m + as <- STU.unsafeInterleaveST (lazyloop m) + return (a:as) + +-- | check that there will only be output as long as there are inputs +checkIns :: Int -- ^ number of inputs + -> [[a]] -- ^ transposed inputs + -> [[b]] -- ^ transposed outputs (infinitie list) + -> [[b]] -- ^ selected outputs + +-- The lazy pattern match is used to avoid evaluating the output list +-- if length i /= nIns. If that happens the input lists of simulate will +-- implicitly be simulated, and due to lack of inputs it will cause an error. +checkIns nIns (i:is) ~(o:os) | length i == nIns = o : checkIns nIns is os +checkIns _ _ _ = [] + + + + diff --git a/src/ForSyDe/Deep/Backend/VHDL.hs b/src/ForSyDe/Deep/Backend/VHDL.hs new file mode 100644 --- /dev/null +++ b/src/ForSyDe/Deep/Backend/VHDL.hs @@ -0,0 +1,125 @@ +----------------------------------------------------------------------------- +-- | +-- Module : ForSyDe.Deep.Backend.VHDL +-- Copyright : (c) ES Group, KTH/ICT/ES 2007-2013 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : forsyde-dev@ict.kth.se +-- Stability : experimental +-- Portability : portable +-- +-- This module provides the VHDL backend of ForSyDe's embedded compiler +-- +----------------------------------------------------------------------------- +module ForSyDe.Deep.Backend.VHDL + (writeVHDL, + writeVHDLOps, + writeAndModelsimVHDL, + writeAndModelsimVHDLOps, + writeAndGhdlVHDL, + writeAndGhdlVHDLOps, + VHDLOps(..), + QuartusOps(..), + QuartusAction(..), + checkSynthesisQuartus, + VHDLDebugLevel(..), + VHDLRecursivity(..), + defaultVHDLOps) where + +import Control.Monad.State (evalStateT) +import qualified Language.Haskell.TH as TH + +import ForSyDe.Deep.System.SysFun +import ForSyDe.Deep.ForSyDeErr +import ForSyDe.Deep.OSharing (readURef) +import ForSyDe.Deep.System.SysDef +import ForSyDe.Deep.Backend.VHDL.Traverse +import ForSyDe.Deep.Backend.VHDL.Modelsim +import ForSyDe.Deep.Backend.VHDL.Ghdl + +-- | Given a System Definition whose name is a valid VHDL _basic_ identifier +-- (call it \"A\") generate @A.vhd@ in current working directory using +-- default compilation options. +-- Imp: the input and output signal names of A must be valid VHDL identifiers +-- (basic or extended) and different to @clk@ and @reset@ +-- which are reserved for the main clock and reset signals +writeVHDL :: SysDef a -> IO () +writeVHDL = writeVHDLOps defaultVHDLOps + +-- | 'writeVHDL'-alternative which allows setting VHDL compilation options. +writeVHDLOps :: VHDLOps -> SysDef a -> IO () +writeVHDLOps ops sysDef = do + -- initiate the compilation State + let sinit = initVHDLTravST $ (readURef.unPrimSysDef.unSysDef) sysDef + -- Compile the code + res <- runErrorT $ evalStateT (setVHDLOps ops >> writeVHDLM) sinit + -- Check if the compilation went well and print an error in case it didn't + either printVHDLError return res + + + +-- | Generate a function which, given a system definition and some simulation +-- stimuli: +-- +-- (1) Writes a VHDL model of the system +-- +-- (2) Simulates the VHDL model with Modelsim getting the results back to Haskell +writeAndModelsimVHDL :: SysFunToIOSimFun sysF simF => + Maybe Int -- ^ Number of cycles to simulate + -- if 'Nothing' the number will be determined + -- by the length of the input stimulti. + -- Useful when the system to simulate doesn't + -- have inputs or the inputs provided are + -- infinite + -> SysDef sysF -- ^ system definition to simulate + -> simF +writeAndModelsimVHDL = writeAndModelsimVHDLOps defaultVHDLOps + + +-- | 'VHDLOps'-alternative of 'writeAndModelsimVHDL', note that +-- compileModelSim will implicitly be set to True +writeAndModelsimVHDLOps :: SysFunToIOSimFun sysF simF => + VHDLOps -> Maybe Int -> SysDef sysF -> simF +writeAndModelsimVHDLOps ops mCycles sysDef = fromTHStrSimFun simIO [] + where sinit = initVHDLTravST $ (readURef.unPrimSysDef.unSysDef) sysDef + simVHDLM :: [[TH.Exp]] -> VHDLM [[String]] + simVHDLM stimuli = do + setVHDLOps ops{compileModelsim=True} + writeVHDLM + executeTestBenchModelsim mCycles stimuli + simIO :: [[TH.Exp]] -> IO [[String]] + simIO stimuli = do + res <- runErrorT $ evalStateT (simVHDLM stimuli) sinit + either printVHDLError return res + +-- | Generate a function which, given a system definition and some simulation +-- stimuli: +-- +-- (1) Writes a VHDL model of the system +-- +-- (2) Simulates the VHDL model with Ghdl getting the results back to Haskell +writeAndGhdlVHDL :: SysFunToIOSimFun sysF simF => + Maybe Int -- ^ Number of cycles to simulate + -- if 'Nothing' the number will be determined + -- by the length of the input stimulti. + -- Useful when the system to simulate doesn't + -- have inputs or the inputs provided are + -- infinite + -> SysDef sysF -- ^ system definition to simulate + -> simF +writeAndGhdlVHDL = writeAndGhdlVHDLOps defaultVHDLOps + +-- | 'VHDLOps'-alternative of 'writeAndGhdlVHDL' +writeAndGhdlVHDLOps :: SysFunToIOSimFun sysF simF => + VHDLOps -> Maybe Int -> SysDef sysF -> simF +writeAndGhdlVHDLOps ops mCycles sysDef = fromTHStrSimFun simIO [] + where sinit = initVHDLTravST $ (readURef.unPrimSysDef.unSysDef) sysDef + simVHDLM :: [[TH.Exp]] -> VHDLM [[String]] + simVHDLM stimuli = do + setVHDLOps ops + writeVHDLM + executeTestBenchGhdl mCycles stimuli + simIO :: [[TH.Exp]] -> IO [[String]] + simIO stimuli = do + res <- runErrorT $ evalStateT (simVHDLM stimuli) sinit + either printVHDLError return res diff --git a/src/ForSyDe/Deep/Backend/VHDL/AST.hs b/src/ForSyDe/Deep/Backend/VHDL/AST.hs new file mode 100644 --- /dev/null +++ b/src/ForSyDe/Deep/Backend/VHDL/AST.hs @@ -0,0 +1,720 @@ +----------------------------------------------------------------------------- +-- | +-- Module : ForSyDe.Deep.Backend.VHDL.AST +-- Copyright : (c) ES Group, KTH/ICT/ES 2007-2013 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : forsyde-dev@ict.kth.se +-- Stability : experimental +-- Portability : non-portable (Template Haskell) +-- +-- A VHDL 93 subset AST (Abstract Syntax Tree), coded so that it can be easy +-- to extend, please see doc/VHDL/vhdl93-syntax.html as reference +-- in order to extend it (this AST is based on that grammar) +----------------------------------------------------------------------------- + +-- This AST is aimed at code generation not parsing, and thus, +-- it was simplified +-- The incompatibilities or simplifications from the standard +-- are properly commented + +-- FIXME: shouldn't be records used instead of bare algebraic types? +-- FIXME: shouldn't the unused type redefinitions be removed? +-- FIXME: It would maybe be a good idea to create a sequence ADT which +-- guaranteed to hold at least one element (i.e. the grammar +-- has some cases such as "choices ::= choice | {choice}" +-- which are not well represented as "[Choice]", +-- "Choices Choice (Maybe [Choice])" is not easy to handle either +-- and thus, it was discarded. + +module ForSyDe.Deep.Backend.VHDL.AST where + +import Data.Char (toLower) +import Text.Regex.Posix + +import ForSyDe.Deep.ForSyDeErr + + +-------------------- +-- VHDL identifiers +-------------------- + +-- VHDL identifier, use mkVHDLId to create it from a String, +-- making sure a string is a proper VHDL identifier +data VHDLId = Basic String | Extended String + deriving Eq + +-- | Obtain the String of a VHDL identifier +fromVHDLId :: VHDLId -> String +fromVHDLId (Basic str) = str +fromVHDLId (Extended str) = '\\' : (escapeBackslashes str) ++ "\\" + where escapeBackslashes [] = [] + escapeBackslashes (x : xs) + | x == '\\' = "\\\\" ++ escapeBackslashes xs + | otherwise = x : escapeBackslashes xs +instance Show VHDLId where + show = show.fromVHDLId + + +-- | unsafely create a basic VHDLId (without cheking if the string is correct) +unsafeVHDLBasicId :: String -> VHDLId +unsafeVHDLBasicId str = Basic str + + +-- | unsafely create an exteded VHDLId (without cheking if the string is +-- correct) +unsafeVHDLExtId :: String -> VHDLId +unsafeVHDLExtId str = Extended str + +-- | unsafely create a VHDLId for different containers. They are basic or +-- extended based on the type of values they contain. +unsafeVHDLContainerId :: [VHDLId] -> String -> VHDLId +unsafeVHDLContainerId ids = if any isExt ids then unsafeVHDLExtId + else unsafeVHDLBasicId + where + isExt (Extended _) = True + isExt (Basic _) = False + +-- | Create a VHDL basic identifier from a String, previously checking if the +-- String is correct +mkVHDLBasicId ::String -> EProne VHDLId +-- FIXME: we relax the fact that two consecutive underlines +-- are not allowed +mkVHDLBasicId [] = throwError EmptyVHDLId +mkVHDLBasicId id + | id =~ basiIdPat && (not $ elem lowId reservedWords) = return $ Basic id + | otherwise = throwError $ IncVHDLBasId id + where lowId = map toLower id + basiIdPat = "^[A-Za-z](_?[A-Za-z0-9])*$" + +-- | Create a VHDL extended identifier from a String, previously checking +-- if the String is correct. The input string must not include the initial +-- and ending backslashes nad the intermediate backslashes shouldn't be escaped. +mkVHDLExtId :: String -> EProne VHDLId +mkVHDLExtId [] = throwError EmptyVHDLId +mkVHDLExtId id + | id =~ extIdPat = return $ Extended id + | otherwise = throwError $ IncVHDLExtId id + where -- Regular expression pattern for extended identifiers. + -- According to the VHDL93 standard, an extended identifier must: + -- * Start and end with a backslash '\' + -- * Its middle characters can be + -- * two contiguous backslashes \\ + -- * an alphanumeric (A-Za-z0-9) + -- * a Special Character + -- * an Other Special Character + -- (backslashes can only appear in pairs as indicated above) + -- + -- However, backslashes will be handled when printing the identifier, + -- (an initial and ending backslash are added and the intermediate backslashes + -- are escaped) + -- + -- Note that we cannot use specialChars and otherSpecialChars + -- to build the pattern because of the double-backslash rule + -- and also, the right bracket (according to the posix + -- standard) needs to go in the first place of a bracket + -- expression to lose its special meaning. Furthermore, + -- (according to the POSIX standard as well) we also need to put + -- '-' in the last place of the bracket expression. + extIdPat = + "^[]A-Za-z0-9 \"#&\\'()*+,./:;<=>_|!$%@?[^`{}~-]+$" + + +-- | Unsafely append a string to a VHDL identifier (i.e. without checking if +-- the resulting identifier is valid) +unsafeIdAppend :: VHDLId -> String -> VHDLId +unsafeIdAppend (Basic id) suffix = Basic $ id ++ suffix +unsafeIdAppend (Extended id) suffix = Extended $ id ++ suffix + +-- | special characters as defined in the VHDL93 standard +specialChars :: [Char] +specialChars = ['"' , '#' , '&' , '\'' , '(' , ')' , '*' , '+' , ',', + '-' , '.' , '/' , ':' , ';' , '<' , '=' , '>' , '_' , '|'] + +-- | other special characters as defined in the VHDL93 standard +otherSpecialChars :: [Char] +otherSpecialChars =['!' , '$' , '%' , '@' , '?' , '[' , '\\' , ']', + '^' , '`' , '{' , '}' , '~'] + +-- | Reserved identifiers +reservedWords :: [String] +reservedWords = ["abs", "access", "after", "alias", "all", "and", + "architecture", "array", "assert", "attribute", "begin", "block", + "body", "buffer", "bus", "case", "component", "configuration", + "constant", "disconnect", "downto", "else", "elsif", "end", "entity", + "exit", "file", "for", "function", "generate", "generic", "group", + "guarded", "if", "impure", "in", "inertial", "inout", "is", "label", + "library", "linkage", "literal", "loop", "map", "mod", "nand", "new", + "next", "nor", "not", "null", "of", "on", "open", "or", "others", + "out", "package", "port", "postponed", "procedure", "process", "pure", + "range", "record", "register", "reject", "rem", "report", "return", + "rol", "ror", "select", "severity", "shared", "signal", "sla", "sll", + "sra", "srl", "subtype", "then", "to", "transport", "type", + "unaffected", "units", "until", "use", "variable", "wait", "when", + "while", "with", "xnor", "xor"] + + + + + --------- + -- AST -- + --------- + + +-- { } (0 or more) is expressed as [ ] +-- [ ] (optional) is expressed as Maybe + + +-- design_file +-- Having ContextClauses associated to library units is messy +-- instead we only allow ContextClause for the whole design file. +-- Furthermore we incorrectly (and deliberately) accept a file with +-- no library units +data DesignFile = DesignFile [ContextItem] [LibraryUnit] + deriving Show + +-- context_item +-- We don't allow the "name1,name2,name3" syntax, only one name is allowed +-- at once +data ContextItem = Library VHDLId | Use SelectedName + deriving Show + +-- library_unit +-- We avoid adding the overhead of a PrimaryUnit and SecondaryUnit types +data LibraryUnit = LUEntity EntityDec | + LUArch ArchBody | + LUPackageDec PackageDec | + LUPackageBody PackageBody + deriving Show + +-- entity_declaration +-- No declarative nor statemet part is allowed +-- Only interface signal declarations are allowed in the port clause +data EntityDec = EntityDec VHDLId [IfaceSigDec] + deriving Show + +-- | interface_signal_declaration +-- We don't allow the "id1,id2,id3" syntax, only one identifier is allowed +-- at once +-- The Mode is mandatory +-- Bus is not allowed +-- Preasigned values are not allowed +-- Subtype indications are not allowed, just a typemark +-- Constraints are not allowed: just add a new type with the constarint +-- in ForSyDe.vhd if it is required +data IfaceSigDec = IfaceSigDec VHDLId Mode TypeMark + deriving Show + +-- | type_mark +-- We don't distinguish between type names and subtype names +-- We dont' support selected names, only simple names because we won't need +-- name selection (i.e. Use clauses will make name selection unnecesary) +type TypeMark = SimpleName + + +-- | mode +-- INOUT | BUFFER | LINKAGE are not allowed +data Mode = In | Out + deriving (Show, Eq) + +-- | architecture_body +-- [ ARCHITECTURE ] and [ architecture_simple_name ] are not allowed +data ArchBody = ArchBody VHDLId VHDLName [BlockDecItem] [ConcSm] + deriving Show + +-- | package_declaration +-- [ PACKAGE ] and [ package_simple_name ] are not allowed +data PackageDec = PackageDec VHDLId [PackageDecItem] + deriving Show + + +-- | package_declarative_item +-- only type declarations, subtype declarations and subprogram specifications +-- (working as subprogram_declaration) allowed +data PackageDecItem = PDITD TypeDec | PDISD SubtypeDec | PDISS SubProgSpec + deriving Show + +-- | package_body +-- [ PACKAGE ] and [ package_simple_name ] are not allowed +data PackageBody = PackageBody VHDLId [PackageBodyDecItem] + deriving Show + +-- | only subprogram_body is allowed +type PackageBodyDecItem = SubProgBody + +-- | subtype-declaration +data SubtypeDec = SubtypeDec VHDLId SubtypeIn + deriving Show + +-- | subtype_indication +-- resolution functions are not permitted +data SubtypeIn = SubtypeIn TypeMark (Maybe Constraint) + deriving Show + +-- | constraint +-- Only index constraints are allowed +type Constraint = IndexConstraint + +-- | range +-- the direction must always be \"to\" +data Range = AttribRange AttribName | ToRange Expr Expr + deriving Show + +-- | index_constraint +data IndexConstraint = IndexConstraint [DiscreteRange] + deriving Show + +-- | discrete_range +-- only ranges are allowed +type DiscreteRange = Range + +-- | type_declaration +-- only full_type_declarations are allowed +data TypeDec = TypeDec VHDLId TypeDef + deriving Show + +-- | type_declaration +-- only composite types and enumeration types (a specific scalar type) +data TypeDef = TDA ArrayTypeDef | TDR RecordTypeDef | TDE EnumTypeDef + deriving Show + +-- | array_type_definition +-- unconstrained_array_definition +-- constrained_array_definition +-- A TypeMark is used instead of a subtype_indication. If subtyping is required, +-- declare a subtype explicitly. +data ArrayTypeDef = UnconsArrayDef [TypeMark] TypeMark | + ConsArrayDef IndexConstraint TypeMark + deriving Show + +-- | record_type_definition +-- [ record_type_simple_name ] not allowed +data RecordTypeDef = RecordTypeDef [ElementDec] + deriving Show + +-- | element_declaration +-- multi-identifier element declarations not allowed +-- element_subtype_definition is simplified to a type_mark +data ElementDec = ElementDec VHDLId TypeMark + deriving Show + +-- | enumeration_type_definition +-- enumeration literals can only be identifiers +data EnumTypeDef = EnumTypeDef [VHDLId] + deriving Show + +-- | name +-- operator_names are not allowed +data VHDLName = NSimple SimpleName | + NSelected SelectedName | + NIndexed IndexedName | + NSlice SliceName | + NAttribute AttribName + deriving Show + +-- | simple_name +type SimpleName = VHDLId + +-- | selected_name +data SelectedName = Prefix :.: Suffix + deriving Show + +infixl :.: + +-- | indexed_name +-- note that according to the VHDL93 grammar the index list cannot be empty +data IndexedName = IndexedName Prefix [Expr] + deriving Show + +-- | prefix +-- only names (no function calls) +type Prefix = VHDLName + +-- | suffix +-- no character or operator symbols are accepted +data Suffix = SSimple SimpleName | All + deriving Show + + +-- | slice_name +data SliceName = SliceName Prefix DiscreteRange + deriving Show + +-- | attribute_name +-- signatures are not allowed +data AttribName = AttribName Prefix SimpleName (Maybe Expr) + deriving Show + +-- | block_declarative_item +-- Only subprogram bodies and signal declarations are allowed +data BlockDecItem = BDISPB SubProgBody | BDISD SigDec + deriving Show + + +-- | subprogram_body +-- No subprogram kind nor designator is allowed +data SubProgBody = SubProgBody SubProgSpec [SubProgDecItem] [SeqSm] + deriving Show + +-- | subprogram_declarative_item +-- only varaible declarations are allowed. +data SubProgDecItem = SPVD VarDec | SPSB SubProgBody + deriving Show + +-- | variable_declaration +-- identifier lists are not allowed +data VarDec = VarDec VHDLId SubtypeIn (Maybe Expr) + deriving Show + +-- | subprogram_specification +-- Only Functions are allowed +-- [Pure | Impure] is not allowed +-- Only an identifier is valid as the designator +-- In the formal parameter list only variable declarations are accepted +data SubProgSpec = Function VHDLId [IfaceVarDec] TypeMark + deriving Show + +-- | interface_variable_declaration +-- [variable] is not allowed +-- We don't allow the "id1,id2,id3" syntax, only one identifier is allowed +-- Mode is not allowed +-- Resolution functions and constraints are not allowed, thus a TypeMark +-- is used instead of a subtype_indication. If subtyping is required, +-- declare a subtype explicitly. +data IfaceVarDec = IfaceVarDec VHDLId TypeMark + deriving Show + +-- | sequential_statement +-- Only If, case, return, for loops, assignment, @wait for@ procedure calls +-- allowed. +-- Only for loops are allowed (thus loop_statement doesn't exist) and cannot +-- be provided labels. +-- The target cannot be an aggregate. +-- General wait statements are not allowed, only @wait for@ +-- It is incorrect to have an empty [CaseSmAlt] +data SeqSm = IfSm Expr [SeqSm] [ElseIf] (Maybe Else) | + CaseSm Expr [CaseSmAlt] | + ReturnSm (Maybe Expr) | + ForSM VHDLId DiscreteRange [SeqSm] | + VHDLName := Expr | + WaitFor Expr | + SigAssign VHDLName Wform | + ProcCall VHDLName [AssocElem] + deriving Show + +-- | helper type, they doesn't exist in the origianl grammar +data ElseIf = ElseIf Expr [SeqSm] + deriving Show + +-- | helper type, it doesn't exist in the origianl grammar +data Else = Else [SeqSm] + deriving Show + +-- | case_statement_alternative +-- it is incorrect to have an empty [Choice] +data CaseSmAlt = CaseSmAlt [Choice] [SeqSm] + deriving Show + +-- | choice +-- although any expression is allowed the grammar specfically only allows +-- simple_expressions (not covered in this AST) +data Choice = ChoiceE Expr | Others + deriving Show + +-- | signal_declaration +-- We don't allow the "id1,id2,id3" syntax, only one identifier is allowed +-- at once +-- Resolution functions and constraints are not allowed, thus a TypeMark +-- is used instead of a subtype_indication +-- Signal kinds are not allowed +data SigDec = SigDec VHDLId TypeMark (Maybe Expr) + deriving Show + +-- | concurrent_statement +-- only block statements, component instantiations and signal assignments +-- are allowed +data ConcSm = CSBSm BlockSm | + CSSASm ConSigAssignSm | + CSISm CompInsSm | + CSPSm ProcSm + deriving Show + +-- | block_statement +-- Generics are not supported +-- The port_clause (with only signals) and port_map_aspect are mandatory +-- The ending [ block_label ] is not allowed +-- +data BlockSm = BlockSm Label [IfaceSigDec] PMapAspect [BlockDecItem] [ConcSm] + deriving Show + +-- | port_map_aspect +newtype PMapAspect = PMapAspect [AssocElem] + deriving Show + +-- | label +type Label = VHDLId + +-- | association_element +data AssocElem = Maybe (FormalPart) :=>: ActualPart + deriving Show + +-- | formal_part +-- We only accept a formal_designator (which is a name after all), +-- in the forme of simple name (no need for selected names) +-- "function_name ( formal_designator )" and "type_mark ( formal_designator )" +-- are not allowed +type FormalPart = SimpleName + +-- | actual_part +-- We only accept an actual_designator, +-- "function_name ( actual_designator )" and "type_mark ( actual_designator )" +-- are not allowed +type ActualPart = ActualDesig + +-- | actual_designator +data ActualDesig = ADName VHDLName | ADExpr Expr | Open + deriving Show + +-- | concurrent_signal_assignment_statement +-- Only conditional_signal_assignment is allowed (without options) +-- The LHS (targets) are simply signal names, no aggregates +data ConSigAssignSm = VHDLName :<==: ConWforms + deriving Show + +-- | conditional_waveforms +data ConWforms = ConWforms [WhenElse] Wform (Maybe When) + deriving Show + +-- | Helper type, it doesn't exist in the VHDL grammar +data WhenElse = WhenElse Wform Expr + deriving Show + +-- | Helper type, it doesn't exist in the VHDL grammar +newtype When = When Expr + deriving Show + +-- | waveform +-- although it is possible to leave [Expr] empty, that's obviously not +-- valid VHDL waveform +data Wform = Wform [WformElem] | Unaffected + deriving Show + +-- | waveform_element +-- Null is not accepted +data WformElem = WformElem Expr (Maybe Expr) + deriving Show + + +-- | component_instantiation_statement +-- No generics supported +-- The port map aspect is mandatory +data CompInsSm = CompInsSm Label InsUnit PMapAspect + deriving Show + +-- | process_statement +-- The label is mandatory +-- Only simple names are accepted in the sensitivity list +-- No declarative part is allowed +data ProcSm = ProcSm Label [SimpleName] [SeqSm] + deriving Show + +-- | instantiated_unit +-- Only Entities are allowed and their architecture cannot be specified +data InsUnit = IUEntity VHDLName + deriving Show + +----------------- +-- Expression AST +----------------- + +-- | expression, instead of creating an AST like the grammar +-- (see commented section below) we made our own expressions which are +-- easier to handle, but which don't don't show operand precedence +-- (that is a responsibility of the pretty printer) + +data Expr = -- Logical operations + And Expr Expr | + Or Expr Expr | + Xor Expr Expr | + Nand Expr Expr | + Nor Expr Expr | + Xnor Expr Expr | + -- Relational Operators + Expr :=: Expr | + Expr :/=: Expr | + Expr :<: Expr | + Expr :<=: Expr | + Expr :>: Expr | + Expr :>=: Expr | + -- Shift Operators + Sll Expr Expr | + Srl Expr Expr | + Sla Expr Expr | + Sra Expr Expr | + Rol Expr Expr | + Ror Expr Expr | + -- Adding Operators + Expr :+: Expr | + Expr :-: Expr | + Expr :&: Expr | + -- Sign Operators + Neg Expr | + Pos Expr | + -- Multiplying Operators + Expr :*: Expr | + Expr :/: Expr | + Mod Expr Expr | + Rem Expr Expr | + -- Miscellaneous Operators + Expr :**: Expr | + Abs Expr | + Not Expr | + -- Primary expressions + -- Only literals, names and function calls are allowed + PrimName VHDLName | + PrimLit Literal | + PrimFCall FCall | + -- Composite_types-related operators + Aggregate [ElemAssoc] -- (exp1,exp2,exp3, ...) + deriving Show + +-- operand precedences, according to the VHDL LRM: +-- "Where the language +-- allows a sequence of operators, operators with the same +-- precedence level are associated with their operands in textual +-- order, from left to right." In other words, they are all left associative +-- +-- For example: a / b / c = (a/b)/c +-- a and b or c is illegal (mixing operators is not allowed +-- by the language and only +-- can avoid parenthesis in some +-- cases) + +infixl 2 `And`, `Or`, `Xor`, `Nand`, `Nor`, `Xnor` +infixl 3 :=:, :/=:, :<:, :<=:, :>:, :>=: +infixl 4 `Sll`, `Srl`, `Sla`, `Sra`, `Rol`, `Ror` +infixl 5 :+:, :-:, :&: +infix 6 `Neg`, `Pos` +infixl 7 :*:, :/:, `Mod`, `Rem` +infixl 8 :**:, `Abs`, `Not` + +-- | Logical Operators precedence +logicalPrec :: Int +logicalPrec = 2 + +-- | Relational Operators Precedence +relationalPrec :: Int +relationalPrec = 3 + +-- | Shift Operators Precedence +shiftPrec :: Int +shiftPrec = 4 + +-- | Plus Operators precedence +plusPrec :: Int +plusPrec = 5 + +-- | Sign Operators Precedence +signPrec :: Int +signPrec = 6 + +-- | Multplying Operators Precedecne +multPrec :: Int +multPrec = 7 + +-- | Miscellaneous Operators Precedence +miscPrec :: Int +miscPrec = 8 + + + + +-- | element_association +-- only one choice is allowed +data ElemAssoc = ElemAssoc (Maybe Choice) Expr + deriving Show + +-- | literal +-- Literals are expressed as a string (remember we are generating +-- code, not parsing) +type Literal = String + +-- | function_call +data FCall = FCall VHDLName [AssocElem] + deriving Show + + +{- + +Expression AST following the grammar (discarded) + +-- again, even if it possible to leave the [Relation] lists empty +-- that wouldn't be valid VHDL code +-- regading NandExpr and NorExpr, their Relation list should +-- have a maximum size of two (i.e. NandExpr Expr (Maybe Expr)) +data Expr = AndExpr [Relation] | + OrExpr [Relation] | + XorExpr [Relation] | + NandExpr [Relation] | + NorExpr [Relation] | + XnorExpr [Relation] + deriving Show + +-- relation +data Relation = Relation ShiftExpr (Maybe (RelOp,ShiftExpr)) + deriving Show + +-- relational_operator +data RelOp = Eq | NEq | Less | LessEq | Gter | GterEq + deriving Show + +-- shift_expression +data ShiftExpr = ShiftExpr SimpleExpr (Maybe(ShiftOp,SimpleExpr)) + deriving Show + +-- simple_expression +data SimpleExpr = SimpleExpr (Maybe Sign) Term [(AddOp,Term)] + deriving Show + +-- sign +data Sign = Pos | Neg + deriving Show + +-- shift_operator +data ShiftOp = Sll | Srl | Sla | Sra | Rol | Ror + deriving Show + +-- adding_operator +data AddOp = Plus | Minus | Concat + deriving Show + +-- term +data Term = Term Factor (Maybe (MultOp, Factor)) + deriving Show + +-- multiplying_operator +data MultOp = Mult | Div | Mod | Rem + deriving Show + +-- factor +data Factor = Exp Primary (Maybe (Primary)) | + Abs Primary | + Not Primary + deriving Show + +-- primary +-- Only literals, names and function calls are allowed +data Primary = PrimName VHDLName | + PrimLit Literal | + PrimFCall FCall + deriving Show + +-- literal +-- Literals are expressed as a string (remember we are generating +-- code, not parsing) +type Literal = String + +-- function_call +data FCall = FCall VHDLName [AssocElem] + deriving Show +-} diff --git a/src/ForSyDe/Deep/Backend/VHDL/Constants.hs b/src/ForSyDe/Deep/Backend/VHDL/Constants.hs new file mode 100644 --- /dev/null +++ b/src/ForSyDe/Deep/Backend/VHDL/Constants.hs @@ -0,0 +1,342 @@ +----------------------------------------------------------------------------- +-- | +-- Module : ForSyDe.Deep.Backend.VHDL.Constants +-- Copyright : (c) ES Group, KTH/ICT/ES +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : forsyde-dev@ict.kth.se +-- Stability : experimental +-- Portability : portable +-- +-- Constants used in the VHDL backend +-- +----------------------------------------------------------------------------- +module ForSyDe.Deep.Backend.VHDL.Constants where + +import ForSyDe.Deep.Backend.VHDL.AST + +-- | Standard context clause used in all generated vhdl files. It imports +commonContextClause :: [ContextItem] +commonContextClause = + [Library forsydeId, + Library ieeeId, + Use $ NSelected (NSimple forsydeId :.: SSimple typesId) :.: All, + Use $ NSelected (NSimple ieeeId :.: SSimple std_logic_1164Id) :.: All, + Use $ NSelected (NSimple ieeeId :.: SSimple numeric_stdId) :.: All] + where forsydeId = unsafeVHDLBasicId "forsyde" + ieeeId = unsafeVHDLBasicId "ieee" + typesId = unsafeVHDLBasicId "types" + std_logic_1164Id = unsafeVHDLBasicId "std_logic_1164" + numeric_stdId = unsafeVHDLBasicId "numeric_std" + +-------------- +-- Identifiers +-------------- + +-- | reset and clock signal identifiers in String form +resetStr, clockStr :: String +resetStr = "resetn" +clockStr = "clock" + +-- | reset and clock signal identifiers in basic VHDLId form +resetId, clockId :: VHDLId +resetId = unsafeVHDLBasicId resetStr +clockId = unsafeVHDLBasicId clockStr + + +-- | \"types\" identifier +typesId :: VHDLId +typesId = unsafeVHDLBasicId "types" + +-- | work identifier +workId :: VHDLId +workId = unsafeVHDLBasicId "work" + +-- | std identifier +stdId :: VHDLId +stdId = unsafeVHDLBasicId "std" + + +-- | textio identifier +textioId :: VHDLId +textioId = unsafeVHDLBasicId "textio" + +-- | range attribute identifier +rangeId :: VHDLId +rangeId = unsafeVHDLBasicId "range" + + +-- | range attribute identifier +imageId :: VHDLId +imageId = unsafeVHDLBasicId "image" + +-- | event attribute identifie +eventId :: VHDLId +eventId = unsafeVHDLBasicId "event" + + +-- | default function identifier +defaultId :: VHDLId +defaultId = unsafeVHDLBasicId "default" + + +-- AsbtExt function identifiers + +-- | absent function identifier +absentId :: VHDLId +absentId = unsafeVHDLBasicId "absent" + +-- | present function identifier +presentId :: VHDLId +presentId = unsafeVHDLBasicId "present" + +-- | fromAbstExt function identifier +fromAbstExtId :: VHDLId +fromAbstExtId = unsafeVHDLBasicId "fromAbstExt" + +-- | unsafeFromAbstExt function identifier +unsafeFromAbstExtId :: VHDLId +unsafeFromAbstExtId = unsafeVHDLBasicId "unsafeFromAbstExt" + +-- | value element identifier +valueId :: VHDLId +valueId = unsafeVHDLBasicId "value" + +-- | value element suffix +valueSuffix :: Suffix +valueSuffix = SSimple valueId + +-- | isPresent function and element identifier +isPresentId :: VHDLId +isPresentId = unsafeVHDLBasicId "isPresent" + +-- | isAbsent function identifier +isAbsentId :: VHDLId +isAbsentId = unsafeVHDLBasicId "isAbsent" + +-- FSVec function identifiers + +-- | ex (operator ! in original Haskell source) function identifier +exId :: VHDLId +exId = unsafeVHDLBasicId "ex" + +-- | sel (function select in original Haskell source) function identifier +selId :: VHDLId +selId = unsafeVHDLBasicId "sel" + + +-- | ltplus (function (<+) in original Haskell source) function identifier +ltplusId :: VHDLId +ltplusId = unsafeVHDLBasicId "ltplus" + + +-- | plusplus (function (++) in original Haskell source) function identifier +plusplusId :: VHDLId +plusplusId = unsafeVHDLBasicId "plusplus" + + +-- | empty function identifier +emptyId :: VHDLId +emptyId = unsafeVHDLBasicId "empty" + +-- | plusgt (function (+>) in original Haskell source) function identifier +plusgtId :: VHDLId +plusgtId = unsafeVHDLBasicId "plusgt" + +-- | singleton function identifier +singletonId :: VHDLId +singletonId = unsafeVHDLBasicId "singleton" + +-- | length function identifier +lengthId :: VHDLId +lengthId = unsafeVHDLBasicId "length" + + +-- | isnull (function null in original Haskell source) function identifier +isnullId :: VHDLId +isnullId = unsafeVHDLBasicId "isnull" + + +-- | replace function identifier +replaceId :: VHDLId +replaceId = unsafeVHDLBasicId "replace" + + +-- | head function identifier +headId :: VHDLId +headId = unsafeVHDLBasicId "head" + + +-- | last function identifier +lastId :: VHDLId +lastId = unsafeVHDLBasicId "last" + + +-- | init function identifier +initId :: VHDLId +initId = unsafeVHDLBasicId "init" + + +-- | tail function identifier +tailId :: VHDLId +tailId = unsafeVHDLBasicId "tail" + + +-- | take function identifier +takeId :: VHDLId +takeId = unsafeVHDLBasicId "take" + + +-- | drop function identifier +dropId :: VHDLId +dropId = unsafeVHDLBasicId "drop" + +-- | shiftl function identifier +shiftlId :: VHDLId +shiftlId = unsafeVHDLBasicId "shiftl" + +-- | shiftr function identifier +shiftrId :: VHDLId +shiftrId = unsafeVHDLBasicId "shiftr" + +-- | rotl function identifier +rotlId :: VHDLId +rotlId = unsafeVHDLBasicId "rotl" + +-- | reverse function identifier +rotrId :: VHDLId +rotrId = unsafeVHDLBasicId "rotr" + +-- | reverse function identifier +reverseId :: VHDLId +reverseId = unsafeVHDLBasicId "reverse" + +-- | toBitVector8 function identifier +toBitVector8Id :: VHDLId +toBitVector8Id = unsafeVHDLBasicId "toBitVector8" + +-- | toBitVector16 function identifier +toBitVector16Id :: VHDLId +toBitVector16Id = unsafeVHDLBasicId "toBitVector16" + +-- | toBitVector32 function identifier +toBitVector32Id :: VHDLId +toBitVector32Id = unsafeVHDLBasicId "toBitVector32" + + +-- | fromBitVector8 function identifier +fromBitVector8Id :: VHDLId +fromBitVector8Id = unsafeVHDLBasicId "fromBitVector8" + + +-- | fromBitVector16 function identifier +fromBitVector16Id :: VHDLId +fromBitVector16Id = unsafeVHDLBasicId "fromBitVector16" + + +-- | fromBitVector32 function identifier +fromBitVector32Id :: VHDLId +fromBitVector32Id = unsafeVHDLBasicId "fromBitVector32" + +-- | fixmul8 function identifier +fixmul8Id :: VHDLId +fixmul8Id = unsafeVHDLBasicId "fixmul8" + + + +-- | copy function identifier +copyId :: VHDLId +copyId = unsafeVHDLBasicId "copy" + + +-- | show function identifier +showId :: VHDLId +showId = unsafeVHDLBasicId "show" + + +-- | write function idenfier (from std.textio) +writeId :: VHDLId +writeId = unsafeVHDLBasicId "write" + +-- | output file identifier (from std.textio) +outputId :: VHDLId +outputId = unsafeVHDLBasicId "output" + +-------- +-- Names +-------- + +defaultSN :: VHDLName +defaultSN = NSimple defaultId + +------------------ +-- VHDL type marks +------------------ + +-- | Stardard logic type mark +std_logicTM :: TypeMark +std_logicTM = unsafeVHDLBasicId "std_logic" + +-- | boolean type mark +booleanTM :: TypeMark +booleanTM = unsafeVHDLBasicId "boolean" + +-- | fsvec_index typemark +fsvec_indexTM :: TypeMark +fsvec_indexTM = unsafeVHDLBasicId "fsvec_index" + +-- | natural typemark +naturalTM :: TypeMark +naturalTM = unsafeVHDLBasicId "natural" + +-- | int32 typemark (defined in ForSyDe's VHDL library) +int64TM :: TypeMark +int64TM = unsafeVHDLBasicId "int64" + +-- | int32 typemark (defined in ForSyDe's VHDL library) +int32TM :: TypeMark +int32TM = unsafeVHDLBasicId "int32" + +-- | int32 typemark (defined in ForSyDe's VHDL library) +int16TM :: TypeMark +int16TM = unsafeVHDLBasicId "int16" + +-- | int8 typemark (defined in ForSyDe's VHDL library) +int8TM :: TypeMark +int8TM = unsafeVHDLBasicId "int8" + +-- | string typemark +stringTM :: TypeMark +stringTM = unsafeVHDLBasicId "string" + +-------------- +-- Expressions +-------------- + +-- | true expression +trueExpr :: Expr +trueExpr = PrimName (NSimple $ unsafeVHDLBasicId "true") + +-- | false expression +falseExpr :: Expr +falseExpr = PrimName (NSimple $ unsafeVHDLBasicId "false") + +-- | \'0\' bit expression +lowExpr :: Expr +lowExpr = PrimLit "'0'" + +-- | \'1\' bit expression +highExpr :: Expr +highExpr = PrimLit "'1'" + +-- | tup string record suffix +tupStrSuffix :: Int -> String +tupStrSuffix n = "tup_" ++ show n + +-- | tup VHLID record suffix +tupVHDLIdSuffix :: Int -> VHDLId +tupVHDLIdSuffix = unsafeVHDLBasicId . tupStrSuffix + +-- | tup VHDLName suffix +tupVHDLSuffix :: Int -> Suffix +tupVHDLSuffix = SSimple . tupVHDLIdSuffix diff --git a/src/ForSyDe/Deep/Backend/VHDL/FileIO.hs b/src/ForSyDe/Deep/Backend/VHDL/FileIO.hs new file mode 100644 --- /dev/null +++ b/src/ForSyDe/Deep/Backend/VHDL/FileIO.hs @@ -0,0 +1,30 @@ +----------------------------------------------------------------------------- +-- | +-- Module : ForSyDe.Deep.Backend.VHDL.FileIO +-- Copyright : (c) ES Group, KTH/ICT/ES 2007-2013 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : forsyde-dev@ict.kth.se +-- Stability : experimental +-- Portability : portable +-- +-- Functions working with files in the VHDL backend. +-- +----------------------------------------------------------------------------- +module ForSyDe.Deep.Backend.VHDL.FileIO (writeDesignFile) where + +import ForSyDe.Deep.Backend.VHDL.AST +import ForSyDe.Deep.Backend.VHDL.Ppr() -- instances +import qualified ForSyDe.Deep.Backend.Ppr as ForSyDePpr (ppr) + +import System.IO +import Text.PrettyPrint.HughesPJ + +-- | Write a design file to a file in disk +writeDesignFile :: DesignFile -> FilePath -> IO () +writeDesignFile df fp = do + handle <- openFile fp WriteMode + hPutStrLn handle "-- Automatically generated by ForSyDe" + hPutStr handle $ (renderStyle mystyle . ForSyDePpr.ppr) df + hClose handle + where mystyle = style{lineLength=80, ribbonsPerLine=1} diff --git a/src/ForSyDe/Deep/Backend/VHDL/Generate.hs b/src/ForSyDe/Deep/Backend/VHDL/Generate.hs new file mode 100644 --- /dev/null +++ b/src/ForSyDe/Deep/Backend/VHDL/Generate.hs @@ -0,0 +1,721 @@ +----------------------------------------------------------------------------- +-- | +-- Module : ForSyDe.Deep.Backend.VHDL.Generate +-- Copyright : (c) ES Group, KTH/ICT/ES 2007-2013 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : forsyde-dev@ict.kth.se +-- Stability : experimental +-- Portability : portable +-- +-- Functions used to generate VHDL AST elements without making any +-- explicit translation. +-- +----------------------------------------------------------------------------- +module ForSyDe.Deep.Backend.VHDL.Generate where + +import ForSyDe.Deep.Backend.VHDL.Constants +import ForSyDe.Deep.Backend.VHDL.AST +import ForSyDe.Deep.Backend.VHDL.Traverse.VHDLM + +-- | Generate a list of asignments (in 'ConcSm' form) of intermediate signals +-- (first argument) to final output signals (second argument) +genOutAssigns :: [VHDLId] -> [VHDLId] -> [ConcSm] +genOutAssigns = zipWith assign + where assign dest orig = CSSASm $ dest `genSignalAssign` orig + +-- | Generate a simple signal assignment, from a VHDL identifier to a +-- VHDL identifier +genSignalAssign :: VHDLId -- ^ destination + -> VHDLId -- ^ origin + -> ConSigAssignSm +genSignalAssign dest orig = genExprAssign dest (PrimName $ NSimple orig) + +-- | Generate a function call asignment +genFCallAssign :: VHDLId -- ^ destination signal + -> VHDLId -- ^ Function Name + -> [VHDLId] -- ^ Function formal parameters + -> [VHDLId] -- ^ Function actual parameters + -> ConSigAssignSm +genFCallAssign dest fName formal actual = + genExprAssign dest (PrimFCall $ genFCall fName formal actual) + +-- | Generate a simple assignment from an expression to a name +genExprAssign :: VHDLId -> Expr -> ConSigAssignSm +genExprAssign dest origExpr = + NSimple dest :<==: (ConWforms [] (Wform [WformElem origExpr Nothing]) + Nothing) + +-- | Generate a system design file for a system from the global system +-- identifier, +-- local traversing results and the translated entity declaration +genSysDesignFile :: String -> EntityDec -> LocalTravResult -> DesignFile +genSysDesignFile globalSysId ent@(EntityDec id _) (LocalTravResult decs stms) = + DesignFile contextClause [LUEntity ent, LUArch archBody] + where archBody = ArchBody archId (NSimple id) decs stms + archId = unsafeVHDLBasicId "synthesizable" + libName = globalSysId ++ "_lib" + libId = unsafeVHDLBasicId libName + contextClause = commonContextClause ++ + [Library libId, + Use $ NSelected (NSimple libId :.: SSimple typesId) :.: All] + +-- | Generate a library design file from the global results +genLibDesignFile :: GlobalTravResult -> DesignFile +genLibDesignFile (GlobalTravResult typeDecs subtypeDecs subProgBodies) = + DesignFile commonContextClause [LUPackageDec packageDec, + LUPackageBody packageBody] + -- Due to dependency among types and subtypes we first output + -- unconstrained types (which may have constarined types depending on), + -- then subtypes (which we may have composite types depending on) + -- A general solution could be a type dependency resolving algorithm + where packageDec = PackageDec typesId (packageUnconsTypeDecs ++ + packageSubtypeDecs ++ + packageTypeDecs ++ + subProgSpecs) + packageUnconsTypeDecs = map PDITD $ filter (\a -> isUnconsType a) typeDecs + packageTypeDecs = map PDITD $ filter (\a -> (not.isUnconsType) a) typeDecs + packageSubtypeDecs = map PDISD subtypeDecs + subProgSpecs = map (\(SubProgBody spec _ _) -> PDISS spec) subProgBodies + packageBody = PackageBody typesId subProgBodies + isUnconsType (TypeDec _ (TDA (UnconsArrayDef _ _))) = True + isUnconsType _ = False + + +-- | Generate a list of association from two lists of signal identifiers +-- The first one establishes the formal parameters +genAssocElems :: [VHDLId] -> [VHDLId] -> [AssocElem] +genAssocElems formalNames actualNames = zipWith genAssoc formalNames actualNames + +-- | Generate a port map from two lists of signal identifiers +-- The first list establishes the formal parameters +genPMap :: [VHDLId] -> [VHDLId] -> PMapAspect +genPMap formalIds actualIds = + PMapAspect $ genAssocElems formalIds actualIds + + +-- | Generate a function call from two lists of signal identifiers +-- The first list establishes the formal parameters +genFCall :: VHDLId -> [VHDLId] -> [VHDLId] -> FCall +genFCall fName formalIds actualIds = + FCall (NSimple fName) $ zipWith genAssoc formalIds actualIds + + +-- | Generate a function call from the Function Name and a list of expressions +-- (its arguments) +genExprFCall :: VHDLId -> [Expr] -> Expr +genExprFCall fName args = + PrimFCall $ FCall (NSimple fName) $ + map (\exp -> Nothing :=>: ADExpr exp) args + +-- | version of genExprFCall which requires exactly n arguments +genExprFCallN :: VHDLId -> Int -> [Expr] -> Expr +genExprFCallN fName n args = genExprFCall fName (takeExactly n args) + where takeExactly 0 [] = [] + takeExactly n (x:xs) | n > 0 = x : takeExactly (n-1) xs + takeExactly _ _ = error "takeExactly: non exact length of input list" + +-- | Generate a function call from the Function Name (constant function) +genExprFCall0 :: VHDLId -> Expr +genExprFCall0 fName = genExprFCall fName [] + +-- | List version of genExprFCall0 +genExprFCall0L :: VHDLId -> [Expr] -> Expr +genExprFCall0L fName [] = genExprFCall fName [] +genExprFCall0L _ _ = error "ForSyDe.Backend.VHDL.Generate.genExprFCall0L incorrect length" + +-- | Generate a function call from the Function Name and an expression argument +genExprFCall1 :: VHDLId -> Expr -> Expr +genExprFCall1 fName arg = genExprFCall fName [arg] + +-- | List version of genExprFCall1 +genExprFCall1L :: VHDLId -> [Expr] -> Expr +genExprFCall1L fName [arg] = genExprFCall fName [arg] +genExprFCall1L _ _ = error "ForSyDe.Backend.VHDL.Generate.genExprFCall1L incorrect length" + +-- | Generate a function call from the Function Name and two expression arguments +genExprFCall2 :: VHDLId -> Expr -> Expr -> Expr +genExprFCall2 fName arg1 arg2 = genExprFCall fName [arg1,arg2] + +-- | List version of genExprFCall2 +genExprFCall2L :: VHDLId -> [Expr] -> Expr +genExprFCall2L fName [arg1, arg2] = genExprFCall fName [arg1,arg2] +genExprFCall2L _ _ = error "ForSyDe.Backend.VHDL.Generate.genExprFCall2L incorrect length" + +-- | Generate a function call from the Function Name and two expression arguments +genExprFCall4 :: VHDLId -> Expr -> Expr -> Expr -> Expr -> Expr +genExprFCall4 fName arg1 arg2 arg3 arg4 = + genExprFCall fName [arg1,arg2,arg2,arg3,arg4] + + +-- | List version of genExprFCall4 +genExprFCall4L :: VHDLId -> [Expr] -> Expr +genExprFCall4L fName [arg1, arg2, arg3, arg4] = + genExprFCall fName [arg1,arg2,arg2,arg3,arg4] +genExprFCall4L _ _ = error "ForSyDe.Backend.VHDL.Generate.genExprFCall4L incorrect length" + +-- | Generate a procedure call from the Function Name and a list of expressions +-- (its arguments) +genExprProcCall :: VHDLId -> [Expr] -> SeqSm +genExprProcCall pName args = ProcCall (NSimple pName) $ + map (\exp -> Nothing :=>: ADExpr exp) args + + +-- | Generate a procedure call from the Function Name (constant procedure) +genExprProcCall0 :: VHDLId -> SeqSm +genExprProcCall0 fName = genExprProcCall fName [] + + +-- | Generate a procedure call from the Function Name and an expression argument +genExprProcCall1 :: VHDLId -> Expr -> SeqSm +genExprProcCall1 pName arg = genExprProcCall pName [arg] + + +-- | Generate a procedure call from the Function Name and four expression +-- arguments +genExprProcCall2 :: VHDLId -> Expr -> Expr -> SeqSm +genExprProcCall2 pName arg1 arg2 = genExprProcCall pName [arg1,arg2] + + +-- | Generate a procedure call from the Function Name and two expression +-- arguments +genExprProcCall4 :: VHDLId -> Expr -> Expr -> Expr -> Expr -> SeqSm +genExprProcCall4 pName arg1 arg2 arg3 arg4 = + genExprProcCall pName [arg1,arg2,arg2,arg3,arg4] + + +-- Generate an association of a formal and actual parameter +genAssoc :: VHDLId -> VHDLId -> AssocElem +genAssoc formal actual = Just formal :=>: ADName (NSimple actual) + + +-- | Generate the default functions for an unconstrained custom vector type +genUnconsVectorFuns :: TypeMark -- ^ type of the vector elements + -> TypeMark -- ^ type of the vector + -> [SubProgBody] +genUnconsVectorFuns elemTM vectorTM = + [SubProgBody exSpec [] [exExpr] , + SubProgBody selSpec [SPVD selVar] [selFor, selRet] , + SubProgBody emptySpec [SPVD emptyVar] [emptyExpr] , + SubProgBody lengthSpec [] [lengthExpr] , + SubProgBody isnullSpec [] [isnullExpr] , + SubProgBody replaceSpec [SPVD replaceVar] [replaceExpr, replaceRet] , + SubProgBody headSpec [] [headExpr] , + SubProgBody lastSpec [] [lastExpr] , + SubProgBody initSpec [SPVD initVar] [initExpr, initRet] , + SubProgBody tailSpec [SPVD tailVar] [tailExpr, tailRet] , + SubProgBody takeSpec [SPVD takeVar] [takeExpr, takeRet] , + SubProgBody dropSpec [SPVD dropVar] [dropExpr, dropRet] , + SubProgBody shiftlSpec [SPVD shiftlVar] [shiftlExpr, shiftlRet] , + SubProgBody shiftrSpec [SPVD shiftrVar] [shiftrExpr, shiftrRet] , + SubProgBody rotlSpec [SPVD rotlVar] [rotlExpr, rotlRet] , + SubProgBody rotrSpec [SPVD rotrVar] [rotrExpr, rotrRet] , + SubProgBody reverseSpec [SPVD reverseVar] [reverseFor, reverseRet] , + SubProgBody copySpec [SPVD copyVar] [copyExpr] , + SubProgBody plusgtSpec [SPVD plusgtVar] [plusgtExpr, plusgtRet] , + SubProgBody ltplusSpec [SPVD ltplusVar] [ltplusExpr, ltplusRet] , + SubProgBody plusplusSpec [SPVD plusplusVar] [plusplusExpr, plusplusRet] , + SubProgBody singletonSpec [SPVD singletonVar] [singletonRet] , + SubProgBody showSpec [SPSB doShowDef] [showRet] , + SubProgBody defaultSpec [] [defaultExpr] ] + where ixPar = unsafeVHDLBasicId "ix" + vecPar = unsafeVHDLBasicId "vec" + vec1Par = unsafeVHDLBasicId "vec1" + vec2Par = unsafeVHDLBasicId "vec2" + fPar = unsafeVHDLBasicId "f" + nPar = unsafeVHDLBasicId "n" + sPar = unsafeVHDLBasicId "s" + iId = unsafeVHDLBasicId "i" + iPar = iId + aPar = unsafeVHDLBasicId "a" + resId = unsafeVHDLBasicId "res" + exSpec = Function exId [IfaceVarDec vecPar vectorTM, + IfaceVarDec ixPar naturalTM] elemTM + exExpr = + ReturnSm (Just $ PrimName $ NIndexed + (IndexedName (NSimple vecPar) [PrimName $ NSimple ixPar])) + selSpec = Function selId [IfaceVarDec fPar naturalTM, + IfaceVarDec nPar naturalTM, + IfaceVarDec sPar naturalTM, + IfaceVarDec vecPar vectorTM ] vectorTM + -- variable res : fsvec_x (0 to n-1); + selVar = + VarDec resId + (SubtypeIn vectorTM + (Just $ IndexConstraint + [ToRange (PrimLit "0") + ((PrimName (NSimple nPar)) :-: + (PrimLit "1")) ])) + Nothing + -- for i res'range loop + -- res(i) := vec(f+i*s); + -- end loop; + selFor = ForSM iId (AttribRange $ applyRangeAttrib resId) [selAssign] + -- res(i) := vec(f+i*s); + selAssign = let origExp = PrimName (NSimple fPar) :+: + (PrimName (NSimple iId) :*: + PrimName (NSimple sPar)) in + NIndexed (IndexedName (NSimple resId) [PrimName (NSimple iId)]) := + (PrimName $ NIndexed (IndexedName (NSimple vecPar) [origExp])) + -- return res; + selRet = ReturnSm (Just $ PrimName (NSimple resId)) + emptySpec = Function emptyId [] vectorTM + emptyVar = + VarDec resId + (SubtypeIn vectorTM + (Just $ IndexConstraint + [ToRange (PrimLit "0") + (PrimLit "-1")])) + Nothing + emptyExpr = ReturnSm (Just $ PrimName (NSimple resId)) + lengthSpec = Function lengthId [IfaceVarDec vecPar vectorTM] naturalTM + lengthExpr = ReturnSm (Just $ PrimName (NAttribute $ + AttribName (NSimple vecPar) lengthId Nothing)) + isnullSpec = Function isnullId [IfaceVarDec vecPar vectorTM] booleanTM + -- return vec'length = 0 + isnullExpr = ReturnSm (Just $ + PrimName (NAttribute $ + AttribName (NSimple vecPar) lengthId Nothing) :=: + PrimLit "0") + replaceSpec = Function replaceId [IfaceVarDec vecPar vectorTM, + IfaceVarDec iPar naturalTM, + IfaceVarDec aPar elemTM ] vectorTM + -- variable res : fsvec_x (0 to vec'length-1); + replaceVar = + VarDec resId + (SubtypeIn vectorTM + (Just $ IndexConstraint + [ToRange (PrimLit "0") + (PrimName (NAttribute $ + AttribName (NSimple vecPar) lengthId Nothing) :-: + (PrimLit "1")) ])) + Nothing + -- res := vec(0 to i-1) & a & vec(i+1 to length'vec-1) + replaceExpr = NSimple resId := + (vecSlice (PrimLit "0") (PrimName (NSimple iPar) :-: PrimLit "1") :&: + PrimName (NSimple aPar) :&: + vecSlice (PrimName (NSimple iPar) :+: PrimLit "1") + ((PrimName (NAttribute $ + AttribName (NSimple vecPar) lengthId Nothing)) + :-: PrimLit "1")) + replaceRet = ReturnSm (Just $ PrimName $ NSimple resId) + vecSlice init last = PrimName (NSlice + (SliceName + (NSimple vecPar) + (ToRange init last))) + headSpec = Function headId [IfaceVarDec vecPar vectorTM] elemTM + -- return vec(0); + headExpr = ReturnSm (Just $ (PrimName $ NIndexed (IndexedName + (NSimple vecPar) [PrimLit "0"]))) + lastSpec = Function lastId [IfaceVarDec vecPar vectorTM] elemTM + -- return vec(vec'length-1); + lastExpr = ReturnSm (Just $ (PrimName $ NIndexed (IndexedName + (NSimple vecPar) + [PrimName (NAttribute $ + AttribName (NSimple vecPar) lengthId Nothing) + :-: PrimLit "1"]))) + initSpec = Function initId [IfaceVarDec vecPar vectorTM] vectorTM + -- variable res : fsvec_x (0 to vec'length-2); + initVar = + VarDec resId + (SubtypeIn vectorTM + (Just $ IndexConstraint + [ToRange (PrimLit "0") + (PrimName (NAttribute $ + AttribName (NSimple vecPar) lengthId Nothing) :-: + (PrimLit "2")) ])) + Nothing + -- res:= vec(0 to vec'length-2) + initExpr = NSimple resId := (vecSlice + (PrimLit "0") + (PrimName (NAttribute $ + AttribName (NSimple vecPar) lengthId Nothing) + :-: PrimLit "2")) + initRet = ReturnSm (Just $ PrimName $ NSimple resId) + tailSpec = Function tailId [IfaceVarDec vecPar vectorTM] vectorTM + -- variable res : fsvec_x (0 to vec'length-2); + tailVar = + VarDec resId + (SubtypeIn vectorTM + (Just $ IndexConstraint + [ToRange (PrimLit "0") + (PrimName (NAttribute $ + AttribName (NSimple vecPar) lengthId Nothing) :-: + (PrimLit "2")) ])) + Nothing + -- res := vec(1 to vec'length-1) + tailExpr = NSimple resId := (vecSlice + (PrimLit "1") + (PrimName (NAttribute $ + AttribName (NSimple vecPar) lengthId Nothing) + :-: PrimLit "1")) + tailRet = ReturnSm (Just $ PrimName $ NSimple resId) + takeSpec = Function takeId [IfaceVarDec nPar naturalTM, + IfaceVarDec vecPar vectorTM ] vectorTM + -- variable res : fsvec_x (0 to n-1); + takeVar = + VarDec resId + (SubtypeIn vectorTM + (Just $ IndexConstraint + [ToRange (PrimLit "0") + ((PrimName (NSimple nPar)) :-: + (PrimLit "1")) ])) + Nothing + -- res := vec(0 to n-1) + takeExpr = NSimple resId := + (vecSlice (PrimLit "1") + (PrimName (NSimple $ nPar) :-: PrimLit "1")) + takeRet = ReturnSm (Just $ PrimName $ NSimple resId) + dropSpec = Function dropId [IfaceVarDec nPar naturalTM, + IfaceVarDec vecPar vectorTM ] vectorTM + -- variable res : fsvec_x (0 to vec'length-n-1); + dropVar = + VarDec resId + (SubtypeIn vectorTM + (Just $ IndexConstraint + [ToRange (PrimLit "0") + (PrimName (NAttribute $ + AttribName (NSimple vecPar) lengthId Nothing) :-: + (PrimName $ NSimple nPar):-: (PrimLit "1")) ])) + Nothing + -- res := vec(n to vec'length-1) + dropExpr = NSimple resId := (vecSlice + (PrimName $ NSimple nPar) + (PrimName (NAttribute $ + AttribName (NSimple vecPar) lengthId Nothing) + :-: PrimLit "1")) + dropRet = ReturnSm (Just $ PrimName $ NSimple resId) + shiftlSpec = Function shiftlId [IfaceVarDec vecPar vectorTM, + IfaceVarDec aPar elemTM ] vectorTM + -- variable res : fsvec_x (0 to vec'length-1); + shiftlVar = + VarDec resId + (SubtypeIn vectorTM + (Just $ IndexConstraint + [ToRange (PrimLit "0") + (PrimName (NAttribute $ + AttribName (NSimple vecPar) lengthId Nothing) :-: + (PrimLit "1")) ])) + Nothing + -- res := a & init(vec) + shiftlExpr = NSimple resId := + (PrimName (NSimple aPar) :&: + genExprFCall1 initId (PrimName $ NSimple vecPar)) + shiftlRet = ReturnSm (Just $ PrimName $ NSimple resId) + shiftrSpec = Function shiftrId [IfaceVarDec vecPar vectorTM, + IfaceVarDec aPar elemTM ] vectorTM + -- variable res : fsvec_x (0 to vec'length-1); + shiftrVar = + VarDec resId + (SubtypeIn vectorTM + (Just $ IndexConstraint + [ToRange (PrimLit "0") + (PrimName (NAttribute $ + AttribName (NSimple vecPar) lengthId Nothing) :-: + (PrimLit "1")) ])) + Nothing + -- res := tail(vec) & a + shiftrExpr = NSimple resId := + (genExprFCall1 tailId (PrimName $ NSimple vecPar) :&: + PrimName (NSimple aPar)) + shiftrRet = ReturnSm (Just $ PrimName $ NSimple resId) + rotlSpec = Function rotlId [IfaceVarDec vecPar vectorTM] vectorTM + -- variable res : fsvec_x (0 to vec'length-1); + rotlVar = + VarDec resId + (SubtypeIn vectorTM + (Just $ IndexConstraint + [ToRange (PrimLit "0") + (PrimName (NAttribute $ + AttribName (NSimple vecPar) lengthId Nothing) :-: + (PrimLit "1")) ])) + Nothing + -- if null(vec) then res := vec else res := last(vec) & init(vec) + rotlExpr = IfSm (genExprFCall1 isnullId (PrimName $ NSimple vecPar)) + [NSimple resId := (PrimName $ NSimple vecPar)] + [] + (Just $ Else [rotlExprRet]) + where rotlExprRet = + NSimple resId := + (genExprFCall1 lastId (PrimName $ NSimple vecPar) :&: + genExprFCall1 initId (PrimName $ NSimple vecPar)) + rotlRet = ReturnSm (Just $ PrimName $ NSimple resId) + rotrSpec = Function rotrId [IfaceVarDec vecPar vectorTM] vectorTM + -- variable res : fsvec_x (0 to vec'length-1); + rotrVar = + VarDec resId + (SubtypeIn vectorTM + (Just $ IndexConstraint + [ToRange (PrimLit "0") + (PrimName (NAttribute $ + AttribName (NSimple vecPar) lengthId Nothing) :-: + (PrimLit "1")) ])) + Nothing + -- if null(vec) then res := vec else res := tail(vec) & head(vec) + rotrExpr = IfSm (genExprFCall1 isnullId (PrimName $ NSimple vecPar)) + [NSimple resId := (PrimName $ NSimple vecPar)] + [] + (Just $ Else [rotrExprRet]) + where rotrExprRet = + NSimple resId := + (genExprFCall1 lastId (PrimName $ NSimple vecPar) :&: + genExprFCall1 initId (PrimName $ NSimple vecPar)) + rotrRet = ReturnSm (Just $ PrimName $ NSimple resId) + reverseSpec = Function reverseId [IfaceVarDec vecPar vectorTM] vectorTM + reverseVar = + VarDec resId + (SubtypeIn vectorTM + (Just $ IndexConstraint + [ToRange (PrimLit "0") + (PrimName (NAttribute $ + AttribName (NSimple vecPar) lengthId Nothing) :-: + (PrimLit "1")) ])) + Nothing + -- for i in 0 to res'range loop + -- res(vec'length-i-1) := vec(i); + -- end loop; + reverseFor = + ForSM iId (AttribRange $ applyRangeAttrib resId) [reverseAssign] + -- res(vec'length-i-1) := vec(i); + reverseAssign = NIndexed (IndexedName (NSimple resId) [destExp]) := + (PrimName $ NIndexed (IndexedName (NSimple vecPar) + [PrimName $ NSimple iId])) + where destExp = PrimName (NAttribute $ AttribName (NSimple vecPar) + lengthId Nothing) :-: + PrimName (NSimple iId) :-: + (PrimLit "1") + -- return res; + reverseRet = ReturnSm (Just $ PrimName (NSimple resId)) + copySpec = Function copyId [IfaceVarDec nPar naturalTM, + IfaceVarDec aPar elemTM ] vectorTM + -- variable res : fsvec_x (0 to n-1) := (others => a); + copyVar = + VarDec resId + (SubtypeIn vectorTM + (Just $ IndexConstraint + [ToRange (PrimLit "0") + ((PrimName (NSimple nPar)) :-: + (PrimLit "1")) ])) + (Just $ Aggregate [ElemAssoc (Just Others) + (PrimName $ NSimple aPar)]) + -- return res + copyExpr = ReturnSm (Just $ PrimName $ NSimple resId) + plusgtSpec = Function plusgtId [IfaceVarDec aPar elemTM, + IfaceVarDec vecPar vectorTM] vectorTM + -- variable res : fsvec_x (0 to vec'length); + plusgtVar = + VarDec resId + (SubtypeIn vectorTM + (Just $ IndexConstraint + [ToRange (PrimLit "0") + (PrimName (NAttribute $ + AttribName (NSimple vecPar) lengthId Nothing))])) + Nothing + plusgtExpr = NSimple resId := + ((PrimName $ NSimple aPar) :&: + (PrimName $ NSimple vecPar)) + plusgtRet = ReturnSm (Just $ PrimName $ NSimple resId) + ltplusSpec = Function ltplusId [IfaceVarDec vecPar vectorTM, + IfaceVarDec aPar elemTM] vectorTM + -- variable res : fsvec_x (0 to vec'length); + ltplusVar = + VarDec resId + (SubtypeIn vectorTM + (Just $ IndexConstraint + [ToRange (PrimLit "0") + (PrimName (NAttribute $ + AttribName (NSimple vecPar) lengthId Nothing))])) + Nothing + ltplusExpr = NSimple resId := + ((PrimName $ NSimple vecPar) :&: + (PrimName $ NSimple aPar)) + ltplusRet = ReturnSm (Just $ PrimName $ NSimple resId) + plusplusSpec = Function plusplusId [IfaceVarDec vec1Par vectorTM, + IfaceVarDec vec2Par vectorTM ] + vectorTM + -- variable res : fsvec_x (0 to vec1'length + vec2'length -1); + plusplusVar = + VarDec resId + (SubtypeIn vectorTM + (Just $ IndexConstraint + [ToRange (PrimLit "0") + (PrimName (NAttribute $ + AttribName (NSimple vec1Par) lengthId Nothing) :+: + PrimName (NAttribute $ + AttribName (NSimple vec2Par) lengthId Nothing) :-: + PrimLit "1")])) + Nothing + plusplusExpr = NSimple resId := + ((PrimName $ NSimple vec1Par) :&: + (PrimName $ NSimple vec2Par)) + plusplusRet = ReturnSm (Just $ PrimName $ NSimple resId) + singletonSpec = Function singletonId [IfaceVarDec aPar elemTM ] + vectorTM + -- variable res : fsvec_x (0 to 0) := (others => a); + singletonVar = + VarDec resId + (SubtypeIn vectorTM + (Just $ IndexConstraint + [ToRange (PrimLit "0") (PrimLit "0")])) + (Just $ Aggregate [ElemAssoc (Just Others) + (PrimName $ NSimple aPar)]) + singletonRet = ReturnSm (Just $ PrimName $ NSimple resId) + showSpec = Function showId [IfaceVarDec vecPar vectorTM] stringTM + doShowId = unsafeVHDLBasicId "doshow" + doShowDef = SubProgBody doShowSpec [] [doShowRet] + where doShowSpec = Function doShowId [IfaceVarDec vecPar vectorTM] + stringTM + -- case vec'len is + -- when 0 => return ""; + -- when 1 => return head(vec); + -- when others => return show(head(vec)) & ',' & + -- doshow (tail(vec)); + -- end case; + doShowRet = + CaseSm (PrimName (NAttribute $ + AttribName (NSimple vecPar) lengthId Nothing)) + [CaseSmAlt [ChoiceE $ PrimLit "0"] + [ReturnSm (Just $ PrimLit "\"\"")], + CaseSmAlt [ChoiceE $ PrimLit "1"] + [ReturnSm (Just $ + genExprFCall1 showId + (genExprFCall1 headId (PrimName $ NSimple vecPar)) )], + CaseSmAlt [Others] + [ReturnSm (Just $ + genExprFCall1 showId + (genExprFCall1 headId (PrimName $ NSimple vecPar)) :&: + PrimLit "','" :&: + genExprFCall1 doShowId + (genExprFCall1 tailId (PrimName $ NSimple vecPar)) ) ]] + -- return '<' & doshow(vec) & '>'; + showRet = ReturnSm (Just $ PrimLit "'<'" :&: + genExprFCall1 doShowId (PrimName $ NSimple vecPar) :&: + PrimLit "'>'" ) + + defaultSpec = Function defaultId [] vectorTM + defaultExpr = + ReturnSm (Just $ genExprFCall0 emptyId) + + +-- | Generate the default functions for a custom tuple type +genTupleFuns :: [TypeMark] -- ^ type of each tuple element + -> TypeMark -- ^ type of the tuple + -> [SubProgBody] +genTupleFuns elemTMs tupleTM = + [SubProgBody defaultSpec [] [defaultExpr], + SubProgBody showSpec [] [showExpr]] + where tupPar = unsafeVHDLBasicId "tup" + defaultSpec = Function defaultId [] tupleTM + defaultExpr = + ReturnSm (Just $ Aggregate (replicate tupSize + (ElemAssoc Nothing $ PrimName defaultSN))) + showSpec = Function showId [IfaceVarDec tupPar tupleTM ] stringTM + -- return '(' & show(tup. + showExpr = ReturnSm (Just $ + PrimLit "'('" :&: showMiddle :&: PrimLit "')'") + where showMiddle = foldr1 (\e1 e2 -> e1 :&: PrimLit "','" :&: e2) $ + map ((genExprFCall1 showId). + PrimName . + NSelected. + (NSimple tupPar:.:). + tupVHDLSuffix) + [1..tupSize] + tupSize = length elemTMs + +-- | Generate the default functions for a custom abst_ext_ type +genAbstExtFuns :: TypeMark -- ^ type of the values nested in AbstExt + -> TypeMark -- ^ type of the extended values + -> [SubProgBody] +genAbstExtFuns elemTM absExtTM = + [SubProgBody defaultSpec [] [defaultExpr], + SubProgBody absentSpec [] [absentExpr] , + SubProgBody presentSpec [] [presentExpr], + SubProgBody fromAbstExtSpec [] [fromAbstExtExpr], + SubProgBody unsafeFromAbstExtSpec [] [unsafeFromAbstExtExpr], + SubProgBody isPresentSpec [] [isPresentExpr], + SubProgBody isAbsentSpec [] [isAbsentExpr], + SubProgBody showSpec [] [showExpr] ] + where defaultPar = unsafeVHDLBasicId "default" + extPar = unsafeVHDLBasicId "extabst" + defaultSpec = Function defaultId [] absExtTM + defaultExpr = + ReturnSm (Just $ PrimName $ NSimple absentId) + absentSpec = Function absentId [] absExtTM + absentExpr = + ReturnSm (Just $ Aggregate + [ElemAssoc Nothing falseExpr, + ElemAssoc Nothing $ PrimName $ defaultSN ]) + presentSpec = + Function presentId [IfaceVarDec extPar elemTM] absExtTM + presentExpr = + ReturnSm (Just $ Aggregate [ElemAssoc Nothing trueExpr, + ElemAssoc Nothing $ PrimName $ NSimple extPar ]) + fromAbstExtSpec = Function fromAbstExtId [IfaceVarDec defaultPar elemTM, + IfaceVarDec extPar absExtTM] + elemTM + fromAbstExtExpr = + IfSm (PrimName $ NSelected (NSimple extPar :.: SSimple isPresentId)) + [ReturnSm (Just $ PrimName $ + (NSelected (NSimple extPar :.: SSimple valueId)))] + [] + (Just $ Else + [ReturnSm (Just $ PrimName $ NSimple defaultPar)]) + unsafeFromAbstExtSpec = + Function unsafeFromAbstExtId [IfaceVarDec extPar absExtTM] elemTM + unsafeFromAbstExtExpr = + ReturnSm (Just $ + PrimName (NSelected (NSimple extPar :.: SSimple valueId))) + isPresentSpec = + Function isPresentId [IfaceVarDec extPar absExtTM] booleanTM + isPresentExpr = + ReturnSm (Just $ + PrimName (NSelected (NSimple extPar :.: SSimple isPresentId))) + isAbsentSpec = + Function isAbsentId [IfaceVarDec extPar absExtTM] booleanTM + isAbsentExpr = + ReturnSm (Just $ + Not $ PrimName (NSelected (NSimple extPar :.: SSimple isPresentId))) + showSpec = Function showId [IfaceVarDec extPar absExtTM ] stringTM + -- if extabs.isPresent + -- return "Prst " & show(extabs.value); + -- else + -- return "Abst"; + -- end if; + showExpr = + IfSm (PrimName $ NSelected (NSimple extPar :.: SSimple isPresentId)) + [ReturnSm (Just $ PrimLit "\"Prst \"" :&: + genExprFCall1 showId (PrimName $ + (NSelected (NSimple extPar :.: SSimple valueId))))] + [] + (Just $ Else + [ReturnSm (Just $ PrimLit "\"Abst\"")]) + + + +-- | Generate the default functions for a custom enumeration type +genEnumAlgFuns :: TypeMark -- ^ enumeration type + -> VHDLId -- ^ First enumeration literal of the type + -> [SubProgBody] +genEnumAlgFuns enumTM firstLit = + [SubProgBody defaultSpec [] [defaultExpr], + SubProgBody showSpec [] [showExpr]] + where enumPar = unsafeVHDLBasicId "enum" + defaultSpec = Function defaultId [] enumTM + defaultExpr = ReturnSm (Just $ PrimName (NSimple firstLit)) + showSpec = Function showId [IfaceVarDec enumPar enumTM] stringTM + -- we slice the resulting image in order to eliminate the + -- leading and trailing slashes + -- + -- return enumTM'image(enum)(2 to enumTM'image(enum)'length-1); + showExpr = ReturnSm (Just $ PrimName $ NSlice $ SliceName image + (ToRange (PrimLit "2") + ((PrimName $ NAttribute $ + AttribName image lengthId Nothing) :-: + PrimLit "1"))) + where image = NAttribute$ AttribName (NSimple enumTM) imageId + (Just $ PrimName $ NSimple enumPar) + +-- | Apply the range attribute out of a simple name +applyRangeAttrib :: SimpleName -> AttribName +applyRangeAttrib sName = AttribName (NSimple sName) rangeId Nothing + diff --git a/src/ForSyDe/Deep/Backend/VHDL/Ghdl.hs b/src/ForSyDe/Deep/Backend/VHDL/Ghdl.hs new file mode 100644 --- /dev/null +++ b/src/ForSyDe/Deep/Backend/VHDL/Ghdl.hs @@ -0,0 +1,213 @@ +----------------------------------------------------------------------------- +-- | +-- Module : ForSyDe.Deep.Backend.VHDL.Ghdl +-- Copyright : (c) ES Group, KTH/ICT/ES 2007-2013 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : forsyde-dev@ict.kth.se +-- Stability : experimental +-- Portability : portable +-- +-- Functions to process the VHDL compilation results with GHDL. +----------------------------------------------------------------------------- +module ForSyDe.Deep.Backend.VHDL.Ghdl (executeTestBenchGhdl) where + +import ForSyDe.Deep.Backend.VHDL.Traverse.VHDLM +import ForSyDe.Deep.Backend.VHDL.TestBench + +import ForSyDe.Deep.System.SysDef +import ForSyDe.Deep.OSharing +import ForSyDe.Deep.ForSyDeErr +import ForSyDe.Deep.Config (getDataDir) + +import Data.Maybe (isJust) +import Control.Monad.State (gets) +import System.Directory (findExecutable, + setCurrentDirectory, + getTemporaryDirectory, + createDirectoryIfMissing) +import System.Process (readProcessWithExitCode, readProcess, runProcess, waitForProcess) +import System.Exit (ExitCode(..)) +import System.IO +import System.FilePath (()) +import qualified Language.Haskell.TH as TH (Exp) + +-- +-- This tool driver needs a Ghdl version containing the following commit, +-- otherwise it will fail with an obscure pattern match failure from within TH +-- generated code +-- +-- commit f6d8e786a1ca3165b41cea7de05b8f2151ac31ff +-- Author: Tristan Gingold +-- Date: Sat May 30 14:05:20 2015 +0200 +-- +-- write: do not implicitely append LF. +-- +-- The oldest release containing this was v0.33 +-- +data GhdlCommand = Analyze | Elaborate | Compile | Import | Run deriving Eq + +instance Show GhdlCommand where + show Analyze = "-a" + show Elaborate = "-e" + show Compile = "-c" + show Import = "-i" + show Run = "-r" + +data GhdlEnv = GhdlEnv { sysId :: String + , sysTb :: String + , syslib :: String + , tbFile :: FilePath + , tbExecutable :: FilePath + , libFile :: FilePath + , workFiles :: [FilePath] + , forsydeLibFile :: FilePath + , forsydeLibDir :: FilePath + , systemLibDir :: FilePath + , workDir :: FilePath + , paths :: [FilePath] + } + +mkGhdlEnv :: SysDefVal -> FilePath -> GhdlEnv +mkGhdlEnv sys osDataPath = + GhdlEnv + { sysId = sysId + , sysTb = sysTb + , syslib = syslib + , libFile = syslib (syslib ++ ".vhd") + , tbFile = "test" (sysTb ++ ".vhd") + , forsydeLibFile = osDataPath"lib""forsyde.vhd" + , workFiles = ("work" (sysId ++ ".vhd")) : + map (("work").(++".vhd").sid.readURef.unPrimSysDef) + (subSys sys) + , forsydeLibDir = forsydeLibDir + , systemLibDir = systemLibDir + , workDir = workDir + , tbExecutable = workDir sysTb + , paths = [forsydeLibDir, systemLibDir, workDir] + } + where + sysId = sid sys + syslib = sysId ++ "_lib" + sysTb = sysId ++ "_tb" + workDir = "work" "ghdl" + forsydeLibDir = "forsyde" "ghdl" + systemLibDir = syslib "ghdl" + + +-- | Generate a testbench and execute it with GHDL +-- (Note: the initial and final CWD will be / ) +executeTestBenchGhdl :: Maybe Int -- ^ Number of cycles to simulate + -> [[TH.Exp]] -- ^ input stimuli, each signal value + -- is expressed as a template haskell + -- expression + -> VHDLM [[String]] -- ^ results, each signal value + -- is expressed as a string +executeTestBenchGhdl mCycles stimuli = do + -- Check if GHDL is installed + installed <- liftIO isGhdlInstalled + unless installed (throwFError GhdlFailed) + + -- compile testbench + cycles <- writeVHDLTestBench mCycles stimuli + + -- assemble all the file paths for compilation + sysid <- gets (sid.globalSysDef.global) + sys <- gets (globalSysDef.global) + dataPath <- liftIO getDataDir + let env = mkGhdlEnv sys dataPath + + -- set up directory structure and tmp files + file <- liftIO $ do + setCurrentDirectory (sysid "vhdl") + tmpdir <- getTemporaryDirectory + (file, handle) <- openTempFile tmpdir "tb_out.txt" + hClose handle -- close handle to avoid opening problems in windows + mapM_ (createDirectoryIfMissing True) $ paths env + return file + + -- analyze the installed forsyde library + runGhdlCommand Analyze "forsyde" -- library (toplevel) + (forsydeLibDir env) -- workdir + [] -- include paths + [forsydeLibFile env] -- files + + -- analyze the generated system library + runGhdlCommand Analyze (syslib env) -- library (toplevel) + (systemLibDir env) -- workdir + [forsydeLibDir env] -- include paths + [libFile env] -- files + + -- compile test bench hierarchy + runGhdlCompile (sysTb env) -- toplevel + (workDir env) -- workdir + [forsydeLibDir env, systemLibDir env] -- include paths + (tbFile env:workFiles env) -- files + + -- Run simulation and capture output + testOutput <- runGhdlSim (sysTb env) cycles + + liftIO $ setCurrentDirectory (".." "..") + --liftIO $ print testOutput -- show what we actually get from Ghdl + + parseTestBenchOut testOutput + +runGhdlCompile :: String -> FilePath -> [FilePath] -> [FilePath] -> VHDLM () +runGhdlCompile toplevel workdir libPaths files = + runGhdlCommandInWorkdir Compile "work" workdir libPaths files extra + where + extra = [show Elaborate, + toplevel] + + +runGhdlCommand :: GhdlCommand + -> String -> FilePath -> [FilePath] -> [FilePath] + -> VHDLM () +runGhdlCommand cmd lib work paths files = + runGhdlCommandInWorkdir cmd lib work paths files [] + +runGhdlCommandInWorkdir :: GhdlCommand + -> String -> FilePath -> [FilePath] -> [FilePath] + -> [String] + -> VHDLM () +runGhdlCommandInWorkdir command libName workdir libPaths files extraOpts = + runCommand "ghdl" $ cmd ++ paths ++ opts ++ files ++ extraOpts + where + cmd = [show command] + paths = map ("-P"++) libPaths + opts = ["--work="++libName, + "--workdir="++workdir] + +runGhdlSim :: String -> Int -> VHDLM String +runGhdlSim toplevel cycles = do + (output,success) <- liftIO $ do + putStrLn $ "Running: ghdl " ++ unwords args + (exitcode,stdout,stderr) <- readProcessWithExitCode "ghdl" args stdin + let success = exitcode == ExitSuccess + return (stdout,success) + unless success (throwFError GhdlFailed) + return output + where + stdin = "" + args = [show Run, toplevel, "--stop-time="++show (cycles*10)++"ns"] + + +-- | run a shell command +runCommand :: String -- ^ Command to execute + -> [String] -- ^ Command arguments + -> VHDLM () +runCommand command args = do + success <- liftIO $ do + putStrLn msg + h <- runProcess command args Nothing Nothing Nothing Nothing Nothing + code <- waitForProcess h + return $ code == ExitSuccess + unless success (throwFError GhdlFailed) + where msg = "Running: " ++ command ++ " " ++ unwords args + + +-- Look for GHDL executables +isGhdlInstalled :: IO Bool +isGhdlInstalled = executablePresent "ghdl" + where executablePresent = liftM isJust .findExecutable + diff --git a/src/ForSyDe/Deep/Backend/VHDL/GlobalNameTable.hs b/src/ForSyDe/Deep/Backend/VHDL/GlobalNameTable.hs new file mode 100644 --- /dev/null +++ b/src/ForSyDe/Deep/Backend/VHDL/GlobalNameTable.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE TemplateHaskell #-} +----------------------------------------------------------------------------- +-- | +-- Module : ForSyDe.Deep.Backend.VHDL.GlobalNameTable +-- Copyright : (c) ES Group, KTH/ICT/ES 2007-2013 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : forsyde-dev@ict.kth.se +-- Stability : experimental +-- Portability : portable +-- +-- Global tranlsation table (symbol table) from Template Haskell Names to VHDL +-- expressions +-- +----------------------------------------------------------------------------- +module ForSyDe.Deep.Backend.VHDL.GlobalNameTable (globalNameTable) where + +import Data.Bits +import Language.Haskell.TH + + +import ForSyDe.Deep.AbsentExt +import qualified ForSyDe.Deep.Bit as B (not) +import ForSyDe.Deep.Bit hiding (not) +import qualified ForSyDe.Deep.Backend.VHDL.AST as VHDL +import ForSyDe.Deep.Backend.VHDL.AST +import ForSyDe.Deep.Backend.VHDL.Constants +import ForSyDe.Deep.Backend.VHDL.Generate +import qualified Data.Param.FSVec as V + +-- | Global tranlsation table from Template Haskell function and +-- constructor Names to VHDL expressions. The table works like this +-- +-- (function, constant constructor name, (arity, function to obtain a +-- VHDL expression +-- provided its +-- arguments are already +-- translated to VHDL )) +globalNameTable :: [(Name, (Int, [VHDL.Expr] -> VHDL.Expr ) )] +globalNameTable = [ +-- Unary constructors + ('Prst , (1, genExprFCall1L presentId ) ), +-- Constant constructors + ('True , (0, genZeroConsCall trueExpr ) ), + ('False , (0, genZeroConsCall falseExpr ) ), + ('H , (0, genZeroConsCall highExpr ) ), + ('L , (0, genZeroConsCall lowExpr ) ), + ('Abst , (0, genZeroConsCall (PrimName $ NSimple absentId) ) ), +-- Quaternary functions + ('V.select , (4, genExprFCall4L selId ) ), +-- Binary functions + ('(&&) , (2, genBinOpCall And ) ), + ('(||) , (2, genBinOpCall Or ) ), + ('(.&.) , (2, genBinOpCall And ) ), + ('(.|.) , (2, genBinOpCall Or ) ), + ('xor , (2, genBinOpCall Xor ) ), + ('(==) , (2, genBinOpCall (:=:) ) ), + ('(/=) , (2, genBinOpCall (:/=:) ) ), + ('(<) , (2, genBinOpCall (:<:) ) ), + ('(<=) , (2, genBinOpCall (:<=:) ) ), + ('(>) , (2, genBinOpCall (:>:) ) ), + ('(>=) , (2, genBinOpCall (:>=:) ) ), + ('(+) , (2, genBinOpCall (:+:) ) ), + ('(-) , (2, genBinOpCall (:-:) ) ), + ('(*) , (2, genBinOpCall (:*:) ) ), + ('div , (2, genBinOpCall (:/:) ) ), + ('mod , (2, genBinOpCall Mod ) ), + ('rem , (2, genBinOpCall Rem ) ), + ('(^) , (2, genBinOpCall (:**:) ) ), + ('(V.+>) , (2, genExprFCall2L plusgtId ) ), + ('(V.<+) , (2, genExprFCall2L ltplusId ) ), + ('(V.++) , (2, genExprFCall2L plusplusId ) ), + ('(V.!) , (2, genExprFCall2L exId ) ), + ('V.take , (2, genExprFCall2L takeId ) ), + ('V.drop , (2, genExprFCall2L dropId ) ), + ('V.shiftl , (2, genExprFCall2L shiftlId ) ), + ('V.shiftr , (2, genExprFCall2L shiftrId ) ), + ('V.copy , (2, genExprFCall2L copyId ) ), + ('fromAbstExt , (2, genExprFCall2L fromAbstExtId ) ), + ('fixmul8 , (2, genExprFCall2L fixmul8Id ) ), +-- unary functions + ('B.not , (1, genUnOpCall Not ) ), + ('not , (1, genUnOpCall Not ) ), + ('negate , (1, genUnOpCall Neg ) ), + ('abs , (1, genUnOpCall Abs ) ), + ('abstExt , (1, genExprFCall1L presentId ) ), + ('isAbsent , (1, genExprFCall1L isAbsentId ) ), + ('isPresent , (1, genExprFCall1L isPresentId ) ), + ('unsafeFromAbstExt, (1, genExprFCall1L unsafeFromAbstExtId ) ), + ('V.singleton , (1, genExprFCall1L singletonId ) ), + ('V.length , (1, genExprFCall1L lengthId ) ), + ('V.lengthT , (1, genExprFCall1L lengthId ) ), + ('V.genericLength , (1, genExprFCall1L lengthId ) ), + ('V.null , (1, genExprFCall1L isnullId ) ), + ('V.head , (1, genExprFCall1L headId ) ), + ('V.last , (1, genExprFCall1L lastId ) ), + ('V.init , (1, genExprFCall1L initId ) ), + ('V.tail , (1, genExprFCall1L tailId ) ), + ('V.rotl , (1, genExprFCall1L rotlId ) ), + ('V.rotr , (1, genExprFCall1L rotrId ) ), + ('V.reverse , (1, genExprFCall1L reverseId ) ), + ('toBitVector8 , (1, genExprFCall1L toBitVector8Id ) ), + ('toBitVector16 , (1, genExprFCall1L toBitVector16Id ) ), + ('toBitVector32 , (1, genExprFCall1L toBitVector32Id ) ), + ('fromBitVector8 , (1, genExprFCall1L fromBitVector8Id ) ), + ('fromBitVector16 , (1, genExprFCall1L fromBitVector16Id ) ), + ('fromBitVector32 , (1, genExprFCall1L fromBitVector32Id ) ), +-- constants + ('V.empty , (0, genExprFCall0L emptyId ) )] + where genBinOpCall op = \[e1, e2] -> e1 `op` e2 + genUnOpCall op = \[e] -> op e + genZeroConsCall cons = \[] -> cons diff --git a/src/ForSyDe/Deep/Backend/VHDL/GlobalNameTable.hs-boot b/src/ForSyDe/Deep/Backend/VHDL/GlobalNameTable.hs-boot new file mode 100644 --- /dev/null +++ b/src/ForSyDe/Deep/Backend/VHDL/GlobalNameTable.hs-boot @@ -0,0 +1,7 @@ +module ForSyDe.Deep.Backend.VHDL.GlobalNameTable (globalNameTable) where + + +import Language.Haskell.TH +import qualified ForSyDe.Deep.Backend.VHDL.AST as VHDL + +globalNameTable :: [(Name, (Int, [VHDL.Expr] -> VHDL.Expr ) )] diff --git a/src/ForSyDe/Deep/Backend/VHDL/Modelsim.hs b/src/ForSyDe/Deep/Backend/VHDL/Modelsim.hs new file mode 100644 --- /dev/null +++ b/src/ForSyDe/Deep/Backend/VHDL/Modelsim.hs @@ -0,0 +1,169 @@ +----------------------------------------------------------------------------- +-- | +-- Module : ForSyDe.Deep.Backend.VHDL.Modelsim +-- Copyright : (c) ES Group, KTH/ICT/ES 2007-2013 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : forsyde-dev@ict.kth.se +-- Stability : experimental +-- Portability : portable +-- +-- Functions to process the VHDL compilation results with Modelsim. +----------------------------------------------------------------------------- +module ForSyDe.Deep.Backend.VHDL.Modelsim (compileResultsModelsim, + executeTestBenchModelsim) where + +import ForSyDe.Deep.Backend.VHDL.Traverse.VHDLM +import ForSyDe.Deep.Backend.VHDL.TestBench + +import ForSyDe.Deep.System.SysDef +import ForSyDe.Deep.OSharing +import ForSyDe.Deep.ForSyDeErr +import ForSyDe.Deep.Config (getDataDir) + +import Data.List (intersperse) +import System.Directory (setCurrentDirectory) +import Control.Monad (liftM, when) +import Control.Monad.State (gets) +import System.Directory (findExecutable, getTemporaryDirectory) +import System.Process (runProcess, waitForProcess) +import System.Exit (ExitCode(..)) +import System.IO +import System.FilePath (()) +import qualified Language.Haskell.TH as TH (Exp) + +-- | Generate a testbench and execute it with Modelsim +-- (Note: the initial and final CWD will be / ) +executeTestBenchModelsim :: Maybe Int -- ^ Number of cycles to simulate + -> [[TH.Exp]] -- ^ input stimuli, each signal value + -- is expressed as a template haskell + -- expression + -> VHDLM [[String]] -- ^ results, each signal value + -- is expressed as a string +executeTestBenchModelsim mCycles stimuli= do + cycles <- writeVHDLTestBench mCycles stimuli + sysid <- gets (sid.globalSysDef.global) + -- change to sysid/vhdl/ + liftIO $ setCurrentDirectory (sysid "vhdl") + -- compile the testbench with modelsim + run_vcom ["-93", "-quiet", "-nologo", "-work", "work", + "test" (sysid ++ "_tb.vhd")] + -- execute the testbench and capture the results + tmpdir <- liftIO getTemporaryDirectory + (file, handle) <- liftIO $ openTempFile tmpdir "tb_out.txt" + -- we close the temporal file to avoid opening problems with vsim on windows + liftIO $ hClose handle + run_vsim ["-c", "-std_output", file, "-quiet", + "-do", "run " ++ show (cycles*10) ++ " ns; exit", + "work." ++ sysid ++ "_tb"] + handle2 <- liftIO $ openFile file ReadMode + flatOut <- liftIO $ hGetContents handle2 + -- go back to the original directory + liftIO $ setCurrentDirectory (".." "..") + parseTestBenchOut flatOut + +-- | Compile the generated VHDL code with Modelsim +-- (Note: the initial and final CWD will be /systemName/vhdl ) +compileResultsModelsim :: VHDLM () +compileResultsModelsim = do + -- Check if modelsim is installed + installed <- liftIO $ isModelsimInstalled + when (not installed) (throwFError ModelsimFailed) + -- get the name of the vhdl files to compile + sys <- gets (globalSysDef.global) + let sysId = sid sys + syslib = sysId ++ "_lib" + libFile = syslib (syslib ++ ".vhd") + workFiles = ("work" (sysId ++ ".vhd")) : + map (("work").(++".vhd").sid.readURef.unPrimSysDef) + (subSys sys) + -- get the modelsim directory of ForSyDe's vhdl library + -- (generated during installation) + dataPath <- liftIO $ getDataDir + + -- map the directory to the logical name forsyde + let modelsimForSyDe = dataPath "lib" "modelsim" + run_vmap ["forsyde", modelsimForSyDe] + + -- compile the library of current model + let modelsimLib = syslib "modelsim" + run_vlib [modelsimLib] + run_vcom ["-93", "-quiet", "-nologo", "-work", modelsimLib, libFile] + -- map the directory of the library to its logical name + run_vmap [syslib, modelsimLib] + + -- compile the work files + -- NOTE: Since vcom doesn't figure out + -- the compilation order (according to compoment dependencies), + -- we first compile the entities and then the architectures. + -- Another option would be keeping a dependency tree in SysDef + -- and execute vcom using a depth search (currently we keep + -- all the subsystems in a flatenned list) + let modelsimWork = "work" "modelsim" + run_vlib [modelsimWork] + run_vcom ("-93" : "-quiet" : "-nologo" : "-work" : modelsimWork : + "-just" : "e" : workFiles) + run_vcom ("-93" : "-quiet" : "-nologo" : "-work" : modelsimWork : + "-just" : "a" : workFiles) + -- map the directory work library to its logical name + run_vmap ["work", modelsimWork] + + + + +-- | Run vlib +run_vlib :: [String] -- ^ arguments + -> VHDLM () +run_vlib = runModelsimCommand "vlib" + +-- | Run vmap +run_vmap :: [String] -- ^ arguments + -> VHDLM () +run_vmap = runModelsimCommand "vmap" + + +-- | Run vmap +run_vcom :: [String] -- ^ arguments + -> VHDLM () +run_vcom = runModelsimCommand "vcom" + +-- | Run vsim +run_vsim :: [String] -- ^ arguments + -> VHDLM () +run_vsim = runModelsimCommand "vsim" + +-- | run a ModelSim command +runModelsimCommand :: String -- ^ Command to execute + -> [String] -- ^ Command arguments + -> VHDLM () +runModelsimCommand command args = do + success <- liftIO $ runWait msg command args + when (not success) (throwFError ModelsimFailed) + where msg = "Running: " ++ command ++ " " ++ (concat $ intersperse " " args) + + +-- | Run a process, previously announcing a message and waiting for it +-- to finnish its execution. +runWait :: String -- ^ message to show + -> FilePath -- ^ command to execute + -> [String] -- ^ command arguments + -> IO Bool -- ^ Did the execution end succesfully? +runWait msg proc args = do + putStrLn msg + h <- runProcess proc args Nothing Nothing Nothing Nothing Nothing + code <- waitForProcess h + return $ code == ExitSuccess + + +-- Look for modelsim executables +isModelsimInstalled :: IO Bool +isModelsimInstalled = executablePresent "vlib" <&&> + executablePresent "vmap" <&&> + executablePresent "vcom" <&&> + executablePresent "vsim" + where executablePresent = (liftM (maybe False (\_-> True))) .findExecutable + +-- | short-circuit and for monads +(<&&>) :: Monad m => m Bool -> m Bool -> m Bool +x <&&> y = do p <- x + if p then y else return False diff --git a/src/ForSyDe/Deep/Backend/VHDL/Ppr.hs b/src/ForSyDe/Deep/Backend/VHDL/Ppr.hs new file mode 100644 --- /dev/null +++ b/src/ForSyDe/Deep/Backend/VHDL/Ppr.hs @@ -0,0 +1,481 @@ +{-# LANGUAGE FlexibleInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : ForSyDe.Deep.Backend.VHDL.Ppr +-- Copyright : (c) ES Group, KTH/ICT/ES 2007-2013 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : forsyde-dev@ict.kth.se +-- Stability : experimental +-- Portability : non-portable (Template Haskell) +-- +-- VHDL pretty-printing instances. +-- +----------------------------------------------------------------------------- + + +-- FIXME: we could avoid the LANGUAGE extensions by adding ppr_list to the Ppr +-- class (see Language.Haskell.TH.Ppr) + +module ForSyDe.Deep.Backend.VHDL.Ppr () where + +import ForSyDe.Deep.Backend.Ppr + +import ForSyDe.Deep.Backend.VHDL.AST + +import Text.PrettyPrint.HughesPJ hiding (Mode) + + +-- | Number of spaces used for indentation +nestVal :: Int +nestVal = 5 + +instance Ppr a => Ppr (Maybe a) where + ppr (Just a) = ppr a + ppr Nothing = empty + +instance (Ppr a, Ppr b) => Ppr (a,b) where + ppr (a,b) = ppr a <+> ppr b + +instance Ppr VHDLId where + ppr = text.fromVHDLId + + +instance Ppr DesignFile where + ppr (DesignFile cx lx) = vNSpaces spaces (ppr_list ($+$) cx) + (ppr_list (vNSpaces spaces) lx) $+$ + vSpace + where spaces = 2 + + + +instance Ppr ContextItem where + ppr (Library id) = text "library" <+> ppr id <> semi + ppr (Use name) = text "use" <+> ppr name <> semi + + +instance Ppr LibraryUnit where + ppr (LUEntity entityDec) = ppr entityDec + ppr (LUArch archBody) = ppr archBody + ppr (LUPackageDec packageDec) = ppr packageDec + ppr (LUPackageBody packageBody) = ppr packageBody + +instance Ppr EntityDec where + ppr (EntityDec id ifaceSigDecs) = + text "entity" <+> idDoc <+> text "is" $+$ + nest nestVal (ppr ifaceSigDecs) $+$ + text "end entity" <+> idDoc <> semi + where idDoc = ppr id + +instance Ppr [IfaceSigDec] where +-- FIXME: improve pretty printing of the +-- declarations +-- This: +-- S1 : bit +-- Ssdds : bit +-- should really be printed as +-- S1 : bit +-- Ssdds : bit + ppr [] = empty + ppr decs = text "port" <+> (parens (ppr_list vSemi decs) <> semi) + + +instance Ppr IfaceSigDec where + ppr (IfaceSigDec id mode typemark) = + ppr id <+> colon <+> ppr mode <+> ppr typemark + + +instance Ppr Mode where + ppr In = text "in" + ppr Out = text "out" + +instance Ppr ArchBody where + ppr (ArchBody id enName decs conSms) = + text "architecture" <+> idDoc <+> text "of" <+> ppr enName <+> text "is" $+$ + nest nestVal (ppr decs) $+$ + text "begin" $+$ + nest nestVal (ppr_list (vNSpaces 1) conSms) $+$ + text "end architecture" <+> idDoc <> semi + where idDoc = ppr id + +instance Ppr PackageDec where + ppr (PackageDec id decs) = + text "package" <+> idDoc <+> text "is" $+$ + vSpace $++$ + nest nestVal (ppr_list (vNSpaces 1) decs) $++$ + vSpace $+$ + text "end package" <+> idDoc <> semi + where idDoc = ppr id + +instance Ppr PackageDecItem where + ppr (PDITD typeDec) = ppr typeDec + ppr (PDISD subtypeDec) = ppr subtypeDec + ppr (PDISS subProgSpec) = ppr subProgSpec <> semi + +instance Ppr PackageBody where + ppr (PackageBody _ []) = text "" -- skip empty body + ppr (PackageBody id decs) = + text "package body" <+> idDoc <+> text "is" $+$ + vSpace $++$ + nest nestVal (ppr_list (vNSpaces 1) decs) $++$ + vSpace $+$ + text "end package body" <+> idDoc <> semi + where idDoc = ppr id + +instance Ppr SubtypeDec where + ppr (SubtypeDec id si) = text "subtype" <+> ppr id <+> text "is" <+> ppr si <> semi + +instance Ppr SubtypeIn where + ppr (SubtypeIn tm mCons) = ppr tm <+> (ppr mCons) + + +instance Ppr Range where + ppr (AttribRange an) = ppr an + ppr (ToRange exp1 exp2) = ppr exp1 <+> text "to" <+> ppr exp2 + + +instance Ppr IndexConstraint where + ppr (IndexConstraint dr) = parens (ppr_list hComma dr) + + +instance Ppr TypeDec where + ppr (TypeDec id typeDef) = + hang (text "type" <+> ppr id <+> text "is") nestVal (ppr typeDef <> semi) + +instance Ppr TypeDef where + ppr (TDA arrayTD) = ppr arrayTD + ppr (TDR recordTD) = ppr recordTD + ppr (TDE enumTD) = ppr enumTD + +instance Ppr ArrayTypeDef where + ppr (UnconsArrayDef unconsIxs elemsTM) = + text "array" <+> parens (ppr_list hComma $ map pprUnconsRange unconsIxs) <+> + text "of" <+> ppr elemsTM + where pprUnconsRange tm = ppr tm <+> text "range <>" + + ppr (ConsArrayDef consIxs elemsTM) = + text "array" <+> ppr consIxs <+> text "of" <+> ppr elemsTM + +instance Ppr RecordTypeDef where + ppr (RecordTypeDef elementDecs) = + text "record" <+> (ppr_list ($+$) elementDecs) $+$ + text "end record" + +instance Ppr ElementDec where + ppr (ElementDec id tm) = ppr id <+> colon <+> ppr tm <> semi + +instance Ppr EnumTypeDef where + ppr (EnumTypeDef ids) = lparen <> ppr_list hComma ids <> rparen + +instance Ppr VHDLName where + ppr (NSimple simple) = ppr simple + ppr (NSelected selected) = ppr selected + ppr (NIndexed indexed) = ppr indexed + ppr (NSlice slice) = ppr slice + ppr (NAttribute attrib) = ppr attrib + +instance Ppr SelectedName where + ppr (prefix :.: suffix) = ppr prefix <> dot <> ppr suffix + +instance Ppr Suffix where + ppr (SSimple simpleName) = ppr simpleName + ppr All = text "all" + +instance Ppr IndexedName where + ppr (IndexedName prefix indexList) = + ppr prefix <> parens ( ppr_list hComma indexList ) + +instance Ppr SliceName where + ppr (SliceName prefix discreteRange) = ppr prefix <> parens (ppr discreteRange) + +instance Ppr AttribName where + ppr (AttribName prefix simpleName mExpr) = + ppr prefix <> char '\'' <> ppr simpleName <> parensNonEmpty (ppr mExpr) + +instance Ppr [BlockDecItem] where + ppr = ppr_list ($+$) + +instance Ppr BlockDecItem where + ppr (BDISPB subProgBody) = ppr subProgBody + ppr (BDISD sigDec) = ppr sigDec + + +instance Ppr SubProgBody where + ppr (SubProgBody subProgSpec decItems statements) = + ppr subProgSpec <+> text "is" $+$ + nest nestVal (ppr_list ($+$) decItems) $+$ + text "begin" $+$ + nest nestVal (ppr_list ($+$) statements) $+$ +-- TODO, show the id here + text "end" <> semi + + +instance Ppr SubProgDecItem where + ppr (SPVD vd) = ppr vd + ppr (SPSB sb) = ppr sb + +instance Ppr VarDec where + ppr (VarDec id st mExpr) = + text "variable" <+> ppr id <+> colon <+> ppr st <+> + (text ":=" <++> ppr mExpr) <> semi + +instance Ppr SubProgSpec where +-- FIXME: improve pretty printing of the +-- declarations +-- This: +-- (S1 : bit; +-- Ssdds : bit) +-- should really be printed as +-- (S1 : bit; +-- Ssdds : bit) + ppr (Function name decList returnType) = + text "function" <+> ppr name <+> (parensNonEmpty (ppr_decs decList) $+$ + text "return" <+> ppr returnType) + where ppr_decs ds = ppr_list vSemi ds + + + +instance Ppr IfaceVarDec where + ppr (IfaceVarDec id typemark) = ppr id <+> colon <+> ppr typemark + +instance Ppr SeqSm where + ppr (IfSm cond sms elseIfs maybeElse) = + text "if" <+> ppr cond <+> text "then" $+$ + nest nestVal (ppr sms) $+$ + ppr elseIfs $+$ + ppr maybeElse $+$ + text "end if" <> semi + ppr (CaseSm patern alts) = text "case" <+> ppr patern <+> text "is" $+$ + nest nestVal (ppr alts) $+$ + text "end case" <> semi + ppr (ReturnSm maybeExpr) = text "return" <+> ppr maybeExpr <> semi + ppr (ForSM id dr sms) = + text "for" <+> ppr id <+> text "in" <+> ppr dr <+> text "loop" $+$ + nest nestVal (ppr sms) $+$ + text "end loop" <> semi + ppr (target := orig) = ppr target <+> text ":=" <+> ppr orig <> semi + ppr (WaitFor expr) = text "wait for" <+> ppr expr <> semi + ppr (targ `SigAssign` orig) = ppr targ <+> text "<=" <+> ppr orig <> semi + ppr (ProcCall name assocs) = + ppr name <> parensNonEmpty (commaSep assocs) <> semi + +instance Ppr [SeqSm] where + ppr = ppr_list ($+$) + +instance Ppr [ElseIf] where + ppr = ppr_list ($+$) + +instance Ppr ElseIf where + ppr (ElseIf cond sms) = text "elseif" <+> ppr cond <+> text "then" $+$ + nest nestVal (ppr sms) + +instance Ppr Else where + ppr (Else sms) = text "else" $+$ + nest nestVal (ppr sms) + + +instance Ppr [CaseSmAlt] where + ppr = ppr_list ($+$) + +instance Ppr Choice where + ppr (ChoiceE expr) = ppr expr + ppr Others = text "others" + +instance Ppr CaseSmAlt where + ppr (CaseSmAlt alts sms) = + text "when" <+> ppr_list joinAlts alts <+> text "=>" $+$ + nest nestVal (ppr sms) + where joinAlts a1 a2 = a1 <+> char '|' <+> a2 + +instance Ppr SigDec where + ppr (SigDec id typemark mInit) = + text "signal" <+> ppr id <+> colon <+> ppr typemark <+> + (text ":=" <++> ppr mInit) <> semi + +instance Ppr [ConcSm] where + ppr = ppr_list ($$) + +instance Ppr ConcSm where + ppr (CSBSm blockSm) = ppr blockSm + ppr (CSSASm conSigAssignSm) = ppr conSigAssignSm + ppr (CSISm compInsSm) = ppr compInsSm + ppr (CSPSm procSm) = ppr procSm + +instance Ppr BlockSm where + ppr (BlockSm label ifaceSigDecs pMapAspect blockDecItems concSms) = + labelDoc <+> colon <+> text "block" $+$ + nest nestVal (ppr ifaceSigDecs) $+$ + nest nestVal (ppr pMapAspect) <> semi $+$ + nest nestVal (ppr blockDecItems) $+$ + text "begin" $+$ + nest nestVal (ppr concSms) $+$ + text "end block" <+> labelDoc <> semi + where labelDoc = ppr label + + +instance Ppr PMapAspect where + ppr (PMapAspect assocs) = text "port map" $$ + (nest identL $ parens (ppr_list vComma assocs)) + where identL = length "port map " + + +instance Ppr AssocElem where + ppr (formalPart :=>: actualPart) = formalPartDoc <+> ppr actualPart + where formalPartDoc = maybe empty (\fp -> ppr fp <+> text "=>") formalPart + +instance Ppr ActualDesig where + ppr (ADName name) = ppr name + ppr (ADExpr expr) = ppr expr + ppr Open = text "open" + +instance Ppr ConSigAssignSm where + ppr (target :<==: cWforms) = ppr target <+> text "<=" <+> (ppr cWforms <> semi) + + +instance Ppr ConWforms where + ppr (ConWforms whenElses wform lastElse) = ppr_list ($+$) whenElses $+$ + ppr wform <+> ppr lastElse + +instance Ppr WhenElse where + ppr (WhenElse wform expr) = ppr wform <+> text "when" <+> + ppr expr <+> text "else" + +instance Ppr When where + ppr (When cond) = text "when" <+> ppr cond + +instance Ppr Wform where + ppr (Wform elems) = ppr_list vComma elems + ppr Unaffected = text "unaffected" + +instance Ppr WformElem where + ppr (WformElem exp mAfter) = ppr exp <+> (text "after" <++> ppr mAfter) + + +instance Ppr CompInsSm where + ppr (CompInsSm label insUnit assocElems) = + ppr label <+> colon <+> (ppr insUnit $+$ + nest nestVal (ppr assocElems) <> semi) + +instance Ppr ProcSm where + ppr (ProcSm label sensl seqSms) = + ppr label <+> colon <+> text "process" <+> + parensNonEmpty (ppr_list hComma sensl) $+$ + text "begin" $+$ + nest nestVal (ppr seqSms) $+$ + text "end process" <+> labelDoc <> semi + where labelDoc = ppr label + +instance Ppr InsUnit where + ppr (IUEntity name) = text "entity" <+> ppr name + +-- FIXME, remove parenthesis according to precedence +instance Ppr Expr where + ppr = pprExprPrec 0 "" + + +-- | Prettyprint an binary infix operator +pprExprPrecInfix :: Int -- ^ Accumulated precedence value (initialized to 0) + -> String -- ^ Enclosing operator (initialized to \"\") + -> Int -- ^ Precedence of current infix operator + -> Expr -- ^ lhs expression + -> String -- ^ operator name + -> Expr -- ^ rhs expression + -> Doc +-- To avoid priting parenthesis based on the left +-- associativity of all operators within the same precedence class, +-- the precedence passed to the left branch is curr instead of +-- curr+1. +-- +-- However, the VHDL grammar sometimes doesn't allow it +-- e.g. "and a or b and d" is illegal. In fact, +-- you can only put two operators together without parenthesis +-- in some cases: +-- +-- * logical operators: "and", "or", "xor", "xnor", but cannot be mixed up. +-- * relational operators: none +-- * shift operators: none +-- * adding operators: all, can be mixed up +-- * multiplying operator: all, can be mixed up +-- * misc operator: none +-- +-- Thus, we keep track of the enclosing +-- operator, and skip parenthesis according to left parsing associativity +-- in the cases stated above. +-- +-- Note that we are only making use of syntactic associativity. e.g. +-- even if "+" is semantially associative: a+(b+c)=(a+b)+c, +-- we will only skip parenthesis in (a+b)+c + +pprExprPrecInfix ac encop curr lhs op rhs = + parensIf (ac>curr || (ac == curr && not skipParenSameLevel)) $ + sep [pprExprPrec curr op lhs <+> text op, pprExprPrec (curr+1) op rhs] + where skipParenSameLevel = curr == plusPrec || curr == multPrec || + (encop == op && op `elem` ["and","or","xor","xnor"]) + +-- | Prettyprint unary prefix operators +pprExprPrecPrefix :: Int -- ^ Accumulated precedence value (initialized to 0) + -> Int -- ^ Precedence of current infix operator + -> String -- ^ operator name + -> Expr -- ^ operator argument + -> Doc +pprExprPrecPrefix ac curr op arg = parensIf (ac>curr) $ + text op <+> pprExprPrec (curr+1) op arg + + +-- | Prints an expression taking precedence and left associativity +-- in account +pprExprPrec :: Int -- ^ Accumulated precedence value (initialized to 0) + -> String -- ^ Enclosing operator + -> Expr -- ^ Expression curently prettyprinted + -> Doc +-- Logical operations +pprExprPrec p e (And e1 e2) = pprExprPrecInfix p e logicalPrec e1 "and" e2 +pprExprPrec p e (Or e1 e2) = pprExprPrecInfix p e logicalPrec e1 "or" e2 +pprExprPrec p e (Xor e1 e2) = pprExprPrecInfix p e logicalPrec e1 "xor" e2 +pprExprPrec p e (Nand e1 e2) = pprExprPrecInfix p e logicalPrec e1 "nand" e2 +pprExprPrec p e (Nor e1 e2) = pprExprPrecInfix p e logicalPrec e1 "nor" e2 +pprExprPrec p e (Xnor e1 e2) = pprExprPrecInfix p e logicalPrec e1 "xnor" e2 +-- Relational Operators +pprExprPrec p e (e1 :=: e2) = pprExprPrecInfix p e relationalPrec e1 "=" e2 +pprExprPrec p e (e1 :/=: e2) = pprExprPrecInfix p e relationalPrec e1 "/=" e2 +pprExprPrec p e (e1 :<: e2) = pprExprPrecInfix p e relationalPrec e1 "<" e2 +pprExprPrec p e (e1 :<=: e2) = pprExprPrecInfix p e relationalPrec e1 "<=" e2 +pprExprPrec p e (e1 :>: e2) = pprExprPrecInfix p e relationalPrec e1 ">" e2 +pprExprPrec p e (e1 :>=: e2) = pprExprPrecInfix p e relationalPrec e1 ">=" e2 +-- Shift Operators +pprExprPrec p e (Sll e1 e2) = pprExprPrecInfix p e shiftPrec e1 "sll" e2 +pprExprPrec p e (Srl e1 e2) = pprExprPrecInfix p e shiftPrec e1 "srl" e2 +pprExprPrec p e (Sla e1 e2) = pprExprPrecInfix p e shiftPrec e1 "sla" e2 +pprExprPrec p e (Sra e1 e2) = pprExprPrecInfix p e shiftPrec e1 "sra" e2 +pprExprPrec p e (Rol e1 e2) = pprExprPrecInfix p e shiftPrec e1 "rol" e2 +pprExprPrec p e (Ror e1 e2) = pprExprPrecInfix p e shiftPrec e1 "ror" e2 +-- Adding Operators +pprExprPrec p e (e1 :+: e2) = pprExprPrecInfix p e plusPrec e1 "+" e2 +pprExprPrec p e (e1 :-: e2) = pprExprPrecInfix p e plusPrec e1 "-" e2 +pprExprPrec p e (e1 :&: e2) = pprExprPrecInfix p e plusPrec e1 "&" e2 +-- Sign Operators +pprExprPrec p _ (Neg e) = pprExprPrecPrefix p signPrec "-" e +pprExprPrec p _ (Pos e) = pprExprPrecPrefix p signPrec "+" e +-- Multiplying Operators +pprExprPrec p e (e1 :*: e2) = pprExprPrecInfix p e multPrec e1 "*" e2 +pprExprPrec p e (e1 :/: e2) = pprExprPrecInfix p e multPrec e1 "/" e2 +pprExprPrec p e (Mod e1 e2) = pprExprPrecInfix p e multPrec e1 "mod" e2 +pprExprPrec p e (Rem e1 e2) = pprExprPrecInfix p e multPrec e1 "rem" e2 +-- Miscellaneous Operators +pprExprPrec p e (e1 :**: e2) = pprExprPrecInfix p e miscPrec e1 "**" e2 +pprExprPrec p _ (Abs e) = pprExprPrecPrefix p signPrec "abs" e +pprExprPrec p _ (Not e) = pprExprPrecPrefix p signPrec "not" e +-- Primary expressions +pprExprPrec _ _ (PrimName name) = ppr name +pprExprPrec _ _ (PrimLit lit) = text lit +pprExprPrec _ _ (PrimFCall fCall) = ppr fCall +-- Composite-type expressions +pprExprPrec _ _ (Aggregate assocs) = parens (ppr_list hComma assocs) + +instance Ppr ElemAssoc where + ppr (ElemAssoc mChoice expr) = (ppr mChoice <++> text "=>") <+> ppr expr + +instance Ppr FCall where + ppr (FCall name assocs) = + ppr name <> parensNonEmpty (commaSep assocs) + diff --git a/src/ForSyDe/Deep/Backend/VHDL/Quartus.hs b/src/ForSyDe/Deep/Backend/VHDL/Quartus.hs new file mode 100644 --- /dev/null +++ b/src/ForSyDe/Deep/Backend/VHDL/Quartus.hs @@ -0,0 +1,115 @@ +----------------------------------------------------------------------------- +-- | +-- Module : ForSyDe.Deep.Backend.VHDL.Quartus +-- Copyright : (c) ES Group, KTH/ICT/ES 2007-2013 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : forsyde-dev@ict.kth.se +-- Stability : experimental +-- Portability : portable +-- +-- Functions to process the VHDL compilation results with Altera's Quartus II +-- software. +----------------------------------------------------------------------------- +module ForSyDe.Deep.Backend.VHDL.Quartus + (callQuartus) where + +import ForSyDe.Deep.ForSyDeErr +import ForSyDe.Deep.Config (getDataDir) +import ForSyDe.Deep.OSharing (readURef) +import ForSyDe.Deep.System.SysDef (subSys,sid,unPrimSysDef) + +import ForSyDe.Deep.Backend.VHDL.Traverse.VHDLM + +import System.IO +import System.Directory +import System.Process +import Control.Monad.State +import System.Exit (ExitCode(..)) + + + +-- | Analyze the results with Quartus +-- (Note: the initial and final CWD will be /systemName/vhdl ) +callQuartus :: VHDLM () +callQuartus = do + mQuartus <- gets (execQuartus.ops.global) + -- is it necessary to call quartus? + case mQuartus of + Nothing -> return () + -- Yes, we create the tcl script and call quartus_sh checking if it + -- exists in the system + Just ops -> do + mPath <- liftIO $ findExecutable "quartus_sh" + case mPath of + Nothing -> do liftIO $ hPutStrLn stderr "Error: quartus_sh not found" + throwFError QuartusFailed + Just _ -> do contents <- gen_quartus_tcl ops + liftIO $ writeFile "quartus.tcl" contents + liftIO $ putStrLn "Running quartus_sh -t quartus.tcl" + code <- liftIO $ waitForProcess =<< runCommand + "quartus_sh -t quartus.tcl" + case code of + ExitFailure _ -> throwFError QuartusFailed + _ -> return () + +-- | Generate the content of quartus.tcl +-- Note that, even in windows, the tcl interpreter requires pathnames +-- to use \"/\" instead of \"\\\" +gen_quartus_tcl :: QuartusOps -> VHDLM String +gen_quartus_tcl (QuartusOps act mFMax mFamDev assigs) = do + sysName <- gets (sid.globalSysDef.global) + dataPath <- liftIO $ getDataDir + recursive <- isRecursiveSet + subs <- gets (subSys.globalSysDef.global) + let libDir = (changeSlashes dataPath) ++ "/lib" + sysLib = sysName ++ "_lib" + return $ unlines ( + packages ++ + [projectNew sysName] ++ + mDefault mFMax fmax ++ + mDefault mFamDev famDev ++ + map mkAssig assigs ++ + [topLevelEntity sysName, + includeVHDLFile ("work/" ++ sysName ++ ".vhd") Nothing, + includeVHDLFile ('"' : (libDir ++ "/forsyde.vhd") ++ "\"") (Just "forsyde"), + includeVHDLFile (sysLib ++ "/" ++ sysLib ++ ".vhd") (Just sysLib)] ++ + (if recursive then + map (\s -> includeVHDLFile + ((("work/"++).(++".vhd").sid.readURef.unPrimSysDef) s) + Nothing) subs + else []) ++ + [actionCmd act] + ) + where mDefault m f = maybe [] f m + actionCmd act = case act of + AnalysisAndElaboration -> + "execute_flow -analysis_and_elaboration" + AnalysisAndSynthesis -> + "execute_module -tool map" + FullCompilation -> + "execute_flow -compile" + fmax max = ["set_global_assignment -name FMAX_REQUIREMENT \"" ++ + show max ++ " MHz\""] + famDev (fam, mDev) = + ["set_global_assignment -name FAMILY " ++ show fam] ++ + case mDev of + Nothing -> [] + Just dev -> ["set_global_assignment -name DEVICE " ++ show dev] + mkAssig (vhdlPin, fpgaPin) = "set_location_assignment " ++ + fpgaPin ++ " -to " ++ vhdlPin + packages = ["load_package project", "load_package flow"] + includeVHDLFile :: FilePath -- ^ system name + -> Maybe String -- ^ what library to include the + -- file in + -> String + includeVHDLFile file mLib = + "set_global_assignment -name VHDL_FILE " ++ file ++ + maybe "" (" -library "++) mLib + topLevelEntity name = + "set_global_assignment -name TOP_LEVEL_ENTITY " ++ name + projectNew name = "project_new " ++ name ++ " -overwrite" + changeSlashes [] = [] + changeSlashes ('\\':xs) = '/' : changeSlashes xs + changeSlashes (x:xs) = x : changeSlashes xs + diff --git a/src/ForSyDe/Deep/Backend/VHDL/TestBench.hs b/src/ForSyDe/Deep/Backend/VHDL/TestBench.hs new file mode 100644 --- /dev/null +++ b/src/ForSyDe/Deep/Backend/VHDL/TestBench.hs @@ -0,0 +1,220 @@ +----------------------------------------------------------------------------- +-- | +-- Module : ForSyDe.Deep.Backend.VHDL.TestBench +-- Copyright : (c) ES Group, KTH/ICT/ES 2007-2013 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : forsyde-dev@ict.kth.se +-- Stability : experimental +-- Portability : portable +-- +-- Functions used to generate a VHDL test bech. +-- +----------------------------------------------------------------------------- +module ForSyDe.Deep.Backend.VHDL.TestBench + (writeVHDLTestBench, + parseTestBenchOut) where + + +import ForSyDe.Deep.Backend.VHDL.Constants +import ForSyDe.Deep.Backend.VHDL.AST +import ForSyDe.Deep.Backend.VHDL.Translate +import ForSyDe.Deep.Backend.VHDL.Traverse.VHDLM +import ForSyDe.Deep.Backend.VHDL.Generate +import ForSyDe.Deep.Backend.VHDL.FileIO + +import ForSyDe.Deep.Ids +import ForSyDe.Deep.System.SysDef + +import qualified Language.Haskell.TH as TH (Exp) +import Control.Monad.State +import Data.List (transpose) +import System.Directory +import System.FilePath + + +-- | Parse the output of the testbench (a tab separated files) +-- into strings denoting the individual output signals +parseTestBenchOut :: String -- ^ String containing the complete output file + -> VHDLM [[String]] -- ^ output signal values in form + -- of strings +parseTestBenchOut str = do + outN <- gets (length.oIface.globalSysDef.global) + case tabSeparatedRows of + [] -> return (replicate outN []) + _ -> return $ transpose tabSeparatedRows + where tabSeparatedRows = ((map (unintersperse '\t')).lines) str + unintersperse _ [] = [] + unintersperse e (c:cs) + -- the null check makes unintersperse imposible to define with foldr + -- or unfoldr + | c == e = if null cs then [[],[]] + else [] : unintersperse e cs + | otherwise = let rest = unintersperse e cs in + case rest of + [] -> [[c]] + (a:as) -> (c:a):as + +-- | write a test bench, using a clock cycle of 10 ns +-- (Note: the initial and final CWD will be / ) +writeVHDLTestBench :: Maybe Int -- ^ Number of cycles to simulate + -- if 'Nothing' the number will be determined + -- by the length of the input stimulti. + -- Useful when the system to simulate doesn't + -- have inputs or the inputs provided are + -- infinite + -> [[TH.Exp]] -- ^ Input stimuli (one list per signal) + -> VHDLM Int -- ^ Number of cycles simulated +writeVHDLTestBench mCycles stimuli = do + sys <- gets (globalSysDef.global) + let sysId = sid sys + cxt = genVHDLTestBenchContext sysId + ent = genVHDLTestBenchEntity sysId + (arch, cycles) <- genVHDLTestBenchArch mCycles stimuli + let design = DesignFile cxt [LUEntity ent, LUArch arch] + tbdir = sysId "vhdl" "test" + tbpath = tbdir (sysId ++ "_tb.vhd") + liftIO $ createDirectoryIfMissing True tbdir + liftIO $ writeDesignFile design tbpath + return cycles + +-- | Generate the Context Clause +genVHDLTestBenchContext :: SysId -- ^ Main system Id + -> [ContextItem] +genVHDLTestBenchContext id = commonContextClause ++ + [Library libId, + Use $ NSelected (NSimple libId :.: SSimple typesId) :.: All, + Use $ NSelected (NSimple stdId :.: SSimple textioId) :.: All] + where libId = unsafeVHDLBasicId (id ++ "_lib") + +-- | Generates an empty entity fot the testbench +genVHDLTestBenchEntity :: SysId -- ^ Main system Id + -> EntityDec +genVHDLTestBenchEntity id = EntityDec (unsafeVHDLBasicId (id ++ "_tb")) [] + +-------------------------- +-- Test Bench Architecture +-------------------------- + + +-- | generate the architecture +genVHDLTestBenchArch :: Maybe Int -- ^ Maximum number of cycles + -> [[TH.Exp]] -- ^ Input stimuli + -> VHDLM (ArchBody, Int) -- ^ Number of cycles simulated +genVHDLTestBenchArch mCycles stimuli = do + sys <- gets (globalSysDef.global) + let sysId = sid sys + iface = iIface sys + oface = oIface sys + l = logic sys + iIds = map fst iface + iVHDLIds = map unsafeVHDLExtId iIds + oIds = map fst oface + -- Get the signal declarations for the input signals + iDecs <- mapM + (\(pId, t) -> transVHDLName2SigDec (unsafeVHDLExtId pId) t Nothing) iface + let finalIDecs = iDecs ++ + [SigDec clockId std_logicTM (Just $ PrimLit "'0'"), + SigDec resetId std_logicTM (Just $ PrimLit "'0'")] + -- Get the component instantiation and the signal declarations for the output + -- signals + (mIns, outDecs) <- + transSysIns2CompIns l + (unsafeVHDLBasicId "totest") + iVHDLIds + (map (\(id, t) -> (unsafeVHDLExtId id,t)) oface) + sysId + iIds + oIds + -- Generate the signal assignments + (stimuliAssigns, cycles) <- genStimuliAssigns mCycles stimuli iVHDLIds + -- Add an assignment to turn off the reset signal after 3 ns + -- (everything lower than 5 ns should work) + let finalAssigns = + (NSimple resetId :<==: + ConWforms [] + (Wform [WformElem (PrimLit "'1'") (Just $ PrimLit "3 ns")]) + Nothing) : stimuliAssigns + -- Get the two processes (clock and output) + clkProc = genClkProc + outputProc = genOutputProc (map unsafeVHDLExtId oIds) + -- return the architecture + return $ (ArchBody + (unsafeVHDLBasicId "test") + (NSimple $ unsafeVHDLBasicId (sysId ++ "_tb")) + (map BDISD (finalIDecs ++ outDecs)) + ( maybe [] (\s -> [CSISm s]) mIns ++ + ( (CSPSm clkProc) : (CSPSm outputProc) : (map CSSASm finalAssigns) ) ), + cycles) + +-- | generate the assignments for the input stimuli +genStimuliAssigns :: Maybe Int -- ^ Maximum number of cycles + -> [[TH.Exp]] -- ^ Input stimuli + -> [VHDLId] -- ^ Input signal ids + -> VHDLM ([ConSigAssignSm], Int) -- ^ (Assignments, + -- number of cycles + -- simulated) +-- if the number of input signas is zero +genStimuliAssigns mCycles [] _ = return ([], maybe 0 id mCycles) + +-- if the nu,ber of input signals is /= zero +genStimuliAssigns mCycles stimuli signals = do + let genWformElem time thExp = + do vExp <- transExp2VHDL thExp + return (WformElem vExp (Just $ PrimLit (show time ++ " ns"))) + wformElems <- mapM (zipWithM genWformElem ([0,10..] :: [Int])) stimuli + let (normWformElems, cycles) = normalize maxCycles wformElems + if cycles == 0 + then return ([],0) + else return + (zipWith + (\s elems -> NSimple s :<==: ConWforms [] (Wform elems) Nothing) + signals + normWformElems, + cycles) + where maxCycles = maybe (-1) id mCycles + -- FIXME: this is not efficient at all + -- Normalize a matrix. Make sure that all the rows in a matrix have the + -- same length, setting a maximum row length (0 establishes no limit) + normalize :: Int -- ^ maximum row-length to process + -> [[a]] -- ^ input matrix + -> ([[a]], Int) -- ^ (output matrix, maximum row length) + normalize max xss + | any null xss || max == 0 = (replicate l [], 0) + | otherwise = let (transres, acum) = normalize' max (transpose xss) + in (transpose transres, acum) + where l = length xss + normalize' max (xs:xss) + | length xs == l && max /= 0 = + let (nextlist, nextacum) = normalize' (max-1) xss + in (xs : nextlist, nextacum+1) + normalize' _ _ = ([], 0) + +-- | generates a clock process with a period of 10ns +genClkProc :: ProcSm +genClkProc = ProcSm (unsafeVHDLBasicId "clkproc") [] sms + where sms = -- wait for 5 ns -- (half a cycle) + [WaitFor $ PrimLit "5 ns", + -- clk <= not clk; + NSimple clockId `SigAssign` + Wform [WformElem (Not (PrimName $ NSimple clockId)) Nothing]] + +-- | generate the output process +genOutputProc :: [VHDLId] -- ^ output signals + -> ProcSm +genOutputProc outs = + ProcSm (unsafeVHDLBasicId "writeoutput") + [clockId] + [IfSm clkPred (writeOuts outs) [] Nothing] + where clkPred = PrimName (NAttribute $ AttribName (NSimple clockId) + eventId + Nothing ) `And` + (PrimName (NSimple clockId) :=: PrimLit "'1'") + writeOuts [] = [] + writeOuts [i] = [writeOut i (PrimLit "LF")] + writeOuts (i:is) = writeOut i (PrimLit "HT") : writeOuts is + writeOut outSig suffix = + genExprProcCall2 writeId + (PrimName $ NSimple outputId) + (genExprFCall1 showId (PrimName $ NSimple outSig) :&: + suffix) diff --git a/src/ForSyDe/Deep/Backend/VHDL/Translate.hs b/src/ForSyDe/Deep/Backend/VHDL/Translate.hs new file mode 100644 --- /dev/null +++ b/src/ForSyDe/Deep/Backend/VHDL/Translate.hs @@ -0,0 +1,921 @@ +{-# LANGUAGE TemplateHaskell, TypeOperators #-} +----------------------------------------------------------------------------- +-- | +-- Module : ForSyDe.Deep.Backend.VHDL.Traverse +-- Copyright : (c) ES Group, KTH/ICT/ES 2007-2013 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : forsyde-dev@ict.kth.se +-- Stability : experimental +-- Portability : portable +-- +-- Functions to translate elements of the intermediate system +-- representation to elements of the VHDL AST. +----------------------------------------------------------------------------- +module ForSyDe.Deep.Backend.VHDL.Translate where + +import ForSyDe.Deep.Backend.VHDL.AST +import qualified ForSyDe.Deep.Backend.VHDL.AST as VHDL +import ForSyDe.Deep.Backend.VHDL.Constants +import ForSyDe.Deep.Backend.VHDL.Generate +import ForSyDe.Deep.Backend.VHDL.Traverse.VHDLM +import ForSyDe.Deep.Backend.VHDL.Translate.HigherOrderFunctions + +import ForSyDe.Deep.Ids +import ForSyDe.Deep.AbsentExt +import ForSyDe.Deep.Signal +import ForSyDe.Deep.Bit hiding (not) +import ForSyDe.Deep.ForSyDeErr +import ForSyDe.Deep.System.SysDef +import ForSyDe.Deep.Process.ProcFun +import ForSyDe.Deep.Process.ProcVal +import ForSyDe.Deep.Process.ProcType + +import Data.Data (tyconUQname) +import Data.Int +import Data.Char (digitToInt) +import Data.List (intersperse) +import Data.Maybe (isJust, fromJust) +import Control.Monad.State +import qualified Data.Set as S +import qualified Language.Haskell.TH as TH +import Language.Haskell.TH hiding (global,Loc) +import qualified Data.Traversable as DT +import Data.Typeable +import Data.Typeable.Internal +import qualified Data.Param.FSVec as V +import Text.Regex.Posix ((=~)) + +import Data.TypeLevel.Num.Reps +import Data.Typeable.FSDTypeRepLib + +-- enable tracing of type translation + +-- import Debug.Trace +debug :: a -> String -> a +-- debug = flip trace +debug a _ = a + + +-- | Translate a System Definition to an Entity, explicitly returning +-- the VHDL identifiers of its output signals. +transSysDef2Ent :: SysLogic -- ^ logic of the system + -> SysDefVal -- ^ system to translate + -> VHDLM EntityDec +transSysDef2Ent logic sysDefVal = do + entId <- transSysId2VHDL (sid sysDefVal) + inDecs <- mapM (uncurry $ transPort2IfaceSigDec In) (iIface sysDefVal) + outDecs <- mapM (uncurry $ transPort2IfaceSigDec Out) (oIface sysDefVal) + -- clock and reset implicit declarations + let implicitDecs = if logic == Sequential then + [IfaceSigDec resetId In std_logicTM, + IfaceSigDec clockId In std_logicTM] + else [] + return $ EntityDec entId (implicitDecs ++ inDecs ++ outDecs) + +-- | Translate a 'ZipwithNSY' process to a block returning a declaration of +-- the resulting signal. +transZipWithN2Block :: Label -- ^ process identifier + -> [VHDLId] -- ^ input signals + -> Loc -- ^ location of the inner function + -> TypedProcFunAST -- ^ AST of the inner function + -> VHDLId -- ^ output signal + -> VHDLM (BlockSm, SigDec) +transZipWithN2Block vPid ins loc ast out = do + -- Translate the process function + (f,fName , inFPars, inFTypes, retFType) <- + withProcFunC ((name.tpast) ast) loc $ transProcFun2VHDL ast + -- Generate the formal parameters of the block + let inPars = map (\n -> unsafeIdAppend vPid ("_in" ++ show n)) [1..length ins] + outPar = unsafeIdAppend vPid "_out" + -- Generate the port interface of the block + inDecs = zipWith (\par typ -> IfaceSigDec par In typ) inPars inFTypes + outDec = IfaceSigDec outPar Out retFType + iface = inDecs ++ [outDec] + -- Generate the port map + pMap = genPMap (inPars ++ [outPar]) (ins ++ [out]) + -- Generate the function call and signal assignment + outAssign = genFCallAssign out fName inFPars ins + return (BlockSm vPid iface pMap [BDISPB f] [CSSASm outAssign], + SigDec out retFType Nothing) + + +-- | Translate a 'ZipwithxSY' process to a block returning a declaration of +-- the resulting signal. +transZipWithx2Block :: Label -- ^ process identifier + -> [VHDLId] -- ^ input signals + -> Loc -- ^ location of the inner function + -> TypedProcFunAST -- ^ AST of the inner function + -> VHDLId -- ^ output signal + -> VHDLM (BlockSm, SigDec) +transZipWithx2Block vPid ins loc ast out = do + -- Translate the process function + (f, fName, [inFPar], [inFType], retFType) <- + withProcFunC ((name.tpast) ast) loc $ transProcFun2VHDL ast + -- Figure out the type of the inputs from the + -- function's input vector type (horrible hack, but it works) + let [[_,suffix]] = (fromVHDLId inFType) =~ "^fsvec_[0-9]*_(.*)$" + inType = unsafeVHDLBasicId $ suffix + -- Generate the formal parameters of the block + inPars = map (\n -> unsafeIdAppend vPid ("_in" ++ show n)) [1..length ins] + outPar = unsafeIdAppend vPid "_out" + -- Generate the port interface of the block + inDecs = map (\par -> IfaceSigDec par In inType) inPars + outDec = IfaceSigDec outPar Out retFType + iface = inDecs ++ [outDec] + -- Generate the port map + pMap = genPMap (inPars ++ [outPar]) (ins ++ [out]) + -- Generate the function call and signal assignment + aggregate = Aggregate $ + map (\e -> ElemAssoc Nothing (PrimName(NSimple e))) inPars + fCall = PrimFCall $ FCall (NSimple fName) + [Just inFPar :=>: ADExpr aggregate] + outAssign = genExprAssign outPar fCall + return (BlockSm vPid iface pMap [BDISPB f] [CSSASm outAssign], + SigDec out retFType Nothing) + +-- | Translate a 'UnzipNSY' process to a block returning a declaration of +-- the resulting signal. +transUnzipNSY2Block :: Label -- ^ process identifier + -> VHDLId -- ^ input signal + -> [VHDLId] -- ^ output signals + -> [FSDTypeRep] -- ^ output signal types + -> VHDLM (BlockSm, [SigDec]) +transUnzipNSY2Block vPid inSig outSigs outTRTypes = do + -- Generate the formal parameters of the block + let inPar = unsafeIdAppend vPid "_in" + outPars = map (\n -> unsafeIdAppend vPid ("_out" ++ show n)) + [1..length outSigs] + -- Generate the port interface of the block + nOuts = length outSigs + inTRType = (fsdTupleTyCon nOuts) `fsdTyConApp` outTRTypes + outTMTypes <- mapM transTR2TM outTRTypes + inTMType <- transTR2TM inTRType + let inDec = IfaceSigDec inPar In inTMType + outDecs = zipWith (\par typ -> IfaceSigDec par Out typ) outPars outTMTypes + iface = inDec : outDecs + -- Generate the port map + pMap = genPMap (inPar : outPars) (inSig : outSigs) + -- Generate the signal assignments + genOrigExp n = (PrimName $ NSelected + (NSimple inPar :.: tupVHDLSuffix n)) + genOutAssign outSig n = CSSASm $ genExprAssign outSig (genOrigExp n) + outAssigns = zipWith genOutAssign outPars [(1::Int)..] + return (BlockSm vPid iface pMap [] outAssigns, + zipWith (\sig typ -> SigDec sig typ Nothing) outSigs outTMTypes) + + + +-- | Translate a 'UnzipxSY' process to a block returning a declaration of +-- the resulting signal. +transUnzipxSY2Block :: Label -- ^ process identifier + -> VHDLId -- ^ input signal + -> [VHDLId] -- ^ output signals + -> FSDTypeRep -- ^ type of vector elements + -> Int -- ^ vector Size + -> VHDLM (BlockSm, [SigDec]) +transUnzipxSY2Block vPid inSig outSigs elemTR vSize = do + -- Generate the formal parameters of the block + let inPar = unsafeIdAppend vPid "_in" + outPars = map (\n -> unsafeIdAppend vPid ("_out" ++ show n)) + [1..length outSigs] + -- Generate the port interface of the block + inTRType = fSVecTyCon `fsdTyConApp` [transInt2TLNat vSize, elemTR] + inTMType <- transTR2TM inTRType + elemTM <- transTR2TM elemTR + let inDec = IfaceSigDec inPar In inTMType + outDecs = map (\par -> IfaceSigDec par Out elemTM) outPars + iface = inDec : outDecs + -- Generate the port map + pMap = genPMap (inPar : outPars) (inSig : outSigs) + -- Generate the signal assignments + genOrigExp n = + PrimName $ NIndexed (NSimple inPar `IndexedName` [PrimLit $ show n]) + genOutAssign outSig n = CSSASm $ genExprAssign outSig (genOrigExp n) + outAssigns = zipWith genOutAssign outPars [(0::Int)..] + return (BlockSm vPid iface pMap [] outAssigns, + map (\sig -> SigDec sig elemTM Nothing) outSigs) + + + + +-- | Translate a 'DelaySY' process to a block returning a declaration of +-- the resulting signal. +transDelay2Block :: Label -- ^ process identifier + -> VHDLId -- ^ input signal + -> ProcValAST -- ^ AST of the initial value + -- of the delay process + -> VHDLId -- ^ output signal + -> VHDLM (BlockSm, SigDec) +transDelay2Block vPid inS (ProcValAST exp tr enums) outS = do + -- Add the enumerated types associated with the value to the global results + addEnumTypes enums + -- Get the type of the initial value + initTR <- transTR2TM tr + -- Translate the initial value + initExp <- withProcValC exp $ withInitFunTransST $ (transExp2VHDL exp) + -- Build the block + let formalIn = unsafeIdAppend vPid "_in" + formalOut = unsafeIdAppend vPid "_out" + iface = [IfaceSigDec resetId In std_logicTM, + IfaceSigDec clockId In std_logicTM, + IfaceSigDec formalIn In initTR, + IfaceSigDec formalOut Out initTR] + assocs = [Just resetId :=>: ADName (NSimple resetId), + Just clockId :=>: ADName (NSimple clockId), + Just formalIn :=>: ADName (NSimple inS), + Just formalOut :=>: ADName (NSimple outS)] + sigAssign = CSSASm (NSimple formalOut :<==: + (ConWforms [whenElseReset] inWform (Just whenRE))) + whenElseReset = WhenElse (Wform [WformElem initExp Nothing]) + (PrimName (NSimple resetId) :=: PrimLit "'0'") + inWform = Wform [WformElem (PrimName $ NSimple formalIn) Nothing] + whenRE = When (PrimFCall $ FCall (NSimple $ unsafeVHDLBasicId "rising_edge") + [Nothing :=>: ADName (NSimple clockId) ]) + return (BlockSm vPid iface (PMapAspect assocs) [] [sigAssign], + SigDec outS initTR Nothing) + +-- | Translate a System instance into a VHDL component instantion +-- returning the declartion of the output signals +transSysIns2CompIns :: SysLogic -- ^ parent system logic + -> Label -- ^ instance identifier + -> [VHDLId] -- ^ input signals + -> [(VHDLId, FSDTypeRep)] -- ^ output signals + -> SysId -- ^ parent system identifier + -> [PortId] -- ^ parent input identifiers + -> [PortId] -- ^ parent output identifiers + -> VHDLM (Maybe CompInsSm, [SigDec]) +transSysIns2CompIns logic vPid ins typedOuts parentId parentInIds parentOutIds = do + if length ins == 0 && length typedOuts == 0 + then return (Nothing, []) + else do + -- Create the declarations for the signals + decs <- mapM (\(name,typ) -> transVHDLName2SigDec name typ Nothing) typedOuts + -- Create the portmap + vParentId <- transSysId2VHDL parentId + vParentInIds <- liftEProne $ mapM mkVHDLExtId parentInIds + vParentOutIds <- liftEProne $ mapM mkVHDLExtId parentOutIds + let implicitAssocIds = if logic == Sequential then [resetId, clockId] else [] + assocs = genAssocElems + (implicitAssocIds ++ vParentInIds ++ vParentOutIds) + (implicitAssocIds ++ ins ++ map fst typedOuts) + entityName = NSelected (NSimple workId :.: SSimple vParentId) + instantiation = CompInsSm vPid (IUEntity entityName) (PMapAspect assocs) + return (Just instantiation, decs) + + +-- | Translate a VHDL Signal to a VHDL Signal declaration +transVHDLName2SigDec :: SimpleName -- ^ Signal name + -> FSDTypeRep -- ^ Type of the intermediate signal + -> Maybe TH.Exp -- ^ Maybe an initializer expression for the signal + -> VHDLM SigDec +transVHDLName2SigDec vId tr mExp = do + tm <- transTR2TM tr + mVExp <- DT.mapM (\e -> withInitFunTransST (transExp2VHDL e)) mExp + return $ SigDec vId tm mVExp + + + +------------------------- +-- Identifier translation +------------------------- + + +-- | Translate a VHDL identifier and a type to an interface signal declaration +transVHDLId2IfaceSigDec :: Mode -> VHDLId -> FSDTypeRep -> VHDLM IfaceSigDec +transVHDLId2IfaceSigDec m vid trep = do + tm <- transTR2TM trep + return $ IfaceSigDec vid m tm + + +-- | Translate a Port to a VHDL Interface signal declaration +transPort2IfaceSigDec :: Mode -> PortId -> FSDTypeRep -> VHDLM IfaceSigDec +transPort2IfaceSigDec m pid trep = do + sid <- transPortId2VHDL pid + transVHDLId2IfaceSigDec m sid trep + +-- | Translate a local TH name to a VHDL Identifier +transTHName2VHDL :: TH.Name -> VHDLM VHDLId +-- we use pprint becase it shows unique names for local names +-- e.g. let x = 1 in let x =2 in x is printed as +-- let x_0 = 1 in let x_1 = 2 in x_1 +-- we want unique names because it saves us from dealing wiht +-- name scopes and having a global name table. +transTHName2VHDL = transPortId2VHDL . tyconUQname . pprint + +-- | Translate a system identifier to a VHDL identifier +transSysId2VHDL :: SysId -> VHDLM VHDLId +transSysId2VHDL = transPortId2VHDL + +-- | Translate a process identifier to a VHDL identifier +transProcId2VHDL :: ProcId -> VHDLM VHDLId +transProcId2VHDL = transPortId2VHDL + +-- | translate a port identifier to a VHDL Identifier +transPortId2VHDL :: PortId -> VHDLM VHDLId +transPortId2VHDL str = liftEProne $ mkVHDLExtId str + + +------------------- +-- Type translation +------------------- + + +-- | translate a 'TypeRep' to a VHDL 'TypeMark' +-- We don't distinguish between a type and its version nested in 'Signal' +-- since it makes no difference in VHDL +transTR2TM :: FSDTypeRep -> VHDLM TypeMark +transTR2TM rep + -- Is it a Signal? + | isSignal = transTR2TM nestedTR `debug` (dbgStr "S") + -- Is it a primitive type? + | isJust mPrimitiveTM = return $ fromJust mPrimitiveTM `debug` (dbgStr "P") + -- Non-Primitive type, try to translate it + | otherwise = customTR2TM rep `debug` (dbgStr "T") + where (isSignal, nestedTR) = let (tc,~[tr]) = fsdSplitTyConApp rep + in (tc == signalTyCon, tr) + signalTyCon = fsdTyConOf (undefined :: Signal ()) + mPrimitiveTM = lookup rep primTypeTable + dbgStr k = ">>>>" ++ k ++ " " ++ (typeRepQName rep) ++ "/" ++ (show rep) + + +-- | Translate a custom 'TypeRep' to a VHDL 'TypeMark' +customTR2TM :: FSDTypeRep -> VHDLM TypeMark +customTR2TM rep = do + -- Check if it was previously translated + mTranslated <- lookupCustomType rep + case mTranslated of + -- Not translated previously + Nothing -> do + -- translate it + e <- doCustomTR2TM rep + -- update the translation table and the accumulated type declarations + addCustomType rep e + -- return the translation + case e of + Left (TypeDec id _) -> return id + Right (SubtypeDec id _) -> return id + -- Translated previously + Just tm -> return tm `debug` "'--> (cache hit)" + +-- | Really do the translation (customTR2TM deals with caching) +doCustomTR2TM :: FSDTypeRep -> VHDLM (Either TypeDec SubtypeDec) + +-- | FSVec? +-- FSVecs are translated to subtypes of unconstrained vectors. +-- All FSVec operations are translated as operations for the +-- unconstrained type. +doCustomTR2TM rep | isFSVec = do + -- Translate the type of the elements contained in the vector + valTM <- transTR2TM valueType + -- Build the unconstrained vector identifier + let vectorId = unsafeVHDLContainerId [valTM] ("fsvec_"++ fromVHDLId valTM) + -- Obtain the unconstrained vector together with its functions and add them + -- to the global traversing-results (if this wasn't previously done): + -- * Check if the unconstrained array was previously translated + vecs <- gets (transUnconsFSVecs.global) + -- * if it wasn't ... + when (not $ elem valueType vecs) `debug` (" vectors: " ++ (show vecs)) $ do + -- create the unconstrained vector type and add it to the global + -- results. _Only_ if we are not working with "FSVec _ Bit" becuase + -- "type fsvec_std_logic" is already included in forsyde.vhd. + when (valueType /= (fsdTy $ typeOf (undefined :: Bit))) + ((addTypeDec $ TypeDec vectorId (TDA (UnconsArrayDef [fsvec_indexTM] valTM))) `debug` "allegiedly not FSVec _ Bit") + -- Add the default functions for the unconstrained + -- vector type to the global results + let funs = genUnconsVectorFuns valTM vectorId + mapM_ addSubProgBody funs + -- Mark the unconstrained array as translated + addUnconsFSVec $ valueType + + -- Create the vector subtype identifier + let subvectorId = unsafeVHDLBasicId ("fsvec_" ++ show size ++ "_" ++ + fromVHDLId valTM) + -- Create the vector subtype declaration + return $ Right $ + SubtypeDec subvectorId (SubtypeIn vectorId + (Just $ IndexConstraint [ToRange (PrimLit "0") + (PrimLit (show $ size-1))])) + where (cons, ~[sizeType,valueType]) = fsdSplitTyConApp rep + isFSVec = cons == fSVecTyCon + size = transTLNat2Int sizeType + + +-- | Tuple? +doCustomTR2TM rep | isTuple = do + -- Create the elements of the record + fieldTMs <- mapM transTR2TM args + let elems = zipWith (\fieldId fieldTM -> ElementDec fieldId fieldTM ) + [tupVHDLIdSuffix n | n <- [1..]] fieldTMs + -- Create the Type Declaration identifier + recordId = unsafeVHDLContainerId fieldTMs $ + (tupStrSuffix $ length fieldTMs) ++ "_" ++ + (concatMap fromVHDLId.intersperse (unsafeVHDLBasicId "_")) fieldTMs + -- Add the default functions for the tuple type to the global results + funs = genTupleFuns fieldTMs recordId + mapM_ addSubProgBody funs + -- Create the record + return $ Left $ (TypeDec recordId (TDR $ RecordTypeDef elems)) + where (cons, args) = fsdSplitTyConApp rep + conStr = fsdTyConName cons + isTuple = (length conStr > 2) && (all (==',') (reverse.tail.reverse.tail $ conStr)) + + +-- | AbstExt? +doCustomTR2TM rep | isAbsExt = do + -- Create the elements of the record + valueTM <- transTR2TM valueTR + let elems = [ElementDec isPresentId booleanTM, + ElementDec valueId valueTM ] + + -- Create the Type Declaration identifier + recordId = unsafeVHDLContainerId [valueTM] $ + "abs_ext_" ++ fromVHDLId valueTM + -- Add the default functions for the vector type to the global results + funs = genAbstExtFuns valueTM recordId + mapM_ addSubProgBody funs + -- Return the resulting the record + return $ Left $ (TypeDec recordId (TDR $ RecordTypeDef elems)) + where (cons, ~[valueTR]) = fsdSplitTyConApp rep + absExtTyCon = fsdTyConOf (undefined :: AbstExt ()) + isAbsExt = cons == absExtTyCon + +-- | Finally, it is an Enumerated algebraic type +-- or an unkown custom type (in that case we throw an error) +-- +-- NOTE: It would be cleaner to have a different clauses for each case but +-- since we need to access the state to check if it's an enumerated +-- algebraic type, we cannot do it. +doCustomTR2TM rep = do + -- Get the accumulated Enumerated Algebraic Types + eTys <- gets (enumTypes.global) + -- Check if current Type representation can be found in eTys + let strRep = typeRepQName rep + let equalsRep (EnumAlgTy name _) = name == strRep + case (S.toList.(S.filter equalsRep)) eTys of + -- Found! + [enumDef] -> liftM Left $ enumAlg2TypeDec enumDef `debug` (">>>>? "++strRep) + -- Not found, unkown custom type + _ -> throwFError $ UnsupportedType rep + +-- | Transform an enumerated Algebraic type to a VHDL +-- TypeMark adding its default function to the global results +enumAlg2TypeDec :: EnumAlgTy -- ^ Enumerated type definition + -> VHDLM TypeDec +enumAlg2TypeDec (EnumAlgTy tn cons) = do + -- Get the TypeMark + tMark <- liftEProne $ mkVHDLExtId tn + -- Get the enumeration literals + enumLits@(firstLit:_) <- liftEProne $ mapM mkVHDLExtId cons + -- Add the default functions for the enumeration type + let funs = genEnumAlgFuns tMark firstLit + mapM_ addSubProgBody funs + -- Create the enumeration type + return (TypeDec tMark (TDE $ EnumTypeDef enumLits)) + +-- | Translation table for primitive types +primTypeTable :: [(FSDTypeRep, TypeMark)] +primTypeTable = [-- Commented out due to representation overflow + -- (typeOf (undefined :: Int64), int64TM) , + (fsdTypeOf (undefined :: Int32), int32TM) , + (fsdTypeOf (undefined :: Int16), int16TM) , + (fsdTypeOf (undefined :: Int8) , int8TM) , + (fsdTypeOf (undefined :: Bool) , booleanTM) , + (fsdTypeOf (undefined :: Bit) , std_logicTM)] + +--------------------------------------- +-- Translating functions and expresions +--------------------------------------- + +------------------------ +-- Translating functions +------------------------ + + +-- | Throw a function error +funErr :: VHDLFunErr -> VHDLM a +funErr err = throwFError $ UntranslatableVHDLFun err + +-- | Translate a typed function AST to VHDL +transProcFun2VHDL :: TypedProcFunAST -- ^ input ast + -> VHDLM (SubProgBody, VHDLId, [VHDLId], [TypeMark], TypeMark) + -- ^ Function, Function name, name of inputs, type of inputs, return type +transProcFun2VHDL (TypedProcFunAST fType fEnums fAST) = do + -- Add the enumerated types associated with the function to the global results + addEnumTypes fEnums + -- Check if the procFunAST fullfils the restrictions of the VHDL Backend + -- FIXME: translate the default arguments + (fName, fInputPats, fBodyExp, whereDecs) <- checkProcFunAST fAST + -- Get the function spec and initialize the translation namespace + (fSpec, fVHDLName, fVHDLPars, argsTM, retTM) <- + transProcFunSpec fName fType fInputPats + -- Translate the where declarations and them to the + -- auxiliary declarations of the function + transDecs whereDecs + -- Translate the function's body + putCurrentFunctionSpec fSpec + bodySms <- transFunBodyExp2VHDL fBodyExp + decs <- gets (auxDecs.funTransST.local) + let fBody = SubProgBody fSpec decs bodySms + return (fBody, fVHDLName, fVHDLPars, argsTM, retTM) + +-- | Translate a typed function AST to VHDL (only returning the functions body +transProcFun2VHDLBody :: TypedProcFunAST -> VHDLM SubProgBody +transProcFun2VHDLBody tpf = do + (body, _, _, _, _) <- transProcFun2VHDL tpf + return body + +-- | Translate a list of declarations to a list of process function +-- ASTs +decs2ProcFuns :: [Dec] -> VHDLM [TypedProcFunAST] +decs2ProcFuns [] = return [] +decs2ProcFuns decs = do + (dec, t, name, clauses, restDecs) <- case decs of + -- A type signature followed by its function declaration + SigD n1 t : f@(FunD n2 cls) : xs | n1 == n2 -> + return (f, t, n1, cls, xs) + -- A type signature followed by its value declaration + -- which will be translated to a function + SigD n1 t : v@(ValD (VarP n2) bdy ds) : xs | n1 == n2 -> do + return (v, t, n1, [Clause [] bdy ds] , xs) + -- Otherwise the provided declaration block is not supported + _ -> funErr $ UnsupportedDecBlock decs + t' <- maybe (funErr $ PolyDec dec) return (type2FSDTypeRep t) + let tpf = TypedProcFunAST t' S.empty (ProcFunAST name clauses []) + restTPFs <- decs2ProcFuns restDecs + return $ tpf:restTPFs + +-- | Tranlate a list of declarations and add them to the auxiliary +-- declarations in the function translation state +transDecs :: [Dec] -> VHDLM () +transDecs decs = do + -- Before anything, clear the previous declaration blocks + -- FIXME: this shouldn't be here + clearAux + -- first we tranlsate the declarations to process functions + tpfs <- decs2ProcFuns decs + -- Before translating the process functions we add their names to the + -- name translation table. It is important to note that, since + -- Template Haskell makes local names unique (e.g. [| let x = 1 in + -- let x = 2 in x |] is tranlsated to let x_0 = 1 in let x_1 = 2 in x_2), + -- we don't have to take care of name scopes i.e. we can have a global name + -- scope. + mapM_ addDecName tpfs + -- Translate the declarations to VHDL and add them + -- to the auxiliary declarations of the function translation + bodyDecs <- mapM (liftM SPSB . transProcFun2VHDLBody) tpfs + addDecsToFunTransST bodyDecs + where addDecName :: TypedProcFunAST -> VHDLM () + addDecName (TypedProcFunAST t _ (ProcFunAST n _ _)) = do + let arity = (length.fst.fsdUnArrowT) t + vhdlId <- transTHName2VHDL n + addTransNamePair n arity (genExprFCallN vhdlId arity) + clearAux = do + lState <- gets local + let s = funTransST lState + modify (\st -> st{local=lState{funTransST=s{auxDecs=[]}}}) + +-- | Check if a process function AST fulfils the VHDL backend restrictions. +-- It returs the function TH-name its input paterns, its body expression, +-- and the list of theclarations in the where construct. +checkProcFunAST :: ProcFunAST + -> VHDLM (Name, [Pat], Exp, [Dec]) +-- FIXME: translate the default arguments! +checkProcFunAST (ProcFunAST thName [Clause pats (NormalB exp) decs] []) = + return (thName, pats, exp, decs) +checkProcFunAST (ProcFunAST _ _ (_:_)) = + intError "ForSyDe.Backend.VHDL.Translate.checkProcFunSpec" + (UntranslatableVHDLFun $ GeneralErr (Other "default parameters are not yet supported")) +checkProcFunAST (ProcFunAST _ [Clause _ bdy@(GuardedB _) _] _) = + funErr (FunGuardedBody bdy) +checkProcFunAST (ProcFunAST _ clauses@(_:_) _) = + funErr (MultipleClauses clauses) +-- cannot happen +checkProcFunAST (ProcFunAST _ [] _) = + -- FIXME, use a custom error + intError "ForSyDe.Backend.VHDL.Translate.checkProcFunSpec" + (UntranslatableVHDLFun $ GeneralErr (Other "inconsistentency")) + + + +-- | Get the spec of a VHDL function from the Haskell function name, its type +-- and its input patterns. This function also takes care of initalizing the +-- translation namespace. +transProcFunSpec :: TH.Name -- ^ Function name + -> FSDTypeRep -- ^ Function type + -> [Pat] -- ^ input patterns + -> VHDLM (SubProgSpec, VHDLId, [VHDLId], [TypeMark], TypeMark) +-- ^ translated function spec, function name, inpt parameters, input types +-- and return types +transProcFunSpec fName fType fPats = do + -- FIXME: translate the default arguments! + -- Get the input and output types + let (argsTR, retTR) = fsdUnArrowT fType + -- Check that the number of patterns equal the function parameter number + expectedN = length argsTR `debug` ("expected (args): "++ (show (length argsTR))) + actualN = length fPats `debug` ("actual (patterns): "++ (show (length fPats))) + when (expectedN /= actualN) (funErr $ InsParamNum fName actualN) + -- Get a VHDL identifier for each input pattern and + -- initialize the translation namespace + fVHDLParIds <- mapM transInputPat2VHDLId fPats + -- Translate the function name + fVHDLName <- transTHName2VHDL fName + -- Translate the types + argsTM <- mapM transTR2TM argsTR + retTM <- transTR2TM retTR + -- Create the spec + let iface = zipWith (\name typ -> IfaceVarDec name typ) fVHDLParIds argsTM + fSpec = Function fVHDLName iface retTM + -- Finally, return the results + return (fSpec, fVHDLName, fVHDLParIds, argsTM, retTM) + +-- | Translate an input pattern to a VHDLID, +-- making the necessary changes in the translation namespace +transInputPat2VHDLId :: TH.Pat -> VHDLM VHDLId +transInputPat2VHDLId pat = do + -- Get the parameter identifier + id <- case pat of + -- if we get a variable or and @ patterm, we just translate it to VHDL + VarP name -> transTHName2VHDL name + AsP name _ -> transTHName2VHDL name + -- otherwise, generate a fresh identifier + _ -> genFreshVHDLId + + -- Prepare the namespace for the pattern + preparePatNameSpace (NSimple id) pat + -- Finally return the generated id + return id + + +-- | prepare the translation namespace for an input pattern +preparePatNameSpace :: Prefix -- ^ name prefix obtained so far + -> Pat -- ^ pattern + -> VHDLM () +-- NOTE: a good alternative to adding selected names to the +-- translation table would be declaring a variable +-- assignment. It would probably make the generated code more +-- readable but at the same time, it requires knowing the +-- pattern type, and TH's AST is unfortunately not +-- type-annotated which would make things more difficult. + +-- variable pattern +preparePatNameSpace prefix (VarP name) = + addTransNamePair name 0 (\[] -> PrimName prefix) + +-- '@' pattern +preparePatNameSpace prefix (AsP name pat) = do + addTransNamePair name 0 (\[] -> PrimName prefix) + preparePatNameSpace prefix pat + +-- wildcard pattern +preparePatNameSpace _ WildP = return () + +-- tuple pattern +preparePatNameSpace prefix (TupP pats) = do + let prepTup n pat = preparePatNameSpace + (NSelected (prefix :.: tupVHDLSuffix n)) pat + zipWithM_ prepTup [1..] pats + +-- AbstExt patterns + +-- Since we only support one clause per function +-- they are not really useful, but we accept them anyways +-- FIXME: true, they are not useful, but again, since we only support one +-- clause per function they denote a programming error. Should they +-- really be supported? +preparePatNameSpace prefix (ConP name ~[pat]) | isAbstExt name = + when isPrst (preparePatNameSpace (NSelected (prefix :.: valueSuffix)) pat) + where isAbstExt name = isPrst || name == 'Abst + isPrst = name == 'Prst + +-- Unary Constructor patterns +-- We try an enumerated type patterns +-- otherwise we throw an unknown constructor pattern error +preparePatNameSpace _ pat@(ConP name []) = do + mId <- getEnumConsId name + case mId of + -- it is an enumerated data constructor, however, since we only admit + -- one clause per function there is nothing to do about it + Just _ -> return () + -- it is an unknown data constructor + Nothing -> funErr $ UnsupportedFunPat pat + +-- otherwise the pattern is not supported +preparePatNameSpace _ pat = funErr $ UnsupportedFunPat pat + + + +-------------------------- +-- Translating expressions +-------------------------- + +-- | Throw an expression error +expErr :: Exp -> VHDLExpErr -> VHDLM a +expErr exp err = throwFError $ UntranslatableVHDLExp exp err + + +-- | Create the unique statement of a VHDL from a TH expression. +transFunBodyExp2VHDL :: TH.Exp -> VHDLM [SeqSm] +transFunBodyExp2VHDL (CondE condE thenE elseE) = + do condVHDLE <- transExp2VHDL condE + thenVHDLSm <- transFunBodyExp2VHDL thenE + elseVHDLSm <- transFunBodyExp2VHDL elseE + return [IfSm condVHDLE thenVHDLSm [] (Just $ Else elseVHDLSm)] +transFunBodyExp2VHDL caseE@(CaseE exp matches) = + do caseVHDLE <- transExp2VHDL exp + caseSmAlts <- mapM (transMatch2VHDLCaseSmAlt caseE) matches + return [CaseSm caseVHDLE caseSmAlts] +-- A higher order function needs to be treated specially +transFunBodyExp2VHDL e@(AppE _ _) + | isHigherOrderFunction e = translateHigherOrderFunctionBody e +-- In other case it is an expression returned directly +transFunBodyExp2VHDL e = + do vHDLe <- transExp2VHDL e + return [ReturnSm $ Just vHDLe] + +-- | Translate a case alternative from Haskell to VHDL +transMatch2VHDLCaseSmAlt :: TH.Exp -> TH.Match -> VHDLM CaseSmAlt +-- FIXME: the exp passed (which contains the full case expression for +-- error reporting purposes) should be part of the context once VHDLM +-- is reworked +transMatch2VHDLCaseSmAlt contextExp (Match pat (NormalB matchExp) decs) = + do transDecs decs + sm <- transFunBodyExp2VHDL matchExp + case pat of + -- FIXME: support pattern matching with tuples, AbsExt, + -- and enumerated types + WildP -> return $ CaseSmAlt [Others] sm + LitP lit -> do vHDLExp <- transExp2VHDL (LitE lit) + return $ CaseSmAlt [ChoiceE vHDLExp] sm + -- FIXME: check! this case introduces new names into scope + VarP name -> do vHDLExp <- transExp2VHDL (VarE name) + return $ CaseSmAlt [ChoiceE vHDLExp] sm + _ -> expErr contextExp $ UnsupportedCasePat pat +transMatch2VHDLCaseSmAlt contextExp (Match _ bdy@(GuardedB _) _) = + expErr contextExp $ CaseGuardedBody bdy + + +-- | Translate a Haskell expression to a VHDL expression +transExp2VHDL :: TH.Exp -> VHDLM VHDL.Expr + + +-- TypeLevel-package numerical constant aliases +transExp2VHDL (VarE name) | isTypeLevelAlias = do + let constant = nameBase name + ([baseSym], val) = splitAt 1 constant + basePrefix = case baseSym of + 'b' -> "2#" + 'o' -> "8#" + 'h' -> "16#" + 'd' -> "" + _ -> error "unexpected base symbol" + return (PrimLit $ basePrefix ++ val) + where isTypeLevelAlias = (show name =~ aliasPat) + aliasPat = "^Data\\.TypeLevel\\.Num\\.Aliases\\.(b[0-1]+|o[0-7]+|d[0-9]+|h[0-9A-F]+)$" + + + +-- A FSVec generated with Template Haskell +transExp2VHDL (VarE unsafeFSVecCoerce `AppE` _ `AppE` (ConE con `AppE` ListE exps)) + | show unsafeFSVecCoerce == "Data.Param.FSVec.unsafeFSVecCoerce" && + show con == "Data.Param.FSVec.FSVec" = do + vhdlExps <- mapM transExp2VHDL exps + return $ Aggregate (map (\e -> ElemAssoc Nothing e) vhdlExps) + + +-- Is it function/constructor application, a constant +-- or an unkown name. +transExp2VHDL e | isConsOrFun = + do -- get the symbol table (name translation table) + nameTable <- gets (nameTable.funTransST.local) + case lookup name nameTable of + -- found name + Just (arity, transF) -> + if arity /= numArgs + then expErr e $ CurryUnsupported arity numArgs + else do exps <- mapM transExp2VHDL args + return $ transF exps + -- Didn't find the name in the global table + Nothing -> do + -- Check if it is a user-defined enumerated data constructor + mId <- getEnumConsId name + case mId of + Just id -> return $ PrimName (NSimple id) + Nothing -> expErr e $ UnkownIdentifier name + where (f,args,numArgs) = unApp e + mName = getName f + name = fromJust mName + isConsOrFun = isJust mName + getName (VarE n) = Just n + getName (ConE n) = Just n + getName _ = Nothing + + + +-- Literals +transExp2VHDL (LitE (IntegerL integer)) = (return.transInteger2VHDL) integer +transExp2VHDL (LitE (IntPrimL integer)) = (return.transInteger2VHDL) integer + +-- Unsupported literal +transExp2VHDL lit@(LitE _) = expErr lit $ UnsupportedLiteral + +-- Infix expressions +transExp2VHDL (InfixE (Just argl) f@(VarE _) (Just argr)) = + transExp2VHDL $ f `AppE` argl `AppE` argr + +-- Sections (unsupported) +transExp2VHDL infixExp@(InfixE _ (VarE _) _) = expErr infixExp Section + +-- Tuples: e.g. (1,2) +transExp2VHDL (TupE exps) = do + vExps <- mapM transExp2VHDL exps + return $ Aggregate $ map (\expr -> ElemAssoc Nothing expr) vExps + +-- Let expressions +transExp2VHDL (LetE decs e) = do + transDecs decs + transExp2VHDL e + +-- Unsupported expressions +transExp2VHDL lamE@(LamE _ _) = expErr lamE LambdaAbstraction +transExp2VHDL condE@(CondE _ _ _) = expErr condE Conditional +transExp2VHDL caseE@(CaseE _ _) = expErr caseE Case +transExp2VHDL doE@(DoE _) = expErr doE Do +transExp2VHDL compE@(CompE _) = expErr compE ListComprehension +transExp2VHDL arithSeqE@(ArithSeqE _) = expErr arithSeqE ArithSeq +transExp2VHDL listE@(ListE _) = expErr listE List +transExp2VHDL sigE@(SigE _ _) = expErr sigE Signature +transExp2VHDL reConE@(RecConE _ _) = expErr reConE Record +transExp2VHDL recUpE@(RecUpdE _ _) = expErr recUpE Record + +-- The rest of expressions are not valid in practice and thus, not supported +-- (e.g. InfixE Nothing (RecConE _ _) _ +transExp2VHDL exp = expErr exp Unsupported + + +-- | Translate an integer to VHDL +transInteger2VHDL :: Integer -> Expr +transInteger2VHDL = PrimLit . show + + +-------------------- +-- Helper Functions +-------------------- + +-- Translate the TypeRep of a type-level natural (e.g: D1 :* D2) to a number +-- Make sure you don't supply an incorrect TypeRep or the function will break +transTLNat2Int :: FSDTypeRep -> Int +transTLNat2Int tr + -- Digit + -- FIXME: Could be made cleaner. It was like this before: + -- isDigit = (digitToInt.last.tyConName) cons + -- which was not able to take care of e.g. Data.TypeLevel.Num.Aliases.D10 + | isDigit = (read.reverse.takeWhile (/='D').reverse.fsdTyConName) cons + -- Connective + | otherwise = 10 * (transTLNat2Int prefix) + (transTLNat2Int lastDigit) + where (cons, args@(~[prefix, lastDigit])) = fsdSplitTyConApp tr + isDigit = null args + + +-- Tranlate an Int to the TypeRep of a type-level natural (e.g: D1 :* D2) +transInt2TLNat :: Int -> FSDTypeRep +transInt2TLNat n + | n < 0 = intError fName (Other "negative index") + | n < 10 = digit n + | otherwise = fsdTyConApp conTyCon [transInt2TLNat suffix, digit last] + where fName = "ForSyDe.Backend.VHDL.Translate.transInt2TLNat" + (suffix, last) = n `divMod` 10 + digit 0 = fsdTypeOf (undefined :: D0) + digit 1 = fsdTypeOf (undefined :: D1) + digit 2 = fsdTypeOf (undefined :: D2) + digit 3 = fsdTypeOf (undefined :: D3) + digit 4 = fsdTypeOf (undefined :: D4) + digit 5 = fsdTypeOf (undefined :: D5) + digit 6 = fsdTypeOf (undefined :: D6) + digit 7 = fsdTypeOf (undefined :: D7) + digit 8 = fsdTypeOf (undefined :: D8) + digit 9 = fsdTypeOf (undefined :: D9) + -- Just to hush the compiler warnings + digit _ = undefined + conTyCon = fsdTyConOf (undefined :: () :* ()) + +-- Type constructor of FSVec +fSVecTyCon :: FSDTypeCon +fSVecTyCon = fsdTyConOf (undefined :: V.FSVec () ()) + +-- unApply an expression and obtain the number of arguments found +unApp :: Exp -> (Exp, [Exp], Int) +unApp e = (first, rest, n) + where (first:rest, n) = unAppAc ([],0) e + unAppAc (xs,n) (f `AppE` arg) = unAppAc (arg:xs, n+1) f + unAppAc (xs,n) f = (f:xs,n) + + + +typeRepQName :: FSDTypeRep -> String +typeRepQName rep = mod ++ dot ++ name + where tr = fsdTyRep rep + tc = typeRepTyCon tr + mod = tyConModule tc + name = tyConName tc + dot = if mod=="" then "" else "." diff --git a/src/ForSyDe/Deep/Backend/VHDL/Translate/HigherOrderFunctions.hs b/src/ForSyDe/Deep/Backend/VHDL/Translate/HigherOrderFunctions.hs new file mode 100644 --- /dev/null +++ b/src/ForSyDe/Deep/Backend/VHDL/Translate/HigherOrderFunctions.hs @@ -0,0 +1,211 @@ +{-# LANGUAGE TemplateHaskell #-} + +module ForSyDe.Deep.Backend.VHDL.Translate.HigherOrderFunctions ( + isHigherOrderFunction, + translateHigherOrderFunctionBody + ) where + +import Language.Haskell.TH +import qualified Language.Haskell.TH as TH +import ForSyDe.Deep.Backend.VHDL.AST +import qualified ForSyDe.Deep.Backend.VHDL.AST as VHDL +import qualified Data.Param.FSVec as V + +import ForSyDe.Deep.Backend.VHDL.Traverse.VHDLM +import Data.Maybe (isJust) +import Data.Data (tyconUQname) +import Control.Monad (when) +import Control.Monad.State + + +isHigherOrderFunction :: TH.Exp -> Bool +isHigherOrderFunction = isJust.getHoF + +translateHigherOrderFunctionBody :: TH.Exp -> VHDLM [SeqSm] +translateHigherOrderFunctionBody exp = case getHoF exp of + (Just transF) -> transF exp + -- This should not happen (translation should be guarded by isHigherOrderFunction) + Nothing -> error $ "This is not a supported higher-order function: "++(show.ppr $ exp) + +type TrFun = TH.Exp -> VHDLM [VHDL.SeqSm] +-- ------------------------------------- +-- Name Table for higher order functions +-- ------------------------------------- + +getHoF :: TH.Exp -> Maybe TrFun +getHoF exp@(AppE _ _) = lookup (fname, nargs) hofNameTable + where + ((VarE fname), _, nargs) = unApp exp +getHoF _ = Nothing + + + +hofNameTable :: [((TH.Name, Arity), TrFun)] +hofNameTable = [(('V.foldl, 3), translateFold 'V.foldl "RANGE"), + (('V.foldr, 3), translateFold 'V.foldr "REVERSE_RANGE"), + (('V.map, 2), translateZipWith 'V.map 2), + (('V.zipWith, 3), translateZipWith 'V.zipWith 3), + (('V.zipWith3, 4), translateZipWith 'V.zipWith3 4)] + + +-- --------------------- +-- Translation functions +-- --------------------- + +translateFold :: TH.Name -> String -> TH.Exp -> VHDLM [VHDL.SeqSm] +translateFold selfName attributeName exp@((((VarE foldname) `AppE` (VarE fname)) `AppE` (VarE _)) `AppE` (VarE _)) | foldname == selfName = do + fnameId <- transTHName2VHDL fname + loopvarId <- genVHDLId "i" + stateId <- genVHDLId "state" + + --- Nat s => (a -> b -> a) -> a -> FSVec s b -> a + fSpec <- getCurrentFunctionSpec + let Function _ [IfaceVarDec initId stateType, + IfaceVarDec argId _] _ = fSpec + + assertNormalForm exp fSpec + + -- check whether this is a known operator + knownTranslation <- lookupName fname + let fCall = case knownTranslation of + Just (arity, genFCallExp) -> (\args -> genFCallExp (map PrimName args)) + Nothing -> (\args -> fnameId $: args) + + -- variable state : stateType + let vardecl = SPVD $ VarDec stateId (SubtypeIn stateType Nothing) Nothing + addDecsToFunTransST [vardecl] + + -- state := init + let initStmt = (NSimple stateId) := (PrimName . NSimple $ initId) + + -- for i in arg'range loop + -- state := f(state, arg(i)) + -- end loop + let rangeAttrib = unsafeVHDLBasicId attributeName + range = AttribRange $ AttribName (NSimple argId) rangeAttrib Nothing + body = [(NSimple stateId) := (fCall [NSimple stateId, argId!:loopvarId])] + forLoopStmt = ForSM loopvarId range body + + -- return state + let retStmt = ReturnSm . Just . PrimName . NSimple $ stateId + + return [initStmt, forLoopStmt, retStmt] +translateFold selfName _ e = error $ "Invalid application of "++(show selfName)++": got `"++(pprint e)++"` expected `"++(show selfName)++" f arg`" + + +translateZipWith :: TH.Name -> Int -> TH.Exp -> VHDLM [VHDL.SeqSm] +translateZipWith selfName selfArity exp | (hofName == selfName) && (nArgs == selfArity) = do + fnameV <- transTHName2VHDL fname + loopvar <- genVHDLId "i" + retnameV <- genVHDLId "ret" + + fSpec <- getCurrentFunctionSpec + let Function _ _ rettype = fSpec + + assertNormalForm exp fSpec + + -- check whether this is a known operator + knownTranslation <- lookupName fname + let fCall = case knownTranslation of + Just (arity, genFCallExp) -> (\args -> genFCallExp (map PrimName args)) + Nothing -> (\args -> fnameV $: args) + + argNames <- mapM (\(VarE argName) -> transTHName2VHDL argName) thArgs + + -- variable ret : rettype + let vardecl = SPVD $ VarDec retnameV (SubtypeIn rettype Nothing) Nothing + addDecsToFunTransST [vardecl] + + -- for i in arg'range loop + -- ret(i) := f(arg1(i), arg2(i), [...]) + -- end loop + let rangeAttrib = unsafeVHDLBasicId "RANGE" + range = AttribRange $ AttribName (NSimple retnameV) rangeAttrib Nothing + indexedArgLst = map (\name -> name!:loopvar) argNames + body = [(retnameV!:loopvar) := (fCall indexedArgLst)] + loopStmt = ForSM loopvar range body + -- return ret + let returnStmt = ReturnSm . Just . PrimName . NSimple $ retnameV + + return $ [loopStmt, returnStmt] + where + ((VarE hofName), (VarE fname):thArgs, nArgs) = unApp exp +translateZipWith selfName selfArity e = error $ "Invalid application of "++self++": got `"++exp++"` expected `"++self++" f "++args++"`" + where self = show selfName + exp = pprint e + args = unwords $ replicate selfArity "arg" + + +-- --------- +-- Utilities +-- --------- + +-- AST level indexing operator +(!:) :: VHDLId -> VHDLId -> VHDLName +(!:) name index = NIndexed $ IndexedName (NSimple name) [PrimName $ NSimple index] + +-- AST level function call operator +($:) :: VHDLId -> [VHDLName] -> VHDL.Expr +($:) fname args = PrimFCall $ FCall (NSimple fname) (map (\a -> Nothing :=>: (ADName a)) args) + +-- AST level sequential assignment operator +-- (:=) :: VHDLName -> VHDL.Expr -> VHDL.SeqSm +-- defined in ForSyDe.Deep.Backend.VHDL.AST + +-- AST level map-association operator +-- (:=>: :: Maybe SimpleName -> ActualDesig -> AssocElem +-- defined in ForSyDe.Deep.Backend.VHDL.AST + +-- unApply an expression and obtain the number of arguments found +unApp :: Exp -> (Exp, [Exp], Int) +unApp e = (first, rest, n) + where (first:rest, n) = unAppAc ([],0) e + unAppAc (xs,n) (f `AppE` arg) = unAppAc (arg:xs, n+1) f + unAppAc (xs,n) f = (f:xs,n) + +transTHName2VHDL :: TH.Name -> VHDLM VHDLId +transTHName2VHDL = liftEProne . mkVHDLExtId . tyconUQname . pprint + +lookupName :: Name -> VHDLM (Maybe (Arity, [VHDL.Expr] -> VHDL.Expr)) +lookupName name = do + nameTable <- gets (nameTable.funTransST.local) + return $ lookup name nameTable + + +-- Check whether the given function application and the given function +-- signature are in normal form. Raises an error when the normal form is +-- violated, otherwise simply returns (). +-- +-- The signature is derived from the outer definition, while the application +-- expression represents the body of the specialized function +-- Some specializations in normal form: +-- map_f v = map f v +-- foldl_f i v = foldl f i v +-- zipWith_f a b = zipWith f a b +-- +-- Normal form means, that apart from the higher order argument, the +-- argument lists agree. This means that all arguments are explicitly written +-- and the names of all arguments are the same. This ensures, that the types +-- within the signature can be relied upon for translation purposes. +-- Additionally, the application of the specialized function needs to be the +-- sole expresssion in the function body, which ensures that the return type of +-- the function is valid as well. +-- +-- Some specializations not in normal form: +-- map_f = map f +-- => incomplete argument list +-- foldl_f v i = foldl f i v +-- => order of arguments does not match +-- zipWith_f v = zipWith f v v +-- => duplicated argument +-- +assertNormalForm :: TH.Exp -> VHDL.SubProgSpec -> VHDLM () +assertNormalForm appl sig = do + let (_, _:args, _) = unApp appl + (Function _ argDecls _) = sig + + argNamesBody <- mapM (\(VarE name) -> transTHName2VHDL name) args + let argNamesSig = map (\(IfaceVarDec name _) -> name) argDecls + + when (argNamesBody /= argNamesSig) $ error ("Higher order function application is not in normal form: "++(pprint appl)++"\n The argument list must agree") + return () diff --git a/src/ForSyDe/Deep/Backend/VHDL/Traverse.hs b/src/ForSyDe/Deep/Backend/VHDL/Traverse.hs new file mode 100644 --- /dev/null +++ b/src/ForSyDe/Deep/Backend/VHDL/Traverse.hs @@ -0,0 +1,234 @@ +----------------------------------------------------------------------------- +-- | +-- Module : ForSyDe.Deep.Backend.VHDL.Traverse +-- Copyright : (c) ES Group, KTH/ICT/ES 2007-2013 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : forsyde-dev@ict.kth.se +-- Stability : experimental +-- Portability : portable +-- +-- This module provides specialized Netlist traversing functions aimed at +-- VHDL compilation. +----------------------------------------------------------------------------- +module ForSyDe.Deep.Backend.VHDL.Traverse + (writeVHDLM, + module ForSyDe.Deep.Backend.VHDL.Traverse.VHDLM) where + +import ForSyDe.Deep.Backend.VHDL.Traverse.VHDLM +import ForSyDe.Deep.Backend.VHDL.Translate +import ForSyDe.Deep.Backend.VHDL.Generate +import ForSyDe.Deep.Backend.VHDL.FileIO +import ForSyDe.Deep.Backend.VHDL.AST +import ForSyDe.Deep.Backend.VHDL.Quartus (callQuartus) +import ForSyDe.Deep.Backend.VHDL.Modelsim + +import ForSyDe.Deep.ForSyDeErr +import ForSyDe.Deep.System.SysDef +import ForSyDe.Deep.Process.ProcVal +import ForSyDe.Deep.Process.ProcFun +import ForSyDe.Deep.Netlist.Traverse +import ForSyDe.Deep.Netlist +import ForSyDe.Deep.OSharing + +import Control.Monad.State +import System.Directory +import System.FilePath +import Data.Maybe (fromJust, isJust) + +-- | Internal VHDL-Monad version of 'ForSyDe.Backend.writeVHDL' +-- (Note: the initial and final CWD will be / ) +writeVHDLM :: VHDLM () +writeVHDLM = do + -- create and change to systemName/vhdl/work + rootDir <- gets (sid.globalSysDef.global) + let workDir = rootDir "vhdl" "work" + liftIO $ createDirectoryIfMissing True workDir + liftIO $ setCurrentDirectory workDir + -- if we are in recursive mode, also write the local results + -- for the rest of the subsystems + rec <- isRecursiveSet + when rec $ do subs <- gets (subSys.globalSysDef.global) + let writeSub s = + withLocalST (initLocalST ((readURef.unPrimSysDef) s)) + writeLocalVHDLM + mapM_ writeSub subs + -- write the local results for the first-level entity + writeLocalVHDLM + -- create and change to systemName/vhdl/systemName_lib + -- (remember we are in workDir) + let libDir = ".." rootDir ++ "_lib" + liftIO $ createDirectoryIfMissing True libDir + liftIO $ setCurrentDirectory $ libDir + -- write the global results + writeGlobalVHDLM + -- change to systemName/vhdl + liftIO $ setCurrentDirectory ".." + -- call quartus if necessary + callQuartus + -- analyze with modelsim if necessary + compile <- isCompileModelsimSet + when compile compileResultsModelsim + -- go back to the original directory + liftIO $ setCurrentDirectory (".." "..") + +-- | Write the global traversing results (i.e. the library design file) +-- accumulated in the state of the monad +writeGlobalVHDLM :: VHDLM () +writeGlobalVHDLM = do + gSysId <- gets (sid.globalSysDef.global) + debugMsg $ "Generating global system library for `" ++ gSysId ++ "' ...\n" + globalRes <- gets (globalRes.global) + -- We can create the id unsafely because sysId was already checked in + -- transSysDef2Ent + let libName = gSysId ++ "_lib" + libDesignFile = genLibDesignFile globalRes + liftIO $ writeDesignFile libDesignFile (libName ++ ".vhd") + + +-- | Traverse the netlist and write the local results (i.e. system design files) +writeLocalVHDLM :: VHDLM () +writeLocalVHDLM = do + gSysDefVal <- gets (globalSysDef.global) + lSysDefVal <- gets (currSysDef.local) + let lSysDefId = sid lSysDefVal + debugMsg $ "Compiling system definition `" ++ lSysDefId ++ "' ...\n" + -- Obtain the netlist of the system definition + let nl = netlist lSysDefVal + -- Traverse the netlist, and get the traversing results + intOutsInfo <- traverseVHDLM nl + LocalTravResult decs stms <- gets (localRes.local) + let finalLogic = logic lSysDefVal + -- Obtain the entity declaration of the system and the VHDL identifiers + -- of the output signals. + entity@(EntityDec _ eIface) <- transSysDef2Ent finalLogic lSysDefVal + -- For each output signal, we need an assigment between its intermediate + -- signal and the final output signal declared in the entity interface. + let outIds = mapFilter (\(IfaceSigDec id _ _) -> id) + (\(IfaceSigDec _ m _) -> m == Out) eIface + outAssigns = genOutAssigns outIds intOutsInfo + finalRes = LocalTravResult decs (stms ++ outAssigns) + -- Finally, generate the design file + sysDesignFile = genSysDesignFile (sid gSysDefVal) entity finalRes + -- and write it to disk + liftIO $ writeDesignFile sysDesignFile (lSysDefId ++ ".vhd") + where mapFilter f p = foldr (\x ys -> if p x then (f x):ys else ys) [] + +-- | Traverse the netlist of a System Definition, +-- returning the (implicit) final traversing state and a list +-- containing the 'IntSignalInfo' of each output of the system +traverseVHDLM :: Netlist [] -> VHDLM [IntSignalInfo] +traverseVHDLM = traverseSEIO newVHDL defineVHDL + +-- | \'new\' traversing function for the VHDL backend +newVHDL :: NlNode NlSignal -> VHDLM [(NlNodeOut, IntSignalInfo)] +newVHDL node = case node of + -- FIXME: Skip the case, basing the generation of tags on + -- outTags + InPort id -> do vId <- transPortId2VHDL id + return [(InPortOut, vId)] + Proc pid proc -> withProcC pid $ do + -- Obtain the VHDL id of the process + vpid <- transProcId2VHDL pid + -- function to create an intermediate signal out of the process + -- identifier and a string suffix + let procSuffSignal sigSuffix = unsafeIdAppend vpid sigSuffix + -- Multiple output tags, add a numeric suffix specifying the output + multOutTags = + zipWith (\tag n -> (tag, procSuffSignal $ outSuffix ++ show n)) + (outTags node) [(1::Int)..] + case proc of + Const _ -> return [(ConstOut, procSuffSignal outSuffix)] + ZipWithNSY _ _ -> return [(ZipWithNSYOut, procSuffSignal outSuffix)] + ZipWithxSY _ _ -> return [(ZipWithxSYOut, procSuffSignal outSuffix)] + UnzipNSY _ _ _ -> return multOutTags + UnzipxSY _ _ _ _ -> return multOutTags + DelaySY _ _ -> return [(DelaySYOut, procSuffSignal outSuffix)] + SysIns _ _ -> + -- Note: Here we could use the name of the System outputs instead of + -- instanceid_out_n but ... that could cause + -- clashes with the oher signal names (we only check for the + -- of the uniqueness of all process ids within a system when + -- creating it). We could check for those clashes but it would be + -- ineffective and ilogical. + return multOutTags + where outSuffix = "_out" + +-- | \'define\' traversing function for the VHDL backend +defineVHDL :: [(NlNodeOut, IntSignalInfo)] + -> NlNode IntSignalInfo + -> VHDLM () +defineVHDL outs ins = do + case (outs,ins) of + (_, InPort _) -> return () + (outs, Proc pid proc) -> withProcC pid $ do + -- We can unsafely transform the pid to a VHDL identifier because + -- it was checked in newVHDL + let vPid = unsafeVHDLExtId pid + case (outs, proc) of + ([(ConstOut, intSig)], Const ProcVal{valAST=ast}) -> do + -- Generate a Signal declaration for the constant + let cons = expVal ast + dec <- withProcValC cons $ transVHDLName2SigDec + intSig (expTyp ast) (Just cons) + addSigDec dec + ([(ZipWithNSYOut, intOut)], ZipWithNSY f intIns) -> do + -- Translate the zipWithN process to a block + -- and get the declaration of its output signal + (block, dec) <- transZipWithN2Block vPid intIns (tpfloc f) (tast f) intOut + addStm $ CSBSm block + -- Generate a signal declaration for the resulting signal + addSigDec dec + ([(ZipWithxSYOut, intOut)], ZipWithxSY f intIns) -> do + -- Translate the zipWithx process to a block + -- and get the declaration of its output signal + (block, dec) <- transZipWithx2Block vPid intIns (tpfloc f) (tast f) intOut + addStm $ CSBSm block + -- Generate a signal declaration for the resulting signal + addSigDec dec + (intOuts, UnzipNSY outTypes _ intIn) -> do + -- Translate the zipWithNSY process to a block + -- and get the declaration of its output signal + (block, decs) <- transUnzipNSY2Block vPid intIn (map snd intOuts) outTypes + addStm $ CSBSm block + -- Generate a signal declaration for the resulting signals + mapM_ addSigDec decs + (intOuts, UnzipxSY typ size _ intIn) -> do + -- Translate the UnzipxSY process to a block + -- and get the declaration of its output signal + (block, decs) <- transUnzipxSY2Block vPid intIn (map snd intOuts) typ size + addStm $ CSBSm block + -- Generate a signal declaration for the resulting signals + mapM_ addSigDec decs + ([(DelaySYOut, intOut)], DelaySY initExp intIn) -> do + -- Translate the delay process to a block + -- and get the declaration of its output signal + (block, dec) <- transDelay2Block vPid intIn (valAST initExp) intOut + addStm $ CSBSm block + -- Generate a signal declaration for the resulting delayed signal + addSigDec dec + + (intOuts, SysIns pSys intIns) -> do + let parentSysRef = unPrimSysDef pSys + parentSysVal = readURef parentSysRef + parentLogic = logic parentSysVal + parentInIface = iIface parentSysVal + parentOutIface = oIface parentSysVal + typedOuts = zipWith (\(_, t) (_, int) -> (int,t)) parentOutIface + intOuts + parentId = sid parentSysVal + -- Translate the instance to a component instantiation + -- and get the declaration of the output signals + (mCompIns, decs) <- transSysIns2CompIns parentLogic + vPid + intIns + typedOuts + parentId + (map fst parentInIface) + (map fst parentOutIface) + when (isJust mCompIns) (addStm $ CSISm $ fromJust mCompIns) + -- Generate a signal declaration for each of the resulting signals + mapM_ addSigDec decs + +-- Othewise there is a problem of inconsisten tags + _ -> intError "ForSyDe.Backend.VHDL.Traverse.defineVHDL" InconsOutTag diff --git a/src/ForSyDe/Deep/Backend/VHDL/Traverse/VHDLM.hs b/src/ForSyDe/Deep/Backend/VHDL/Traverse/VHDLM.hs new file mode 100644 --- /dev/null +++ b/src/ForSyDe/Deep/Backend/VHDL/Traverse/VHDLM.hs @@ -0,0 +1,614 @@ +{-# LANGUAGE FlexibleContexts #-} +----------------------------------------------------------------------------- +-- | +-- Module : ForSyDe.Deep.Backend.VHDL.Traverse.VHDLM +-- Copyright : (c) ES Group, KTH/ICT/ES 2007-2013 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : forsyde-dev@ict.kth.se +-- Stability : experimental +-- Portability : portable +-- +-- 'VHDM' (VHDL Monad), related types and functions +-- +----------------------------------------------------------------------------- +module ForSyDe.Deep.Backend.VHDL.Traverse.VHDLM where + +import ForSyDe.Deep.Backend.VHDL.AST +import qualified ForSyDe.Deep.Backend.VHDL.AST as VHDL +import {-# SOURCE #-} ForSyDe.Deep.Backend.VHDL.GlobalNameTable (globalNameTable) + +import ForSyDe.Deep.Ids +import ForSyDe.Deep.ForSyDeErr +import ForSyDe.Deep.System.SysDef (SysDefVal(..)) +import ForSyDe.Deep.Netlist.Traverse (TravSEIO) +import ForSyDe.Deep.Process.ProcType (EnumAlgTy(..)) + +import Data.Data (tyconModule) +import Data.Maybe (fromJust) +import qualified Data.Set as S (filter) +import Data.Set (Set, union, empty, toList) +import Control.Monad.State +import Language.Haskell.TH (nameBase, nameModule, Name, Exp, Arity) +import qualified Language.Haskell.TH as TH +import Data.Typeable (TypeRep,typeRepTyCon,tyConName,tyConPackage,tyConModule) +import Data.Typeable.FSDTypeRepLib + +------------------------------------- +-- How does the VHDL Backend work? -- +------------------------------------- +-- FIXME: This documentation is a bit outated +-- All the types used in the the System Defintion are translated to VHDL +-- put into Package, the into a Design File and written to disk. +-- +-- The System Definition itself is translated to another VHDL Design File and +-- written to disk. +-- +-- This Design File will contain only two library units; +-- an Entity Declaration and an Architecture. +-- 1) The Entity Declaration can be obtained from the SysDef directly (without +-- traversing the netlist) +-- 2) The Architecture (or more specifically, its declarations and +-- the statements) is obtained from the netlist by traversing it. +-- +-- The state of the traversal is composed by +-- * list of type defintions translated during the traversal +-- * table of equivalence between Haskell types and the VHDL identifier +-- of its translated type (used to avoid translating the same type +-- multiple times) +-- * the list of declarations of the architecture +-- * the list of statements of the architecture +-- * a table of System Definition references, used to keep track of the +-- system definitions (corresponding to one or more instances in the +-- netlist) whose code was already generated. +-- +-- For each process (netlist node) found during the traversal: +-- * A signal declaration is generated for each output and added to +-- the list of architecture declarations. +-- * A VHDL block including the translation of the process is generated +-- and added to the list of architecture statements. +-- +-- In the special case of finding a System Instance +-- 1) a port map statement is generated and added to the list of +-- architecture statements. +-- 2) the System Definition table is used to check if the Design File of +-- the System Definition associated with the instance was written to +-- disk. +-- 3) if the the associated System Definition wasn't in the table +-- 1) generate and write to disk the corresponding Design File +-- 2) add the System Definition to the table + +------------- +-- FunTransST +------------- + +-- | Function translation state. State used during the translation of +-- ProcFuns to VHDL. +-- +-- This type provides the number of fresh names already generated, +-- a translation table from Template Haskell Names to VHDL Expressions +-- (a symbol table) and auxiliary VHDL declarations. +-- +-- It only makes sense in a process-function context. +data FunTransST = FunTransST + {freshNameCount :: Int, + nameTable :: [(Name, (Arity, [VHDL.Expr] -> VHDL.Expr ) )], + -- The table entries work as follows: + -- (Template Haskell Name (table key), + -- (Arity, function with which to construct the translated VHDL expression + -- given itsarguments already translated to VHDL + -- ) + auxDecs :: [SubProgDecItem], + -- Auxiliary VHDL declarations generated during the translation of + -- the ProcFun to be put in the declaration block of the translated VHDL + -- function. + currentFSpec :: Maybe VHDL.SubProgSpec} + -- The function signature currently being compiled + + +-- | Initial translation state for functions +initFunTransST :: FunTransST +initFunTransST = FunTransST 0 globalNameTable [] Nothing + +----------- +-- VHDLM -- +----------- + +-- | VHDL backend monad +type VHDLM a = TravSEIO VHDLTravST ContextErr a + +---------------- +-- VHDLTravST -- +---------------- + +-- | VHDL traversing State. (see 'ForSyDe.Netlist.Traverse.traverseSIO') +data VHDLTravST = VHDLTravST + {local :: LocalVHDLST, -- Local State (related to the system currently + -- compiled) + global :: GlobalVHDLST} -- Global state (related to all systems being + -- recursively compiled) + +data LocalVHDLST = LocalVHDLST + {currSysDef :: SysDefVal, -- System definition which is currently + -- being compiled + context :: Context, -- Error Context + funTransST :: FunTransST, -- Translation state for functions (ProcFuns) + -- It only makes sense + -- in a process-function context + localRes :: LocalTravResult} -- Result accumulated during the + -- traversal of current System Definition + -- netlist + + + + +-- | initialize the local state +initLocalST :: SysDefVal -> LocalVHDLST +initLocalST sysDefVal = + LocalVHDLST sysDefVal (SysDefC (sid sysDefVal) (loc sysDefVal)) + initFunTransST emptyLocalTravResult + +-- | Execute certain operation with a concrete local state. +-- The initial local state is restored after the operation is executed +withLocalST :: LocalVHDLST -> VHDLM a -> VHDLM a +withLocalST l' action = do + -- get the initial local state + st <- get + let l = local st + -- set the modified state + put st{local=l'} + -- execute the action + res <- action + -- restore the initial local state + st' <- get + put st'{local=l} + -- return the result + return res + +-- | Execute certain operation with the initial function translation state +-- The initial state is restored after the operation is executed +withInitFunTransST :: VHDLM a -> VHDLM a +withInitFunTransST action = do + -- get the initial name space + st <- get + let l = local st + ns = funTransST l + -- set the empty name space + put st{local=l{funTransST=initFunTransST}} + -- execute the action + res <- action + -- restore the initial name table + st' <- get + let l' = local st' + put st'{local=l'{funTransST=ns}} + -- return the result + return res + + + +data GlobalVHDLST = GlobalVHDLST + {globalSysDef :: SysDefVal, -- global system definition + -- (the first-level system being compiled) + ops :: VHDLOps, -- Compilation options + globalRes :: GlobalTravResult, -- Result accumulated during the + -- whole compilation + enumTypes :: Set EnumAlgTy, -- Set of the enumerated + -- algebraic types accumulated + -- by all ProcFuns and ProcVals + -- in the system + typeTable :: [(FSDTypeRep, TypeMark)], -- Type translation table + transUnconsFSVecs :: [FSDTypeRep]} -- Unconstrained FSVecs previously translated. + -- Each unconstrained FSVec is represented by + -- the 'TypeRep' of its elements + + +-- | Empty initial traversing state +initGlobalVHDLST :: SysDefVal -> GlobalVHDLST +initGlobalVHDLST sysDefVal = + GlobalVHDLST sysDefVal defaultVHDLOps emptyGlobalTravResult empty [] [] + +-- | Empty initial traversing state +initVHDLTravST :: SysDefVal -> VHDLTravST +initVHDLTravST sysDefVal = + VHDLTravST (initLocalST sysDefVal) (initGlobalVHDLST sysDefVal) + +------------- +-- TravResult +------------- + +-- | Local result accumulated during the traversal of a netlist +data LocalTravResult = LocalTravResult + {archDecs :: [BlockDecItem], -- generated architecture declarations + archSms :: [ConcSm] } -- generated architecture statements + + + +-- | empty local VHDL compilation result +emptyLocalTravResult :: LocalTravResult +emptyLocalTravResult = LocalTravResult [] [] + + +-- | Global Results accumulated throughout the whole compilation +data GlobalTravResult = GlobalTravResult + {typeDecs :: [TypeDec], -- Types translated during the traversal + subtypeDecs :: [SubtypeDec], -- Subtypes translated during the traversal + subProgBodies :: [SubProgBody] } -- Functions or procedures generated during + -- the traversal + + + +-- | empty global VHDL compilation result +emptyGlobalTravResult :: GlobalTravResult +emptyGlobalTravResult = GlobalTravResult [] [] [] + + +---------- +-- VHDLOps +---------- + +-- | VHDL Compilation options +data VHDLOps = VHDLOps {debugVHDL :: VHDLDebugLevel, -- ^ Debug mode + recursivityVHDL :: VHDLRecursivity, + execQuartus :: Maybe QuartusOps, -- ^ Analyze the generated code with Quartus + compileModelsim :: Bool -- ^ Compile the generated code with Modelsim + } + deriving (Eq, Show) + +-- | Debug level +data VHDLDebugLevel = VHDLNormal | VHDLVerbose + deriving (Eq, Ord, Show) + +-- | Print a message to stdout if in verbose mode +debugMsg :: String -> VHDLM () +debugMsg str = do + debugLevel <- gets (debugVHDL.ops.global) + when (debugLevel > VHDLNormal) + (liftIO $ putStr ("DEBUG: " ++ str)) + +-- | Recursivity, should the parent systems of system instances be compiled as +-- well? +data VHDLRecursivity = VHDLRecursive | VHDLNonRecursive + deriving (Eq, Show) + +------------- +-- QuartusOps +------------- + +-- Quartus options + +-- | Options passed to Quartus II by the VHDL Backend. Most of them are optional +-- and Quartus will use a default value. +-- +-- It contains: +-- +-- * What action to perform +-- +-- * Optinally, the minimum acceptable clock frequency (fMax) expressed in MHz +-- +-- * FPGA family and specific device model (both are independently optional). +-- +-- * Pin assignments, in the form (VHDL Pin, FPGA Pin). Note +-- that Quartus will automatically split composite VHDL ports +--- (arrays and records) in various pins with different logical names. +data QuartusOps = + QuartusOps {action :: QuartusAction, + fMax :: Maybe Int, + fpgaFamiliyDevice :: Maybe (String, Maybe String), + pinAssigs :: [(String,String)] } + deriving (Eq, Show) + +-- | Action to perform by Quartus +data QuartusAction = AnalysisAndElaboration -- ^ Analysis and eleboration flow + | AnalysisAndSynthesis -- ^ Call map executable + | FullCompilation -- ^ Compile flow + deriving (Eq, Show) + +-- | Options to check if the model is synthesizable, all options except +-- the action to take are set to default. +checkSynthesisQuartus :: QuartusOps +checkSynthesisQuartus = QuartusOps AnalysisAndSynthesis Nothing Nothing [] + + +-- | Check if we are in recursive mode +isRecursiveSet :: VHDLM Bool +isRecursiveSet = do + recOp <- gets (recursivityVHDL.ops.global) + return $ recOp == VHDLRecursive + +-- | Check if we want to compile the results with modelsim +isCompileModelsimSet :: VHDLM Bool +isCompileModelsimSet = gets (compileModelsim.ops.global) + +-- | Default traversing options +defaultVHDLOps :: VHDLOps +defaultVHDLOps = VHDLOps VHDLNormal VHDLRecursive Nothing False + + +-- | Set VHDL options inside the VHDL monad +setVHDLOps :: VHDLOps -> VHDLM () +setVHDLOps options = modify (\st -> st{global=(global st){ops=options}}) + + +------------------------------------- +-- Useful functions in the VHDL Monad +------------------------------------- + + +-- | Add a signal declaration to the 'LocalTravResult' in the State +addSigDec :: SigDec -> VHDLM () +addSigDec dec = modify addFun + -- FIXME: use a queue for the declarations + where addFun st = st{local=l{localRes=r{archDecs=ads ++ [BDISD dec]}}} + where l = local st + r = localRes l + ads = archDecs r + + +-- | Add a statement to the 'LocalTravResult' in the State +addStm :: ConcSm -> VHDLM () +addStm sm = modify addFun + -- FIXME: use a queue for the statements + where addFun st = st{local=l{localRes=r{archSms=aSms ++ [sm]}}} + where l = local st + r = localRes l + aSms = archSms r + + +-- | Find a previously translated custom type +lookupCustomType :: FSDTypeRep -> VHDLM (Maybe SimpleName) +lookupCustomType rep = do + transTable <- gets (typeTable.global) + let res = lookup rep transTable + return res + --when (res==Nothing) $ mapM_ (\(elem,_) -> liftIO $ putStrLn $ (tyConName.typeRepTyCon) elem ++ "," ++ (tyConModule.typeRepTyCon) elem ++ "," ++(tyConPackage.typeRepTyCon) elem) transTable + --when (res==Nothing) (liftIO $ putStrLn $ (tyConName.typeRepTyCon) rep ++ "," ++ (tyConModule.typeRepTyCon) rep ++ "," ++(tyConPackage.typeRepTyCon) rep ++ "\n") + --let gkey = typeRepKey rep + --mapM_ (\(elem,_) -> let key = typeRepKey elem in liftIO $ putStrLn $ show (gkey==key) ++ ".." ++(tyConPackage.typeRepTyCon) elem ++ ".." ++ (tyConModule.typeRepTyCon) elem ++ ".." ++(tyConName.typeRepTyCon) elem) transTable + + --liftIO$putStrLn$ "\n" ++ (tyConPackage.typeRepTyCon) rep ++ ".." ++ (tyConModule.typeRepTyCon) rep ++ ".." ++(tyConName.typeRepTyCon) rep + + --liftIO$putStrLn$show (lookup rep transTable) ++ "\n\n" + + --return $ lookup rep transTable + + +-- | Add enumerated types to the global state +addEnumTypes :: Set EnumAlgTy -> VHDLM () +addEnumTypes newETs = do + globalST <- gets global + let oldETs = enumTypes globalST + modify (\st -> st{global = globalST {enumTypes = oldETs `union` newETs}}) + +-- | Check if a Template haskell 'Name' corresponding to +-- a Enumerated-type data constructor is present in the enumerated +-- types accumulated in the global state and return the corresponding +-- VHDL identifier. +getEnumConsId :: Name -> VHDLM (Maybe VHDLId) +getEnumConsId consName = do + let consModule = (fromJust.nameModule) consName + consBase = nameBase consName + enums <- gets (enumTypes.global) + let matchesName (EnumAlgTy dataName enums) = + tyconModule dataName == consModule && elem consBase enums + case (toList.(S.filter matchesName)) enums of + [] -> return Nothing + [_] -> liftM Just (liftEProne $ mkVHDLExtId consBase) + -- _ -> this shouldn't happen since the enumerated types stored are unique + _ -> intError "ForSyDe.Backend.VHDL.Traverse.VHDLM.getEnum" + (UntranslatableVHDLFun $ GeneralErr (Other "pattern match inconsistency")) + + +-- | Add a cutom type to the global results and type translation table +addCustomType :: FSDTypeRep -> Either TypeDec SubtypeDec -> VHDLM () +addCustomType rep eTD = do + globalST <- gets global + let transTable = typeTable globalST + gRes = globalRes globalST + tDecs = typeDecs gRes + stDecs = subtypeDecs gRes + -- FIXME: use queues + modify (\st -> st{global = + case eTD of + Left td@(TypeDec id _) -> + if id `notElem` (map snd transTable) then + globalST + {typeTable = transTable ++ [(rep, id)], + globalRes = gRes{typeDecs = tDecs ++ [td]}} + else globalST + Right std@(SubtypeDec id _) -> + if id `notElem` (map snd transTable) then + globalST + {typeTable = transTable ++ [(rep, id)], + globalRes = gRes{subtypeDecs = stDecs ++ [std]}} + else globalST + }) + +-- | Add type declaration to the global results +addTypeDec :: TypeDec -> VHDLM () +addTypeDec td = do + globalST <- gets global + let gRes = globalRes globalST + tDecs = typeDecs gRes + -- FIXME: use queues + modify (\st -> st{global = globalST{globalRes = gRes{typeDecs = tDecs ++ [td]}}}) + + +-- | Add subtype declaration to the global results +addSubtypeDec :: SubtypeDec -> VHDLM () +addSubtypeDec std = do + globalST <- gets global + let gRes = globalRes globalST + stDecs = subtypeDecs gRes + -- FIXME: use queues + modify (\st -> st{global = globalST{ + globalRes = gRes{subtypeDecs = stDecs ++ [std]}}}) + + +-- | Add an unconstrained FSVec to the global results +addUnconsFSVec :: FSDTypeRep -> VHDLM () +addUnconsFSVec trep = do + globalST <- gets global + -- FIXME: use queues + modify (\st -> st{global = + globalST{ + transUnconsFSVecs = (transUnconsFSVecs globalST) ++ [trep]}}) + +-- | Add a subprogram to the global results +addSubProgBody :: SubProgBody -> VHDLM () +addSubProgBody newBody = do + globalST <- gets global + let gRes = globalRes globalST + bodies = subProgBodies gRes + -- FIXME: use queues + modify (\st -> st{global = globalST + {globalRes = gRes{subProgBodies = bodies ++ [newBody]}}}) + + +-- | Add a TH-name (arity, VHDL expression construtor function) pair to the translation namespace table +addTransNamePair :: Name -> Arity -> ([Expr] -> Expr) -> VHDLM () +addTransNamePair thName arity vHDLFun = do + lState <- gets local + let s = funTransST lState + table = nameTable s + modify (\st -> st{local=lState{funTransST=s{ + nameTable=(thName,(arity,vHDLFun)):table}}}) + +-- | Add a declarations to Auxiliary VHDL declarations of the Function +-- translation state +addDecsToFunTransST :: [SubProgDecItem] -> VHDLM () +addDecsToFunTransST decs = do + lState <- gets local + let s = funTransST lState + auxs = auxDecs s + modify (\st -> st{local=lState{funTransST=s{ + auxDecs=decs++auxs}}}) + + + +getCurrentFunctionSpec :: VHDLM SubProgSpec +getCurrentFunctionSpec = do + fSpecM <- gets (currentFSpec.funTransST.local) + case fSpecM of + Just fSpec -> return fSpec + Nothing -> error "Bug: Incomplete translation context, found `Nothing` expected `Just SubProgSpec`" + +putCurrentFunctionSpec :: SubProgSpec -> VHDLM () +putCurrentFunctionSpec spec = do + lState <- gets local + let s = funTransST lState + modify (\st -> st{local=lState{funTransST=s{ + currentFSpec=Just spec}}}) + +-- | Get a fresh VHDL Identifier and increment the +-- tranlation-namespace-count of freshly generated identifiers. +-- +-- Note that all user-supplied identifiers (process ids, port ids, +-- and function parameters) are translated to extended VHDL +-- identifiers. That, together with the fact that basic and extended +-- VHDL identifers live in different namespaces, guarantees that +-- freshly generated basic VHDL identifiers cannot clash with the +-- ones supplied by the frontend. +genFreshVHDLId :: VHDLM VHDLId +genFreshVHDLId = genVHDLId "fresh_" + +genVHDLId :: String -> VHDLM VHDLId +genVHDLId prefix = do + lState <- gets local + let ns = funTransST lState + count = freshNameCount ns + modify (\st -> st{local=lState{funTransST=ns{freshNameCount=count+1}}}) + liftEProne.mkVHDLBasicId $ (prefix ++ show count) + +-- | Lift an 'EProne' value to the VHDL monad setting current error context +-- for the error +-- liftEProne :: EProne a -> VHDLM a +liftEProne :: EProne a -> VHDLM a +liftEProne ep = do + cxt <- gets (context.local) + either (throwError.(ContextErr cxt)) return ep + +-- | Throw a ForSyDe error, setting current error context +throwFError :: ForSyDeErr -> VHDLM a +throwFError = liftEProne.Left + + + +-- | Execute certain operation with a concrete process context. +-- The initial context is restored after the operation is executed +-- Note: the initial context must be a system context or 'InconsistenContexts' +-- will be raised. +withProcC :: ProcId -> VHDLM a -> VHDLM a +withProcC pid action = do + -- get the initial context + st <- get + let l = local st + c = context l + -- set the modified name context + put st{local=l{context=setProcC pid c}} + -- execute the action + res <- action + -- restore the initial name context + st' <- get + let l' = local st' + put st'{local=l'{context=c}} + -- return the result + return res + + + +-- | Execute certain operation with a concrete process function context. +-- The initial context is restored after the operation is executed +-- Note: the initial context must be a process context or +-- 'InconsistenContexts' will be raised. +withProcFunC :: Name -> Loc -> VHDLM a -> VHDLM a +withProcFunC name loc action = do + -- get the initial context + st <- get + let l = local st + c = context l + -- set the modified context + put st{local=l{context=setProcFunC name loc c}} + -- execute the action + res <- action + -- restore the initial context + st' <- get + let l' = local st' + put st'{local=l'{context=c}} + -- return the result + return res + + + +-- | Execute certain operation with a concrete process function context. +-- The initial context is restored after the operation is executed +-- Note: the initial context must be a process context or +-- 'InconsistenContexts' will be raised. +withProcValC :: Exp -> VHDLM a -> VHDLM a +withProcValC exp action = do + -- get the initial context + st <- get + let l = local st + c = context l + -- set the modified context + put st{local=l{context=setProcValC exp c}} + -- execute the action + res <- action + -- restore the initial context + st' <- get + let l' = local st' + put st'{local=l'{context=c}} + -- return the result + return res + + +---------------- +-- IntSignalInfo +---------------- + +-- | Intermediate signal information. Tag generated for each output of each +-- node found during the traversal. +-- (see ForSyDe.Netlist.Traverse.traverseSIO). +-- It contains the VHDL intemediate signal name associated with the process +-- output. +type IntSignalInfo = SimpleName + diff --git a/src/ForSyDe/Deep/Bit.hs b/src/ForSyDe/Deep/Bit.hs new file mode 100644 --- /dev/null +++ b/src/ForSyDe/Deep/Bit.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE TemplateHaskell, DeriveDataTypeable, MultiParamTypeClasses, + FunctionalDependencies, TypeSynonymInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : ForSyDe.Bit +-- Copyright : (c) ES Group, KTH/ICT/ES 2007-2013 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : forsyde-dev@ict.kth.se +-- Stability : experimental +-- Portability : portable +-- +-- 'Bit' Datatype. Note that the 'Num' instance is phony and shouldn't be used +-- +----------------------------------------------------------------------------- +module ForSyDe.Deep.Bit (Bit(..), + not, + bitToBool, + boolToBit, + toBitVector8, + fromBitVector8, + toBitVector16, + fromBitVector16, + toBitVector32, + fromBitVector32, + toBitVector64, + fromBitVector64, + fixmul8) where + +import Language.Haskell.TH.Lift +import Data.Int +import Data.Bits +import Data.Data (Data, Typeable) +import Prelude hiding (not) + +import Data.Param.FSVec (FSVec, reallyUnsafeVector) +import qualified Data.Param.FSVec as V +import Data.TypeLevel.Num (D8,D16,D32,D64,Nat) + +data Bit = H -- ^ High value + | L -- ^ Low value + deriving (Eq, Show, Data, Typeable) + +$(deriveLift1 ''Bit) + +-- | Not operation over bits +not :: Bit -> Bit +not = complement + + +instance Bits Bit where + H .&. x = x + L .&. _ = L + H .|. _ = H + L .|. x = x + xor H L = H + xor L H = H + xor _ _ = L + complement L = H + complement H = L + shift x 0 = x + shift _ _ = L + rotate x _ = x + bitSize _ = 1 + isSigned _ = False + + +-- Phony instance of Num +instance Num Bit where + H + L = H + H + H = L + L + x = x + -- since they are unsigned and there are only two elements, (-) == (+) + (-) = (+) + -- multiplication is equivalent to (.&.) + (*) = (.&.) + -- since a bit is unsigned, it is equivalent to identity + abs = id + signum _ = L + fromInteger n = if n<=0 then L else H + +-- | Convert a bit to a boolean +bitToBool :: Bit -> Bool +bitToBool H = True +bitToBool L = False + +-- | Convert a boolean to a bit +boolToBit :: Bool -> Bit +boolToBit True = H +boolToBit False = L + +toBitVector8 :: Int8 -> FSVec D8 Bit +toBitVector8 = reallyUnsafeToBitVector + +fromBitVector8 :: FSVec D8 Bit -> Int8 +fromBitVector8 = fromBitVectorDef 0 + + +toBitVector16 :: Int16 -> FSVec D16 Bit +toBitVector16 = reallyUnsafeToBitVector + +fromBitVector16 :: FSVec D16 Bit -> Int16 +fromBitVector16 = fromBitVectorDef 0 + + +toBitVector32 :: Int32 -> FSVec D32 Bit +toBitVector32 = reallyUnsafeToBitVector + +fromBitVector32 :: FSVec D32 Bit -> Int32 +fromBitVector32 = fromBitVectorDef 0 + + +toBitVector64 :: Int64 -> FSVec D64 Bit +toBitVector64 = reallyUnsafeToBitVector + +fromBitVector64 :: FSVec D64 Bit -> Int64 +fromBitVector64 = fromBitVectorDef 0 + + +fixmul8 :: Int8 -> Int8 -> Int8 +fixmul8 a b = fromIntegral $ (fromIntegral a * fromIntegral b::Int16) `div` 128 + + + +{- This would have been much more convenient + But it makes things really complicated int he VHDL + backend + +-- | Datatypes which can be converted to and from +-- vectors of bits +class BitStream d s | d -> s where + -- | convert a data type to a bit vector + toBitVector :: d -> FSVec s Bit + -- | get a datatype from a bit vector + fromBitVector :: FSVec s Bit -> d + +instance BitStream Int8 D8 where + toBitVector = reallyUnsafeToBitVector + fromBitVector = fromBitVectorDef 0 + + +instance BitStream Int16 D16 where + toBitVector = reallyUnsafeToBitVector + fromBitVector = fromBitVectorDef 0 + + +instance BitStream Int32 D32 where + toBitVector = reallyUnsafeToBitVector + fromBitVector = fromBitVectorDef 0 + + +instance BitStream Int64 D64 where + toBitVector = reallyUnsafeToBitVector + fromBitVector = fromBitVectorDef 0 +-} + +------------------- +-- Helper functions +------------------- +reallyUnsafeToBitVector :: Bits a => a -> FSVec s Bit +reallyUnsafeToBitVector x = + reallyUnsafeVector $ map (boolToBit.(testBit x)) [size-1,size-2..0] + where size = bitSize x + +-- | version of fromBitVector supplying a default initial value from which to +-- start working +fromBitVectorDef :: (Bits a, Nat s) => a -> FSVec s Bit -> a +fromBitVectorDef def vec = fst $ V.foldr f (def, 0) vec + where f e (ac, pos) = (copyBit e ac pos, pos+1) + copyBit H = setBit + copyBit L = clearBit + + + + diff --git a/src/ForSyDe/Deep/Config.hs b/src/ForSyDe/Deep/Config.hs new file mode 100644 --- /dev/null +++ b/src/ForSyDe/Deep/Config.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE TemplateHaskell, CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : ForSyDe.Deep.Config +-- Copyright : (c) ES Group, KTH/ICT/ES 2007-2013 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : forsyde-dev@ict.kth.se +-- Stability : experimental +-- Portability : portable +-- +-- Configuration values of ForSyDe +-- +----------------------------------------------------------------------------- +module ForSyDe.Deep.Config (forsydeVersion, + maxTupleSize, + module Paths_forsyde_deep) where + +import Paths_forsyde_deep +import ForSyDe.Deep.Version (getVersion) + +#ifdef DEVELOPER +maxTupleSize :: Int +maxTupleSize = 8 +#else +import GHC.Exts (maxTupleSize) +#endif + +forsydeVersion = $(getVersion) diff --git a/src/ForSyDe/Deep/DFT.hs b/src/ForSyDe/Deep/DFT.hs new file mode 100644 --- /dev/null +++ b/src/ForSyDe/Deep/DFT.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE ScopedTypeVariables, FlexibleContexts #-} +----------------------------------------------------------------------------- +-- | +-- Module : ForSyDe.Deep.DFT +-- Copyright : (c) ES Group, KTH/ICT/ES 2007-2013 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : forsyde-dev@ict.kth.se +-- Stability : experimental +-- Portability : portable +-- +-- This module includes the standard Discrete Fourier Transform (DFT) +-- function, and a fast Fourier transform (FFT) algorithm, for +-- computing the DFT, when the input vectors' length is a power of 2. +----------------------------------------------------------------------------- +module ForSyDe.Deep.DFT(dft, fft) where + + +import qualified Data.Param.FSVec as V +import Data.Param.FSVec +import Data.TypeLevel (Nat, IsPowOf, D2) +import Data.Complex + + +-- | The function 'dft' performs a standard Discrete Fourier Transformation +dft :: forall s . Nat s => FSVec s (Complex Double) -> FSVec s (Complex Double) +dft v = V.map (bigX_k v) nVector + where + lT = V.lengthT v + lV = V.genericLength v + -- FIXME: dft does not type-check without this type signature: + -- learn why! + nVector :: Num a => FSVec s a + nVector = kVector lT + fullCircle = V.map (\n -> -2*pi*n/lV) nVector + bigX_k v k = sumV (V.zipWith (*) v (bigW k)) + bigW k = V.map (** k) (V.map cis fullCircle) + sumV = V.foldl (+) (0:+ 0) + + +-- | The function 'fft' implements a fast Fourier transform (FFT) algorithm, +-- for computing the DFT, when the size N is a power of 2. +fft :: (Nat s, IsPowOf D2 s) => + FSVec s (Complex Double) -> FSVec s (Complex Double) +fft v = V.map (bigX v) (kVector lT) + where lT = V.lengthT v + +kVector :: (Num a, Nat s) => s -> FSVec s a +kVector s = V.iterate s (+1) 0 + + +bigX :: (Nat s, IsPowOf D2 s) => + FSVec s (Complex Double) -> Integer -> Complex Double +-- since there are no output length constraints (no vector is being returned) +-- we can simply obtain the list inside the vector and work with it directly +bigX v k = bigX' (V.genericLength v) (V.fromVector v) k + where bigX' :: Integer -> [Complex Double] -> Integer -> Complex Double + -- The first argument is the length of the list (bigN) + bigX' _ (x0:[x1]) k | even k = x0 + x1 * bigW 2 0 + | odd k = x0 - x1 * bigW 2 0 + bigX' l xs k = bigF_even + bigF_odd * bigW l k + where bigF_even = bigX' halfl (evens xs) k + bigF_odd = bigX' halfl (odds xs) k + halfl = l `div` 2 + +bigW :: Integer -> Integer -> Complex Double +bigW bigN k = cis (-2 * pi * (fromInteger k) / (fromInteger bigN)) + +evens :: [a] -> [a] +evens [] = [] +evens [v1] = [v1] +evens (v1:_:v) = v1 : evens v + +odds :: [a] -> [a] +odds [] = [] +odds [_] = [] +odds (_:v2:v) = v2 : odds v + + diff --git a/src/ForSyDe/Deep/FIR.hs b/src/ForSyDe/Deep/FIR.hs new file mode 100644 --- /dev/null +++ b/src/ForSyDe/Deep/FIR.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE TemplateHaskell, RelaxedPolyRec, PatternGuards #-} +-- The PatternGuards are used to hush innapropiate compiler warnings +-- see http://hackage.haskell.org/trac/ghc/ticket/2017 +----------------------------------------------------------------------------- +-- | +-- Module : ForSyDe.Deep.FIR +-- Copyright : (c) ES Group, KTH/ICT/ES 2007-2013 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : forsyde-dev@ict.kth.se +-- Stability : experimental +-- Portability : portable +-- +-- This module implements FIR filters for the synchronous computational model. +----------------------------------------------------------------------------- +module ForSyDe.Deep.FIR (fir) where + +import ForSyDe.Deep.Ids +import ForSyDe.Deep.Signal +import ForSyDe.Deep.Process + +import Data.TypeLevel.Num (Nat, Pos) +import Data.Param.FSVec hiding ((++)) +import qualified Data.Param.FSVec as V +import Data.Typeable + +-- | +-- All kinds of FIR-filters can now be modeled by means of 'fir'. The +-- only argument needed is the list of coefficients, which is given as +-- a vector of any size. To illustrate this, an 8-th order band pass +-- filter is modeled as follows. +-- +-- > bp = fir "fir Id" $(vectorTH [0.06318761339784, 0.08131651217682, 0.09562326700432, +-- > 0.10478344432968, 0.10793629404886, 0.10478344432968, +-- > 0.09562326700432, 0.08131651217682, 0.06318761339784 ]) +-- + +fir :: (Fractional b, ProcType b, Pos s, Typeable s) => + ProcId -> FSVec s b -> Signal b -> Signal b +fir id h = innerProd (id ++ "_innerProd") h . sipo (id ++ "_sipo") k 0.0 + where k = V.lengthT h + +sipo :: (Pos s, Typeable s, Fractional a, ProcType a) => + ProcId -> s -> a -> Signal a -> FSVec s (Signal a) +sipo id n s0 = unzipxSY (id ++ "_unzipxSY") . scanldSY (id ++ "_scanldSY") srV initState + where initState = V.copy n s0 + srV = $(newProcFun [d| srV :: Pos s => FSVec s a -> a -> FSVec s a + srV v a = V.shiftr v a |]) + +innerProd :: (Fractional a, ProcType a, Nat s, Typeable s) => + ProcId -> FSVec s a -> FSVec s (Signal a) -> Signal a +innerProd id h = zipWithxSY id (ipV `defArgVal` h) + where ipV = $(newProcFun + -- We could make the inner product in one traverse + -- but FSVecs don't allow recursive calls + -- (they don't allow to check the constraints statically) + -- Thus, we traverse the vector twice + [d| ipV :: (Nat s, Num a) => FSVec s a -> FSVec s a -> a + ipV v1 v2 = + V.foldl (+) 0 $ V.zipWith (*) v1 v2 |]) + + + diff --git a/src/ForSyDe/Deep/ForSyDeErr.hs b/src/ForSyDe/Deep/ForSyDeErr.hs new file mode 100644 --- /dev/null +++ b/src/ForSyDe/Deep/ForSyDeErr.hs @@ -0,0 +1,465 @@ +{-# LANGUAGE FlexibleContexts #-} +----------------------------------------------------------------------------- +-- | +-- Module : ForSyDe.ForSyDeErr +-- Copyright : (c) ES Group, KTH/ICT/ES 2007-2013 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : forsyde-dev@ict.kth.se +-- Stability : experimental +-- Portability : portable +-- +-- ForSyDe error-related types and functions. +-- +----------------------------------------------------------------------------- +module ForSyDe.Deep.ForSyDeErr + (ForSyDeErr(..), + ContextErr(..), + VHDLFunErr(..), + VHDLExpErr(..), + Context(..), + setProcC, + setProcFunC, + setProcValC, + Loc, + EProne, + liftEither, + uError, + intError, + qError, + qGiveUp, + qPutTraceMsg, + printError, + printVHDLError, + printGraphMLError, + module Control.Monad.Error, + module Debug.Trace) where + + +import ForSyDe.Deep.Ids + +import Data.Maybe (fromMaybe) +import Debug.Trace +import Control.Monad.Error +import Data.Dynamic +import Language.Haskell.TH.Syntax hiding (Loc) +import Language.Haskell.TH.Ppr +import Language.Haskell.TH.PprLib +import Text.PrettyPrint.HughesPJ (render) +import Data.Typeable.FSDTypeRepLib + +------------- +-- ForSyDeErr +------------- + +-- | All Errors thrown or displayed in ForSyDe +data ForSyDeErr = + -- Used in ForSyDe.ForSyDeErr + InconsistentContexts | + -- Used in ForSyDe.Netlist + EvalErr String | + + -- Used in ForSyDe.System.* + -- | Not a variable name + NonVarName Name | + -- | Incompatible system function + IncomSysF Name Type | + -- | Incompatible input interface length + InIfaceLength (SysId,Int) ([String],Int) | + -- | Incompatible output interface length + OutIfaceLength (SysId,Int) ([String],Int) | + -- | Multiply defined port identifier + MultPortId PortId | + -- | Multiply defined process identifier + MultProcId ProcId | + -- | The system contains components from different subsystems with + -- the same Identifiers + SubSysIdClash SysId (Maybe Loc) (Maybe Loc) | + -- | Not a SysDef variable + NonSysDef Name Type | + + -- Used in ForSyDe.Proc.ProcFun + -- | Incorrect Declarations provided to create a ProcFun + IncorrProcFunDecs [Dec] | + + -- Used in ForSyDe.Netlist.Traversable + -- | Inconsistent output tag + InconsOutTag | + + -- Used in ForSyDe.Backend.Simulate + -- | Inconsistent System Definition Port + InconsSysDefPort PortId | + -- | Dynamic type mismatch + DynMisMatch Dynamic TypeRep | + -- | Signature mismatch + SigMisMatch Type | + -- | Simulation input signals length mismatch + InLengthMisMatch Int Int | + + -- Used in ForSyDe.Backend.VHDL.* + -- | Empty VHDL identifier + EmptyVHDLId | + -- | Incorrect Basic VHDL Identifier + IncVHDLBasId String | + -- | Incorrect Extended VHDL Identifier + IncVHDLExtId String | + -- | Function untranslatable to VHDL (function name and error raised) + UntranslatableVHDLFun VHDLFunErr | + -- | Expresion untranslatable to VHDL + UntranslatableVHDLExp Exp VHDLExpErr | + -- Common Backend errors + -- | UnsUpported type + UnsupportedType FSDTypeRep | + -- | Reserved identifier + ReservedId String | + -- | Unsupported process + UnsupportedProc | + -- | Quartus Failed + QuartusFailed | + -- | Ghdl Failed + GhdlFailed | + -- | Modelsim Failed + ModelsimFailed | + + -- | Other Errors + Other String + +-- | Function translation errors in the VHDL backend +data VHDLFunErr = + -- | Polymorphic declaration + PolyDec Dec | + -- | Unsupported declaration block + UnsupportedDecBlock [Dec] | + -- | Insufficient number of parameters + InsParamNum Name Int | + -- | Unsupported input pattern in function + UnsupportedFunPat Pat | + -- | Multiple clauses + MultipleClauses [Clause] | + -- | Guards in case alternatives are not supported + FunGuardedBody Body | + -- | A general Error which applies to a function + -- (e.g. its name or parameters are not a VHDL identifier, + -- an error in an inner expression ... ) + GeneralErr ForSyDeErr + + +instance Show VHDLFunErr where + show (PolyDec dec) = "polymorphic daclaration:\n" ++ + pprint dec ++ + "\nDeclarations within a ProcFun must be monomorphic in order to be " ++ + "translatable to VHDL" + show (UnsupportedDecBlock decs) = "Unsupported declaration block:\n" ++ + concatMap pprint decs ++ + "All declaration blocks within a process function must follow the following " ++ + "pattern:\n" ++ + " name1 :: type\n" ++ + " name1 arg1 arg2 ... = defintion1\n" ++ + " name2 :: type\n" ++ + " name2 arg1 arg2 .... = defintion2\n" + show (FunGuardedBody body) = "guards are not supported in functions:\n" ++ + (render.to_HPJ_Doc.(pprBody True)) body + show (InsParamNum name n) = + "insufficient number of parameters (" ++ show n ++ ") in the defintion of `" ++ + pprint name ++ + "'\n point free definitons are not suported by the VHDL backend" + show (UnsupportedFunPat pat) = + "input pattern `" ++ pprint pat ++ "' is not supported" + show (MultipleClauses cs) = "multiple clauses (" ++ + (show.length) cs ++ "):\n" ++ pprint cs + show (GeneralErr err) = show err + +-- | Expression translation errors in the VHDL backend +data VHDLExpErr = + -- | Guards in case alternatives are not supported + CaseGuardedBody Body | + -- Unsupported case pattern + UnsupportedCasePat Pat | + -- | Where constructs in case alternatives are not supported + CurryUnsupported Int Int | + -- | Unkown identifier + UnkownIdentifier Name | + -- Unsupported literal + UnsupportedLiteral | + -- Sections are not supported + Section | + -- Lambda Abstractions are not supported + LambdaAbstraction | + -- Conditional expressions are only supported in a function body + Conditional | + -- Case expressions are only supported in a function body + Case | + -- Do expressions are not supported + Do | + -- List comprehensions are not supported + ListComprehension | + -- Arithmetic sequences are not supported + ArithSeq | + -- Lists are not supported + List | + -- Signature expressiosn are not supported + Signature | + -- Record expressions are not supported + Record | + -- Unsupported expression generic error + -- it shouldn't be raised, just for pattern completeness + Unsupported + +instance Show VHDLExpErr where + show (CaseGuardedBody body) = + "guards are not supported in case alternatives:\n" ++ + (render.to_HPJ_Doc.(pprBody True)) body + show (UnsupportedCasePat pat) = "unsupported case pattern: `" ++ + pprint pat ++ "'" + show (CurryUnsupported expected real) = + "Currification is not supported, all arguments must be fully supplied\n"++ + " Expected arguments: " ++ show expected ++ " Provided arguments: " ++ + show real + show (UnkownIdentifier name) = "unkown identifier `" ++ pprint name ++ "'" + show UnsupportedLiteral = "unsupported literal" + show Section = "sections are not supported" + show LambdaAbstraction = "lambda abstractions are not supported" + show Conditional = "conditional expressions are only supported within" + ++ " a function body" + show Case = "case expressions are only supported within" + ++ " a function body" + show Do = "do expressions are not suupported" + show ListComprehension = "list comprehensions are not supported" + show ArithSeq = "arithmetic sequences are not supported" + show List = "lists are not supported" + show Signature = "signature expressions are not supported" + show Record = "record expressions are not supported" + show Unsupported = "unsupported expression" + +-- | Show errors +instance Show ForSyDeErr where + show InconsistentContexts = "Inconsistent contexts" + show (EvalErr str) = "Non evaluable node (" ++ show str ++ ")" + show (NonVarName name) = show name ++ " is not a variable name." + show (IncomSysF fName inctype) = + "Incompatible system function type\n"++ + show strFName ++ " was expected to have type:\n" ++ + " Signal i1 -> Signal i2 -> ..... -> Signal in ->\n" ++ + " (Signal o1, Signal o2, ... , Signal om)\n" ++ + " with n <- |N U {0} and m <- |N U {0}\n" ++ + " i1 .. in, o1 .. im monomorphic types\n" ++ + "However " ++ strFName ++ " has type\n " ++ + " " ++ pprint inctype + where strFName = show fName + show (InIfaceLength sysInInfo portIdsInInfo) = + showIfaceLength "input interface" sysInInfo portIdsInInfo + show (OutIfaceLength sysOutInfo portIdsOutInfo) = + showIfaceLength "output interface" sysOutInfo portIdsOutInfo + show (MultPortId portId) = + "Multiply defined port identifier " ++ show portId + show (MultProcId procId) = + "Multiply defined process identifier " ++ show procId + show (SubSysIdClash subSysId mLoc1 mLoc2) = + "System contains components of different subsystems " ++ + "(defined at locations " ++ finalLoc1 ++ " and " ++ finalLoc2 ++ ") " ++ + "which share the same system identifier (`"++subSysId++")" + where finalLoc1 = fromMaybe "" mLoc1 + finalLoc2 = fromMaybe "" mLoc2 + show (NonSysDef name t) = + "A variable with SysDef type was expected\n" ++ + "However " ++ show name ++ " has type " ++ pprint t + show (IncorrProcFunDecs decs) = + "Only a function declaration (possibly precedeeded by a signature)" ++ + "is accepted\n"++ + "The specific, incorrect declarations follow:\n" ++ + pprint decs + show InconsOutTag = "Inconsistent output tag" + show (InconsSysDefPort id) = "Inconsistent port in SysDef: " ++ show id + show (DynMisMatch dyn rep) = + "Type matching error in dynamic value with typerep " ++ + show (dynTypeRep dyn) ++ + "\n(Expected type: " ++ show rep ++ " )." + show (SigMisMatch t) = + "Signal mismatch: expected a Signal type but got " ++ pprint t + show (InLengthMisMatch l1 l2) = + "Cannot simulate: simulation arguments length-mismatch: " ++ + show l1 ++ " /= " ++ show l2 + show EmptyVHDLId = "Empty VHDL identifier" + show (IncVHDLBasId id) = "Incorrect VHDL basic identifier " ++ + "`" ++ id ++ "'" + show (IncVHDLExtId id) = "Incorrect VHDL extended identifier " ++ + "`" ++ id ++ "'" + show (UnsupportedType tr) = "Unsupported type " ++ show tr + show (ReservedId str) = "Identifier `" ++ str ++ "' is reserved" + show UnsupportedProc = "Unsupported process" + show (UntranslatableVHDLFun err) = + "Untranslatable function: " ++ show err + show (UntranslatableVHDLExp exp err) = + "Untranslatable expression `" ++ pprint exp ++ "': " ++ show err + show QuartusFailed = "Quartus failed" + show GhdlFailed = "Ghdl failed" + show ModelsimFailed = "Modelsim failed" + show (Other str) = str + +-- | help function for the show instance +showIfaceLength :: String -> (SysId, Int) -> ([String],Int) -> String +showIfaceLength ifaceMsg (sysName, sysIfaceL) (ifaceIds, ifaceL) = + "Incorrect length of " ++ ifaceMsg ++ " (" ++ show ifaceL ++ ")\n" ++ + " " ++ show ifaceIds ++ "\n" ++ + sysName ++ " expects an " ++ show ifaceMsg ++ " length of " ++ + show sysIfaceL + +----------------- +-- Context Error +----------------- + +-- | A context error: a 'ForSyDeErr' with context information (indicating where +-- the error ocurred) +data ContextErr = ContextErr Context ForSyDeErr + +-- | A context: it indicates where an error ocurred. +data Context = + -- | Empty context + EmptyC | + -- | In a System definition + SysDefC SysId (Maybe Loc) | + -- | In a Process + ProcC SysId (Maybe Loc) ProcId | + -- | In a Proces Function + ProcFunC SysId (Maybe Loc) ProcId Name Loc | + -- | In a Process value + ProcValC SysId (Maybe Loc) ProcId Exp + +-- | type indicating a location in the user's source +-- code +type Loc = String + +-- | Set a process context from a system context +setProcC :: ProcId -- ^ Identifier of the process + -> Context -- ^ system context + -> Context +setProcC pid (SysDefC sysid mSysloc) = ProcC sysid mSysloc pid +setProcC _ _ = intError funName InconsistentContexts + where funName = "ForSyDe.ForSyDeErr.setProcC" + +-- | Set a process function context from a process context +setProcFunC :: Name -- ^ Function name + -> Loc -- ^ Function location + -> Context -- ^ system context + -> Context +setProcFunC name loc (ProcC sysid sysloc pid) = + ProcFunC sysid sysloc pid name loc +setProcFunC _ _ _ = intError funName InconsistentContexts + where funName = "ForSyDe.ForSyDeErr.setProcFunC" + +-- | Set a process value context from a process context +setProcValC :: Exp -- ^ Expression value + -> Context -- ^ system context + -> Context +setProcValC exp (ProcC sysid sysloc pid) = ProcValC sysid sysloc pid exp +setProcValC _ _ = intError funName InconsistentContexts + where funName = "ForSyDe.ForSyDeErr.setProcValC" + +instance Show Context where + show EmptyC = "" + show (SysDefC id mLoc) = "system definition `" ++ id ++ + "' (created in " ++ finalLoc ++ ")" + where finalLoc = fromMaybe "" mLoc + show (ProcC sysid sysloc pid) = "process `" ++ pid ++ "' belonging to " ++ + show (SysDefC sysid sysloc) + show (ProcFunC sysid sysloc pid fName fLoc) = + "process function `" ++ pprint fName ++ "' (created in " ++ fLoc ++ ") " ++ + " used by " ++ show (ProcC sysid sysloc pid) + show (ProcValC sysid sysloc pid valExp) = + "process argument `" ++ pprint valExp ++ "' used by " + ++ show (ProcC sysid sysloc pid) + + +instance Show ContextErr where + show (ContextErr cxt err) = case cxt of + EmptyC -> show err + _ -> show err ++ "\nin " ++ show cxt + +-------------- +-- Error Monad +-------------- + +-- | We make ForSyDeErr an instance of the Error class to be able to throw it +-- as an exception. +instance Error ForSyDeErr where + noMsg = Other "An Error has ocurred" + strMsg = Other + + +instance Error ContextErr where + noMsg = ContextErr EmptyC noMsg + strMsg = \str -> ContextErr EmptyC (strMsg str) + +-- | 'EProne' represents failure using Left ForSyDeErr or a successful +-- result of type a using Right a +-- +-- 'EProne' is implicitly an instance of +-- ['MonadError'] (@Error e => MonadError e (Either e)@) +-- ['Monad'] (@Error e => Monad (Either e)@) +type EProne = Either ForSyDeErr +-- FIXME: Rethink Eprone so that it takes contexts in account + +------------------- +-- Helper functions +------------------- + +-- | Throws a an error caused by improper use of a user-exported function +uError :: String -- ^ User-exported function which cuased the error + -> ForSyDeErr -- ^ Error to show + -> a +uError funName err = error $ "User error in " ++ funName ++ ": " ++ + show err ++ "\n" + + +-- | Throws an internal error +intError :: String -- ^ Function which caused the internal error + -> ForSyDeErr -- ^ Error to show + -> a +intError funName err = error $ "Internal error in " ++ funName ++ ": " ++ + show err ++ "\n" ++ + "Please report!" + +-- | lift an Either expression to an Error Monad +liftEither :: MonadError e m => Either e a -> m a +liftEither = either throwError return + + + +-- | An error reporting function for Quasi monads +-- Executing in the monad will stop inmideately after calling qError +-- Note, it does not work for GHC<6.8 +-- see +qError :: Quasi m => String -- ^ The name of the function + -- called in the splice + -> ForSyDeErr -- ^ Error to show + -> m a +qError fname err = fail $ "Error when calling " ++ fname ++ ":\n" ++ + show err + + +-- | Stop execution, find the enclosing qRecover +-- if a recover is not found, it is considered as an internal error +-- and the string provided will used as a reference to +-- the origin of the error. +-- Note, it does not work for GHC<6.8 +-- see +qGiveUp :: Quasi m => String -> m a +qGiveUp name = fail $ "qGiveUp: Internal error in " ++ name ++ + ", please report." + +-- | Output a trace message in a quasi monad (similar to 'putTraceMsg') +qPutTraceMsg :: Quasi m => String -> m () +qPutTraceMsg msg = qRunIO (putTraceMsg msg) + + +-- | Print an Error +printError :: Show a => a -> IO () +printError = putStrLn.("Error: "++).show + +-- | Print a VHDL compilation error +printVHDLError :: Show a => a -> IO b +printVHDLError = error.("VHDL Compilation Error: "++).show + +-- | Print a GraphML compilation error +printGraphMLError :: Show a => a -> IO () +printGraphMLError = putStrLn.("VHDL Compilation Error: "++).show diff --git a/src/ForSyDe/Deep/Ids.hs b/src/ForSyDe/Deep/Ids.hs new file mode 100644 --- /dev/null +++ b/src/ForSyDe/Deep/Ids.hs @@ -0,0 +1,23 @@ +----------------------------------------------------------------------------- +-- | +-- Module : ForSyDe.Deep.Ids +-- Copyright : (c) ES Group, KTH/ICT/ES 2007-2013 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : forsyde-dev@ict.kth.se +-- Stability : experimental +-- Portability : portable +-- +-- ForSyDe identifier types +-- +----------------------------------------------------------------------------- +module ForSyDe.Deep.Ids where + +-- | A process identifier +type ProcId = String + +-- | A Port identifier +type PortId = String + +-- | A System identifier +type SysId = String diff --git a/src/ForSyDe/Deep/Netlist.hs b/src/ForSyDe/Deep/Netlist.hs new file mode 100644 --- /dev/null +++ b/src/ForSyDe/Deep/Netlist.hs @@ -0,0 +1,252 @@ +{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-} +----------------------------------------------------------------------------- +-- | +-- Module : ForSyDe.Deep.Netlist +-- Copyright : (c) ES Group, KTH/ICT/ES 2007-2013 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : forsyde-dev@ict.kth.se +-- Stability : experimental +-- Portability : portable +-- +-- This module provides a definition for the netlist of a system description, +-- which is used as the intermediate representation of the embedded compiler. +-- +-- The netlist is modelled as a directed cyclic graph whose nodes +-- are shared using Observable Sharing ("ForSyDe.OSharing"). +-- +-- /This module is based on Lava2000/: +-- +----------------------------------------------------------------------------- + +module ForSyDe.Deep.Netlist where + + +import ForSyDe.Deep.Ids +import ForSyDe.Deep.OSharing (URef, newURef, readURef) +import {-# SOURCE #-} ForSyDe.Deep.System.SysDef + (SysDef(..), PrimSysDef(..), oIface) +import ForSyDe.Deep.Process.ProcFun (TypedProcFun(..)) +import ForSyDe.Deep.ForSyDeErr +import ForSyDe.Deep.Process.ProcVal (ProcVal(..)) + +import Data.Dynamic +import Data.Typeable.FSDTypeRepLib + + +----------- +-- Netlist +----------- + + +-- | The netlist of a system is modelled as a directed cyclic graph but is +-- really equivalently implemented as a set of (possibly overlapping) trees +-- capable of sharing nodes between them. +-- +-- There is no specific data structure for the netlist itself. Instead, a +-- netlist is simply represented by its outputs. Each output is the root node +-- of a tree ('NlTree'). The NlTrees can (and probably will) have common nodes. +-- +-- It is important to note that, due to the use of trees, the only way to +-- traverse a 'Netlist' is from its outputs to its inputs. + +newtype Netlist container = Netlist {netlistOuts :: (container NlTree)} + + + +---------- +-- NlNode +---------- + +-- | A node of the netlist can be either a process, component instances or +-- special nodes to help traversing the graph. +-- +-- Since the netlist graph is implemented with trees, they only store +-- information about their inputs (which are their child nodes in the tree). + +data NlNode inputi = + -- Ports + InPort PortId | -- ^ Input Ports of the system + -- Processes + Proc ProcId (NlProc inputi) + + +-- | A process node +-- Note that vectors and transformed to lists puls an Int parameter +-- indicating its size +data NlProc inputi = + -- Constant signal + Const ProcVal | -- ^ A signal with constant value + -- During all its periods + + -- | mapSY and zipWithSY processes + ZipWithNSY (TypedProcFun Dynamic) -- Process function in dynamic form + [inputi] | + + -- | Vector version of zipWithNSY + ZipWithxSY (TypedProcFun ([Dynamic] -> Dynamic)) -- Process function + -- with dynamic arguments + [inputi] | + + -- ^ Inverse of ZipWithNSY + UnzipNSY [FSDTypeRep] -- Type of the elements in the input tuple + -- (type of outputs) + (Dynamic -> [Dynamic]) -- Dynamic version of the unzipping function + -- for the concrete, monomorphic types + -- of the process + inputi | + + -- | Vector version of UnzipSY + UnzipxSY FSDTypeRep -- Type of elements in the input vector + -- (and type of the outputs) + Int -- Size of output vector (Number of output signals) + (Dynamic -> [Dynamic]) + inputi | + + -- | delaySY process + DelaySY ProcVal inputi | + + -- A System Instance is considered a special process + + -- | System Instance + SysIns PrimSysDef [inputi] + + + +--------- +-- NlEdge +--------- + +-- FIXME: The NLNodeOut should merely be an integer + +-- | The node connection is carried out by directed edges modelled as +-- Unsafe Unmutable References (allowing to share nodes) connected +-- in the output->input direction (remember we are using trees). +-- Since the node to which the edge is directed can have various outputs +-- (e.g a system instance) the edge is tagged to indicate to what +-- output it refers to. +data NlEdge node = NlEdge (ForSyDe.Deep.OSharing.URef node) NlNodeOut + + +-- FIXME: output tags are ugly, create a variant of NlNode which takes outputs in account + +-- | The different outputs which the different nodes can have +data NlNodeOut = InPortOut | + ConstOut | + ZipWithNSYOut | + ZipWithxSYOut | + UnzipNSYOut Int | + UnzipxSYOut Int | + DelaySYOut | + SysInsOut PortId + deriving (Show, Eq) + +-- | Get the output tags of a node +outTags :: NlNode a -> [NlNodeOut] +outTags (InPort _) = [InPortOut] +outTags (Proc _ proc) = + case proc of + Const _ -> [ConstOut] + ZipWithNSY _ _ -> [ZipWithNSYOut] + ZipWithxSY _ _ -> [ZipWithxSYOut] + UnzipNSY types _ _ -> map UnzipNSYOut [1..length types] + UnzipxSY _ nout _ _ -> map UnzipxSYOut [1..nout] + DelaySY _ _ -> [DelaySYOut] + SysIns primSysDefRef _ -> + map (SysInsOut . fst) ((oIface . readURef . unPrimSysDef) primSysDefRef) + + + +------------ +-- NlTree +------------ + +-- | We tie the knot to connect nodes through 'NlEdge's, building a Tree which +-- can have shared nodes. +-- +-- That is done by storing 'NlTree's as the the input information of each node +-- of the tree. Child nodes of the tree are closer to the inputs of the system +-- and parents are closer to the outputs. + +newtype NlTree = NlTree {rootEdge :: (NlEdge (NlNode NlTree))} + +----------- +-- NlSignal +----------- + +-- | A 'NlTree', or more preciselly its root 'NlEdge', is after all, how +-- signals are implemented in the netlist. +type NlSignal = NlTree + +-- | Get the tag of a signal +nlSignalNlOut :: NlSignal -> NlNodeOut +nlSignalNlOut (NlTree (NlEdge _ tag)) = tag + +--------- +-- Signal +--------- + + +-- | A signal can be seen as wire which carries values of certain type +-- and which can be connected and processed by the two computational +-- entities of a ForSyDe system: processes and block instances. +-- + +-- A Signal is internally represented as an edge of the graph representing +-- the system netlist. +-- The phantom type parameter ensures type-consistency for the signal +-- processing functions. + +newtype Signal a = Signal {unSignal :: NlSignal} + deriving Typeable + + +------------------- +-- Helper functions +------------------- + +-- FIXME: All these newWhatever functions probably shouldn't be here + +-- | Generate a signal pointing to an 'InPort' node +newInPort :: PortId -> NlSignal +newInPort id = NlTree (NlEdge (newURef (InPort id)) InPortOut) + + +-- | Generate a reference to a new 'SysIns' node +newSysIns :: ProcId -> SysDef a -> [NlSignal] + -> URef (NlNode NlSignal) +newSysIns id (SysDef primSysDef) inputInfo = + newURef (Proc id (SysIns primSysDef inputInfo)) + +-- | Generate the output signal of a node +newNodeOutSig :: URef (NlNode NlSignal) -- ^ Reference to the node + -> NlNodeOut -- ^ Output tag + -> NlSignal +newNodeOutSig ref mTag = NlTree (NlEdge ref mTag) + + +-- | Evaluate the output of a process within a synchronous period +-- The inputs and outputs are given in dynamic form +eval :: NlNode Dynamic -> [(NlNodeOut, Dynamic)] +eval node = case node of + InPort _ -> intError evalStr (EvalErr "InPort") + Proc _ proc -> case proc of + Const pv -> [(ConstOut, dyn pv)] + ZipWithNSY fun dynArgs + -> [(ZipWithNSYOut, foldl1 dynApp ((tval fun) : dynArgs))] + ZipWithxSY fun dynListArg + -> [(ZipWithxSYOut, (tval fun) dynListArg)] + UnzipNSY _ fun dynArg + -> zipWith (\n dyn -> (UnzipNSYOut n, dyn)) + [1..] + (fun dynArg) + UnzipxSY _ _ fun dynArg + -> zipWith (\n dyn -> (UnzipxSYOut n, dyn)) + [1..] + (fun dynArg) + DelaySY _ _ + -> intError evalStr (EvalErr "DelaySY") + SysIns _ _ + -> intError evalStr (EvalErr "SysIns") + + where evalStr = "ForSyDe.Netlist.eval" diff --git a/src/ForSyDe/Deep/Netlist/Traverse.hs b/src/ForSyDe/Deep/Netlist/Traverse.hs new file mode 100644 --- /dev/null +++ b/src/ForSyDe/Deep/Netlist/Traverse.hs @@ -0,0 +1,193 @@ +{-# LANGUAGE ScopedTypeVariables #-} +----------------------------------------------------------------------------- +-- | +-- Module : ForSyDe.Netlist.Traverse +-- Copyright : (c) ES Group, KTH/ICT/ES 2007-2013 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : forsyde-dev@ict.kth.se +-- Stability : experimental +-- Portability : non-portable (LSTV) +-- +-- This module provides traversing operations for 'ForSyDe.Deep.Netlist' +-- +-- +-- /This module is based on Lava2000/: +-- +----------------------------------------------------------------------------- +module ForSyDe.Deep.Netlist.Traverse where + + +import ForSyDe.Deep.Netlist +import ForSyDe.Deep.OSharing +import ForSyDe.Deep.ForSyDeErr + + +import Data.Maybe (fromMaybe) +-- qualified to avoid nameclash +import qualified Data.Foldable as DF (Foldable(foldMap), toList) +import Data.Monoid (mempty) +-- qualified to avoid nameclash +import qualified Data.Traversable as DT (Traversable(traverse,mapM)) +import Control.Applicative (pure, (<$>)) +import Control.Monad.State +import Control.Monad.ST (ST) + +-- Instances to traverse a netlist Node (and implicitly the whole netlist) + +instance DF.Foldable NlProc where + foldMap _ (Const _) = mempty + foldMap f (ZipWithNSY _ is) = DF.foldMap f is + foldMap f (ZipWithxSY _ is) = DF.foldMap f is + foldMap f (UnzipNSY _ _ i) = f i + foldMap f (UnzipxSY _ _ _ i) = f i + foldMap f (DelaySY _ i) = f i + foldMap f (SysIns _ i) = DF.foldMap f i + + + +instance DF.Foldable NlNode where + foldMap _ (InPort _) = mempty + foldMap f (Proc _ proc) = DF.foldMap f proc + +instance Functor NlProc where + fmap _ (Const val) = Const val + fmap f (ZipWithNSY pf is) = ZipWithNSY pf (fmap f is) + fmap f (ZipWithxSY pf is) = ZipWithxSY pf (fmap f is) + fmap f (UnzipNSY ts pf i) = UnzipNSY ts pf (f i) + fmap f (UnzipxSY t n pf i) = UnzipxSY t n pf (f i) + fmap f (DelaySY c i) = DelaySY c (f i) + fmap f (SysIns def is) = SysIns def (fmap f is) + + + +instance Functor NlNode where + fmap _ (InPort id) = InPort id + fmap f (Proc id proc) = Proc id (fmap f proc) + +instance DT.Traversable NlProc where + traverse _ (Const val) = pure (Const val) + traverse f (ZipWithNSY pf is) = ZipWithNSY pf <$> DT.traverse f is + traverse f (ZipWithxSY pf is) = ZipWithxSY pf <$> DT.traverse f is + traverse f (UnzipNSY ts pf i) = UnzipNSY ts pf <$> f i + traverse f (UnzipxSY t n pf i) = UnzipxSY t n pf <$> f i + traverse f (DelaySY c i) = DelaySY c <$> f i + traverse f (SysIns def is) = SysIns def <$> DT.traverse f is + + + + +instance DT.Traversable NlNode where + traverse _ (InPort id) = pure (InPort id) + traverse f (Proc id proc) = Proc id <$> DT.traverse f proc + + +-- | Traversing monad, stacking state and error transformers over IO +type TravSEIO s e a = (StateT s (ErrorT e IO)) a + + + +-- | traverseSIO traverses a netlist and returns a final user-defined +-- traversing state (@s@) given: +-- new: generates a new (and normally unique) tag for the outputs of each +-- netlist node given the traversing state (which is possibly updated +-- as well). +-- define: given the output tags of a node, current iteration state, +-- and the output tags of its children, @define@ +-- generates the netlist of that node, possibly updating +-- the traversing state +-- FIXME: shoudn't the arguments of define go the other way around? +-- first inputs then outputs. +-- FIXME: why are tags needed in define? [oinfo] should be enough. +-- tags are ugly in general (see the pattern matches) fix this problem. +traverseSEIO :: (DT.Traversable container, Error e) => + (NlNode NlSignal -> TravSEIO s e [(NlNodeOut, oinfo)]) -- ^ new + -> ([(NlNodeOut, oinfo)] -> NlNode oinfo -> TravSEIO s e ()) -- ^ define + -> Netlist container + -> TravSEIO s e (container oinfo) +traverseSEIO new define (Netlist rootSignals) = + do uRefTable <- liftIO $ newURefTableIO + + let gather (NlTree (NlEdge nodeRef tag)) = + do visited <- liftIO $ queryIO uRefTable nodeRef + case visited of + Just infoPairs -> return (specifyOut tag infoPairs) + Nothing -> do + let node = readURef nodeRef + infoPairs <- new node + liftIO $ addEntryIO uRefTable nodeRef infoPairs + childInfo <- DT.mapM gather node + define infoPairs childInfo + return (specifyOut tag infoPairs) + + specifyOut :: NlNodeOut -> [(NlNodeOut, a)] -> a + specifyOut tag pairs = fromMaybe err maybeOut + where funName = "ForSyDe.NetList.Traverse.traverseIO" + err = intError funName InconsOutTag + maybeOut = lookup tag pairs + + DT.mapM gather rootSignals + +-- | Traversing monad, stacking state and error transformers over ST +type TravSEST s e st a = (StateT s (ErrorT e (ST st))) a + +-- | 'ST'-monad version of 'traverseSEIO' +traverseSEST :: (DT.Traversable container, Error e) => + (NlNode NlSignal -> TravSEST s e st [(NlNodeOut, oinfo)]) -- ^ new + -> ([(NlNodeOut, oinfo)] -> NlNode oinfo -> TravSEST s e st ()) -- ^ define + -> Netlist container + -> TravSEST s e st (container oinfo) +traverseSEST new define (Netlist rootSignals) = + do let lift2 = lift.lift + uRefTable <- lift2 $ newURefTableST + let gather (NlTree (NlEdge nodeRef tag)) = + do visited <- lift2 $ queryST uRefTable nodeRef + case visited of + Just infoPairs -> return (specifyOut tag infoPairs) + Nothing -> do + let node = readURef nodeRef + infoPairs <- new node + lift2 $ addEntryST uRefTable nodeRef infoPairs + childInfo <- DT.mapM gather node + define infoPairs childInfo + return (specifyOut tag infoPairs) + + specifyOut :: NlNodeOut -> [(NlNodeOut, a)] -> a + specifyOut tag pairs = fromMaybe err maybeOut + where funName = "ForSyDe.NetList.Traverse.traverseIO" + err = intError funName InconsOutTag + maybeOut = lookup tag pairs + + DT.mapM gather rootSignals + +-- deprecated, do not use +traverseST :: DT.Traversable container => + (NlNode NlSignal -> ST s [(NlNodeOut, oinfo)]) + -> ([(NlNodeOut, oinfo)] -> NlNode oinfo -> ST s ()) + -> Netlist container + -> ST s (container oinfo) +traverseST new define (Netlist rootSignals) = + do uRefTable <- newURefTableST + + let gather (NlTree (NlEdge nodeRef tag)) = + do visited <- queryST uRefTable nodeRef + case visited of + Just infoPairs -> return (specifyOut tag infoPairs) + Nothing -> do let node = readURef nodeRef + infoPairs <- new node + addEntryST uRefTable nodeRef infoPairs + childInfo <- DT.mapM gather node + define infoPairs childInfo + return (specifyOut tag infoPairs) + + specifyOut :: NlNodeOut -> [(NlNodeOut, a)] -> a + specifyOut tag pairs = fromMaybe err maybeOut + where funName = "ForSyDe.NetList.Traverse.traverseST" + err = intError funName InconsOutTag + maybeOut = lookup tag pairs + + DT.mapM gather rootSignals + +-- | Obtain the arguments of a node +arguments :: NlNode a -> [a] +arguments = DF.toList diff --git a/src/ForSyDe/Deep/OSharing.hs b/src/ForSyDe/Deep/OSharing.hs new file mode 100644 --- /dev/null +++ b/src/ForSyDe/Deep/OSharing.hs @@ -0,0 +1,208 @@ +----------------------------------------------------------------------------- +-- | +-- Module : ForSyDe.Deep.OSharing +-- Copyright : (c) ES Group, KTH/ICT/ES 2007-2013 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : forsyde-dev@ict.kth.se +-- Stability : experimental +-- Portability : portable +-- +-- This module provides support for Observable Sharing: +-- +-- It provides: +-- +-- * 'URef': Unsafe Unmutable references, using them causes side effects. +-- +-- * 'URefTable': a table were 'URef's are used as key and can store +-- any value. +-- +-- /This Module was taken from Lava2000's/ @Ref.hs@ /module/: +-- +-- +-- IMPORTANT WARNING: Even if all the functions causing side effects +-- are set as NOINLINE and that all currently known +-- Haskell compilers are based in graph reduction +-- (i.e. referential transparency will be preserved if +-- sharing is), there are other optimisations than inlining +-- that can break Observable Sharing, e.g. Common +-- Subexpression Elimination (CSE). +----------------------------------------------------------------------------- +module ForSyDe.Deep.OSharing + ( -- Unsafe references + URef, + newURef, + readURef, + -- Tables of Unsafe References (IO version) + URefTableIO, + newURefTableIO, + addEntryIO, + queryIO, + -- Tables of Unsafe References (IO version) + URefTableST, + newURefTableST, + addEntryST, + queryST, + -- Memoizating functions + memoURef, + memoURefIO, + memoURefST) + where + +import ForSyDe.Deep.OSharing.UDynamic + +import System.IO (fixIO) +import System.IO.Unsafe (unsafePerformIO) +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Control.Monad.ST +import qualified Control.Monad.ST.Unsafe as STU + + + +-- | An Unsafe Unmutable Reference to a value of type a +-- +-- An 'URef' is implemented as follows: it has two pieces of information. The +-- first one is an updatable list of entries for each table it is a member in. +-- Since the types of the Tables vary, the URef has no idea what type of +-- values it is supposed to store. So we use dynamic types. +-- +-- Since it is an updatable list, it is an IORef, which we also use to compare +-- two 'URef's. The second part is just the value the URef is pointing at (this +-- can never change anyway since references are unmutable). +-- +-- FIXME: why IORef? it should maybe be STRef? +-- Besides: Is it guaranteed that the values of an IORef +-- are not changed by the garbage collector? +data URef a + = URef (IORef [(URefTableTag, UDynamic)]) a + +instance Eq (URef a) where + URef r1 _ == URef r2 _ = r1 == r2 + +instance Show a => Show (URef a) where + showsPrec _ (URef _ a) = showChar '{' . shows a . showChar '}' + + +-- | Create a new Unsafe Unmutable Reference to a Haskell object +-- +-- This operation, as explained in the Observable sharing paper, can cuase +-- side-effects, since the value returned (the 'URef') is not determined by +-- the arguments of the function (i.e. different calls to 'newURef' with +-- the same argument return different 'URef's). +newURef :: a -> URef a +newURef a = unsafePerformIO $ + do r <- newIORef [] + return (URef r a) +{-# NOINLINE newURef #-} + +-- | Read the value pointed by the 'URef'. +readURef :: URef a -> a +readURef (URef _ a) = a + +-------------- +-- URefTableIO +-------------- + +-- | A unique identifier which univocally designates a table +type URefTableTag + = IORef () + + +-- | A 'URefTable' a b +-- +-- * Unsafe References to a value of type "a" (key of the table) +-- * Values of type "b" associated to each key +-- +-- Here is how we implement Tables of URefs: +-- +-- A Table is nothing but a unique tag, of type TableTag. TableTag can be +-- anything, as long as it is easy to create new ones, and we can compare them +-- for equality. (I chose IORef ()). +-- +-- So how do we store URefs in a Table? We do not want the Tables keeping +-- track of their URefs (which would be disastrous when the table becomes big, +-- and we would not have any garbage collection). +-- +-- Instead, every URef keeps track of the value it has in each table it is +-- in. This has the advantage that we have a constant lookup time (if the +-- number of Tables we are using is small), and we get garbage collection of +-- table entries for free. +newtype URefTableIO a b + = URefTableIO URefTableTag + deriving Eq + +-- | Create a new table +newURefTableIO :: IO (URefTableIO a b) +newURefTableIO = URefTableIO `fmap` newIORef () + +-- | Query the value corresponding to an 'URef' +queryIO :: URefTableIO a b -> URef a -> IO (Maybe b) +queryIO (URefTableIO t) (URef r _) = + do list <- readIORef r + return (unsafeFromUDyn `fmap` lookup t list) + +-- | Add an ('URef' a, b) pair entry to the table +addEntryIO :: URefTableIO a b -- ^ key of the entry + -> URef a + -> b -- ^ value of the entry + -> IO () +addEntryIO (URefTableIO t) (URef r _) b = + do list <- readIORef r + writeIORef r ((t, unsafeToUDyn b) : filter ((/= t) . fst) list) + +-------------- +-- URefTableST +-------------- + +-- | 'ST' version of 'URefTableIO' +newtype URefTableST s a b + = URefTableST (URefTableIO a b) + deriving Eq + +-- | 'ST' version of 'newURefTableIO' +newURefTableST :: ST s (URefTableST s a b) +newURefTableST = STU.unsafeIOToST (URefTableST `fmap` newURefTableIO) + +-- | 'ST' version of 'queryIO' +queryST :: URefTableST s a b -> URef a -> ST s (Maybe b) +queryST (URefTableST tab) r = STU.unsafeIOToST (queryIO tab r) + +-- | 'ST' version of 'addEntryIO' +addEntryST :: URefTableST s a b -> URef a -> b -> ST s () +addEntryST (URefTableST tab) r b = STU.unsafeIOToST (addEntryIO tab r b) + +-------------------------------- +-- Memoization of URef functions +-------------------------------- + +-- | Generates a memoizated version of a function taking 'URef' values +memoURef :: (URef a -> b) -> (URef a -> b) +memoURef f = unsafePerformIO . memoURefIO (return . f) +{-# NOINLINE memoURef #-} + +-- | 'IO' version of 'memoURef' +memoURefIO :: (URef a -> IO b) -> (URef a -> IO b) +memoURefIO f = unsafePerformIO $ + do tab <- newURefTableIO + let f' r = do mb <- queryIO tab r + case mb of + Just b -> do return b + Nothing -> fixIO $ \b -> + do addEntryIO tab r b + f r + return f' +{-# NOINLINE memoURefIO #-} + +-- | 'ST' version of 'memoURef' +memoURefST :: (URef a -> ST s b) -> (URef a -> ST s b) +memoURefST f = unsafePerformST $ + do tab <- newURefTableST + let f' r = do mb <- queryST tab r + case mb of + Just b -> do return b + Nothing -> fixST $ \b -> + do addEntryST tab r b + f r + return f' + where unsafePerformST = unsafePerformIO . STU.unsafeSTToIO +{-# NOINLINE memoURefST #-} diff --git a/src/ForSyDe/Deep/OSharing/UDynamic.hs b/src/ForSyDe/Deep/OSharing/UDynamic.hs new file mode 100644 --- /dev/null +++ b/src/ForSyDe/Deep/OSharing/UDynamic.hs @@ -0,0 +1,54 @@ +----------------------------------------------------------------------------- +-- | +-- Module : ForSyDe.Deep.OSharing +-- Copyright : (c) ES Group, KTH/ICT/ES 2007-2013 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : forsyde-dev@ict.kth.se +-- Stability : experimental +-- Portability : non-portable (GHC libraries) +-- +-- This module provides support for unsafe dynamic typing. +-- +-- Use with care. Normally, "Data.Dynamic" is preferred since it provides a +-- safe casting operation thanks to the use of "Data.Typeable". +-- +-- /This module is based on Lava2000/: +-- +----------------------------------------------------------------------------- +module ForSyDe.Deep.OSharing.UDynamic + (UDynamic, + unsafeToUDyn, + unsafeFromUDyn) + + where + +import Unsafe.Coerce (unsafeCoerce) +import GHC.Base (Any) + +-- | A value of type 'UDynamic' (from Unsafe Dynamic) can +-- implicitly any Haskell value. +-- +-- It is unsafe because, as opposed to 'Data.Dynamic', +--- it does not encapsule type information and does +-- it makes unsafe to cast a 'UDynamic' back to its original Haskell type. +data UDynamic = UDynamic Any + +-- | Converts an arbitrary value into an object of type 'UDynamic'. +-- It is unsafe because it does not provide type information during the +-- transformation +unsafeToUDyn :: a -> UDynamic +unsafeToUDyn a = UDynamic (unsafeCoerce a) + +-- | Converts a 'UDynamic' object back into an ordinary Haskell value. +-- It is unsafe because there is no way to unsure converting +-- back to the correct original Haskell type. Thus, this +-- function should be used with care since it can cuase disastrous errors. +-- +-- e.g. disastrousCast :: a -> b +-- disastrousCast = unsafeToDyn . unsafeFromDyn +-- +-- The following program would coredump +-- main = putStr (disastrousCast 1 :: String) +unsafeFromUDyn :: UDynamic -> a +unsafeFromUDyn (UDynamic obj) = unsafeCoerce obj diff --git a/src/ForSyDe/Deep/Process.hs b/src/ForSyDe/Deep/Process.hs new file mode 100644 --- /dev/null +++ b/src/ForSyDe/Deep/Process.hs @@ -0,0 +1,24 @@ +----------------------------------------------------------------------------- +-- | +-- Module : ForSyDe.Deep.Process +-- Copyright : (c) ES Group, KTH/ICT/ES 2007-2013 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : forsyde-dev@ict.kth.se +-- Stability : experimental +-- Portability : portable +-- +-- Publicly usable functions to create primitive processes. (Reexports +-- "ForSyDe.Process.SynchProc") +-- +----------------------------------------------------------------------------- +module ForSyDe.Deep.Process + (ProcFun, newProcFun, defArgVal, defArgPF, + ProcType, + module ForSyDe.Deep.Process.SynchProc) where + +import ForSyDe.Deep.Process.ProcFun (ProcFun, newProcFun, defArgVal, defArgPF) + +import ForSyDe.Deep.Process.SynchProc +import ForSyDe.Deep.Process.ProcType (ProcType) +import ForSyDe.Deep.Process.ProcType.Instances () diff --git a/src/ForSyDe/Deep/Process/Desugar.hs b/src/ForSyDe/Deep/Process/Desugar.hs new file mode 100644 --- /dev/null +++ b/src/ForSyDe/Deep/Process/Desugar.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE CPP, TemplateHaskell, Rank2Types #-} +module ForSyDe.Deep.Process.Desugar (desugarTransform) where + +import qualified Language.Haskell.TH as TH +import Language.Haskell.TH +import Control.Monad.State.Lazy + +import Data.Generics +import qualified Data.Param.FSVec as V + +{- +desugarTransform :: [Dec] -> Q [Dec] +desugarTransform = return +-} + +desugarTransform :: [Dec] -> Q [Dec] +--desugarTransform decs = foldAccDecs (mkM extractTypedLambda) decs +desugarTransform decs = (return decs) + =+=> extractTypedLambda + =+=> extractInfixOpSection + =+=> specializeHof + =+=> deleteSigE +#ifdef DEVELOPER + >>= dumpTree + where + dumpTree :: [Dec] -> Q [Dec] + dumpTree ts = do _ <- runIO $ mapM (print.ppr) ts + return ts +#endif + +-- Apply declaration-accumulating transformation +(=+=>) :: Typeable a => Q [Dec] -> (a -> DecAccM a) -> Q [Dec] +decs =+=> f = decs >>= (foldAccDecs $ mkM f) + +-- Extract all occurences of lambda expressions within type signatures +-- ... ((\... -> ...) :: ...) ... +-- Create functions declarations for them and replace the lambda expression +-- with a reference to the declaration: +-- ... lambda0 ... +-- where +-- lambda0 :: ... +-- lambda0 ... = ... +extractTypedLambda :: Exp -> DecAccM Exp +extractTypedLambda (SigE (LamE patterns lamBody) ty) = do + name <- lift $ newName "lambda" + let body = NormalB lamBody + signature = (SigD name ty) + function = (FunD name [(Clause patterns body [])]) + modify $ \declState -> signature:function:declState + return (VarE name) +extractTypedLambda e = return e + +-- Make a function out of a suitably annotated operator section +-- ... (+3)::Int32->Int32 ... +-- is transformed to +-- ... infix_section_0 ... +-- where infix_section_0 a = a+3 +extractInfixOpSection :: Exp -> DecAccM Exp +extractInfixOpSection (SigE exp@(InfixE _ _ _) ty) = do + name <- lift.newName $ "infix_section" + argname <- lift.newName $ "a" + let body = NormalB $ everywhere (mkT $ insertArgument argname) exp + patterns = [VarP argname] + signature = SigD name ty + function = FunD name [(Clause patterns body [])] + modify $ \declState -> signature:function:declState + return (VarE name) + where + insertArgument :: Name -> Exp -> Exp + insertArgument argn (InfixE Nothing op r) = InfixE (Just $ VarE argn) op r + insertArgument argn (InfixE l op Nothing) = InfixE l op (Just $ VarE argn) + insertArgument _ e = e +extractInfixOpSection e = return e + + +hofNames :: [TH.Name] +hofNames = [ + 'V.foldr, + 'V.foldl, + 'V.map, + 'V.zipWith, + 'V.zipWith3 + ] + +isHigherOrderFunctionName :: TH.Name -> Bool +isHigherOrderFunctionName n = elem n hofNames + +-- specializing extraction: +-- find all hof applications: (AppE (VarE hofName) (VarE fname)) +-- build specialized function definition in normal form +-- collect specialized declarations in state of DecAccM +-- replace application with call to specialized function +specializeHof :: Exp -> DecAccM Exp +-- arity=2 +specializeHof (SigE (AppE hofapp@(AppE (VarE hofName) (VarE argFunName)) arg1@(SigE _ argtype)) rettype) + | isHigherOrderFunctionName hofName = do + name <- lift.newName $ (nameBase hofName)++"_"++(nameBase argFunName) + argname <- lift.newName $ "v" + + let body = NormalB $ AppE hofapp (VarE argname) + patterns = [VarP argname] + signature = (SigD name (AppT (AppT ArrowT argtype) rettype)) + function = (FunD name [(Clause patterns body [])]) + modify $ \declState -> declState++[signature,function] + return (SigE (AppE (VarE name) arg1) rettype) +specializeHof e = return e + +-- Delete all the type signature expressions as they are not recognized during +-- translation +deleteSigE :: Exp -> DecAccM Exp +deleteSigE (SigE e _) = return e +deleteSigE e = return e + +type DecAccM t = StateT [Dec] Q t + +-- stateful fold over the tree. Applies f everywhere within the tree, +-- collecting additional declarations during traversal, and adding them to the +-- corresponding scope +foldAccDecs :: GenericM DecAccM -> [Dec] -> Q [Dec] +foldAccDecs transform decs = mapM apply decs + where + apply :: Dec -> Q Dec + apply (FunD name [Clause pat body decls]) = do + (newBody,newDecls) <- runStateT (everywhereM transform body) [] + transfDecls <- foldAccDecs transform decls + return $ FunD name [Clause pat newBody (transfDecls++newDecls)] + apply (ValD pat body decls) = do + (newBody,newDecls) <- runStateT (everywhereM transform body) [] + transfDecls <- foldAccDecs transform decls + return $ ValD pat newBody (transfDecls++newDecls) + apply d = return d diff --git a/src/ForSyDe/Deep/Process/Desugar.hs-boot b/src/ForSyDe/Deep/Process/Desugar.hs-boot new file mode 100644 --- /dev/null +++ b/src/ForSyDe/Deep/Process/Desugar.hs-boot @@ -0,0 +1,7 @@ +{-# LANGUAGE Rank2Types #-} +module ForSyDe.Deep.Process.Desugar (desugarTransform) where + +import Language.Haskell.TH +import Data.Generics + +desugarTransform :: [Dec] -> Q [Dec] diff --git a/src/ForSyDe/Deep/Process/ProcFun.hs b/src/ForSyDe/Deep/Process/ProcFun.hs new file mode 100644 --- /dev/null +++ b/src/ForSyDe/Deep/Process/ProcFun.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE TemplateHaskell #-} +----------------------------------------------------------------------------- +-- | +-- Module : ForSyDe.Deep.Process.ProcFun +-- Copyright : (c) ES Group, KTH/ICT/ES 2007-2013 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : forsyde-dev@ict.kth.se +-- Stability : experimental +-- Portability : non-portable (Template Haskell) +-- +-- This module provides a type ('ProcFun') to store the functions passed +-- to process constructors. +-- +----------------------------------------------------------------------------- +module ForSyDe.Deep.Process.ProcFun + (ProcFun(..), + ProcFunAST(..), + newProcFun, + defArgVal, + defArgPF, + TypedProcFun(..), + TypedProcFunAST(..), + procFun2Dyn, + contProcFun2Dyn, +) where + +import ForSyDe.Deep.Process.ProcType +import ForSyDe.Deep.Process.Desugar (desugarTransform) +import ForSyDe.Deep.Process.ProcVal (ProcValAST, mkProcValAST) +import ForSyDe.Deep.ForSyDeErr + +import Language.Haskell.TH hiding (Loc) +import Language.Haskell.TH.Syntax hiding (Loc) +import Language.Haskell.TH.LiftInstances () +import Data.Dynamic +import Data.Maybe (fromJust) +import Data.Set (Set) +import Data.Typeable.FSDTypeRepLib (FSDTypeRep, fsdTy) + +----------- +-- ProcFun +----------- + +-- | A Process Function +data ProcFun a = + ProcFun {val :: a, -- ^ Value of the function + pfloc :: Loc, -- ^ where was it created + ast :: ProcFunAST} -- ^ AST of the function + + + +-- | A process Function AST +data ProcFunAST = + ProcFunAST {name :: Name, -- ^ Function Name + -- (FIXME: maybe just a String?) + cls :: [Clause], -- ^ Function clauses + pars :: [DefArg]} -- ^ Default parameters + + +-- | A process Function default argument +-- Either a process function AST or a value AST +data DefArg = FunAST ProcFunAST | ValAST ProcValAST + + + +-- | Sets a default value for an argument of the process function +defArgVal :: (Lift a, ProcType a) => ProcFun (a -> b) -> a -> ProcFun b +-- FIXME: inneficient, use a queue data structure +defArgVal pf v = + pf{ ast = astPF {pars = ((pars astPF) ++ [ValAST (mkProcValAST v)])}, + val = (val pf) v} + where astPF = ast pf + +-- | Sets a default value for an argument of the process function +-- when the argument is a process function itself +defArgPF :: ProcFun (a -> b) -> ProcFun a -> ProcFun b +defArgPF pf v = pf{ ast = astPF {pars = ((pars astPF) ++ [FunAST (ast v)])}, + val = (val pf) (val v)} + where astPF = ast pf + +-- | Template Haskell constructor for 'ProcFun', here is an example on how to use it +-- +-- @ +-- plus1Fun :: ProcFun (Int -> Int) +-- plus1Fun = $(newProcFun [d| plus1 :: Int -> Int +-- plus1 n = n + 1 |]) +-- @ +newProcFun :: Q [Dec] -> ExpQ +newProcFun fDecQs = do + fDecsRaw <- fDecQs + fDecs <- desugarTransform fDecsRaw + -- Check for the declarations to be correct + (name, cls) <- recover (currErr $ IncorrProcFunDecs fDecs) + (checkDecs fDecs) + -- Generate the main expression + loc <- qLocation + let errInfo = loc_module loc in do + exp <- [| let fName = name + fClauses = cls + in ProcFun $(varE name) + errInfo + (ProcFunAST fName fClauses []) |] + -- Add the function declarations to the expression + return $ LetE fDecs exp + where currErr = qError "newProcFun" + +---------------- +-- TypedProcFun +---------------- + + +-- | A ProcFun bundled with its type representation. This type is not +-- exported to the end user. Only used internally. +data TypedProcFun a = + TypedProcFun {tval :: a, -- ^ Value of the function + tpfloc :: Loc, + tast :: TypedProcFunAST} -- ^ AST of the function + + +-- | A ProcFunAST bundled with its type representation: +-- Why a TypeRep and not the Type provided by Template Haskell? +-- We could use the type signature provided by TH but ... +-- 1) We don't want to force the user to provide a signature +-- 2) We don't want to handle polymorphic types. We just want the +-- monomorphic type used by the process using the procfun. +-- Why not just including the 'TypeRep' in ProcFunAST? +-- We need the context of the process to know what monomorphic types are +-- going to be used. Thus it is imposible to guess the TypeRep within +-- the code of newProcFun. +data TypedProcFunAST = + TypedProcFunAST {tptyp :: FSDTypeRep, -- function type + tpEnums :: Set EnumAlgTy, -- enumerated types associated + -- with the function + tpast :: ProcFunAST} + +-- | transform a ProcFun into a Dynamic TypedProcFun +procFun2Dyn :: Typeable a => Set EnumAlgTy -> ProcFun a -> TypedProcFun Dynamic +procFun2Dyn s (ProcFun v l a) = + TypedProcFun (toDyn v) l (TypedProcFunAST (fsdTy (typeOf v)) s a) + +-- FIXME: probably not needed +-- | tranform the arguments and return value of +-- a ProcFun to dynamic +contProcFun2Dyn :: (Typeable1 container, + Typeable b, + Functor container, + Typeable a) => + Set EnumAlgTy -> + ProcFun (container a -> b) -> + TypedProcFun (container Dynamic -> Dynamic) +contProcFun2Dyn s (ProcFun v l a) = + TypedProcFun (fmapDyn v) l (TypedProcFunAST (fsdTy (typeOf v)) s a) + where fmapDyn f cont = toDyn (f (fmap (fromJust.fromDynamic) cont)) + + +---------------------------- +-- Internal Helper Functions +---------------------------- + +-- | Check the decarations passed to newProcFun to be correct +checkDecs :: [Dec] -> Q (Name, [Clause]) +checkDecs [FunD name2 cls] = return (name2, cls) +-- in case a signature is provided +checkDecs [SigD name1 _, FunD name2 cls] | name1 == name2 = + return (name1, cls) +checkDecs _ = qGiveUp name + where name = "ForSyDe.Process.ProcFun.checkDecs" diff --git a/src/ForSyDe/Deep/Process/ProcType.hs b/src/ForSyDe/Deep/Process/ProcType.hs new file mode 100644 --- /dev/null +++ b/src/ForSyDe/Deep/Process/ProcType.hs @@ -0,0 +1,178 @@ +{-# LANGUAGE TemplateHaskell, PolyKinds, CPP#-} +#if __GLASGOW_HASKELL__ >= 800 +{-# OPTIONS_GHC -freduction-depth=64 #-} +#else +{-# OPTIONS_GHC -fcontext-stack=64 #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : ForSyDe.Deep.Process.ProcType +-- Copyright : (c) ES Group, KTH/ICT/ES 2008-2013 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : forsyde-dev@ict.kth.se +-- Stability : experimental +-- Portability : non-portable (non-standard instances) +-- +-- This module includes and exports, the internal definition, instantiations +-- and related types of 'ProcType', a class used to constrain the arguments +-- taken by process constructors. +----------------------------------------------------------------------------- +module ForSyDe.Deep.Process.ProcType ( + EnumAlgTy(..), + ProcType(..), + genTupInstances) where + +import Control.Monad (replicateM) +import Data.List (intersperse) +import Data.Data +import Data.Set (Set, union) +import Language.Haskell.TH +import Language.Haskell.TH.Syntax (Lift(..)) +import Text.ParserCombinators.ReadP + +-- | Data type describing an algebraic enumerated type (i.e. an algrebraic +-- type whose data constructors have arity zero) +data EnumAlgTy = EnumAlgTy String [String] + deriving Show + +instance Eq EnumAlgTy where + (EnumAlgTy d1 _) == (EnumAlgTy d2 _) = d1 == d2 + +instance Ord EnumAlgTy where + (EnumAlgTy d1 _) `compare` (EnumAlgTy d2 _) = d1 `compare` d2 + +-- | Class used to constrain the arguments (values and 'ProcFun's) taken by +-- process constructors +class (Data a, Lift a) => ProcType a where + -- | Get the associated enumerated type-definitions of certain value, + -- taking nesting in account. + -- + -- For example: + -- + -- > module MyMod where + -- > + -- > data Colour = Blue | Red + -- > deriving (Data, Typeable) + -- > data Shapes = Circle | Square + -- > deriving (Data, Typeable) + -- > + -- > getEnums (Prst Blue, Circle) = + -- > fromList [EnumAlgTy "MyMod.Colour" ["Blue", "Red"], + -- > EnumAlgTy "MyMod.Shapes" ["Circle", "Square"]] + getEnums :: a -> Set EnumAlgTy + -- | Read a process type + readProcType :: ReadP a + +-- Function to automatically generate ProcType, Data, and Lift +-- instances for tuples (with 2 or more elements) with Template Haskell. For +-- example, in the case of 2 elements, the code generated would be: +-- +-- @ +-- instance (ProcType o1, ProcType o2) => ProcType (o1, o2) where +-- getEnums _ = getEnums (undefined :: a) `union` getEnums (undefined :: b) +-- readProcType = do +-- skipSpaces >> char '(' +-- o1 <- readProcType +-- skipSpaces >> char ',' +-- o2 <- readProcType +-- skipSpaces >> char ')' +-- return (o1,o2) +-- +-- deriving Data and Lift is only neccessary for tuples with more than 7 +-- elements: +-- +-- instance (Data o1, Data o2) => Data (o1, o2) where +-- gfoldl k z (o1, o2) = z (,) `k` o1 `k` o2 +-- gunfold k z _ = k (k (z (,) )) +-- toConstr a = mkConstr (dataTypeOf a) "(,)" [] Prefix +-- dataTypeOf a = mkDataType "Data.Tuple.(,)" [toConstr a] +-- +-- FIXME: This won't be necessary once the Data a => Lift a instance is created +-- +-- instance (Lift o1, Lift o2) => Lift (o1, o2) where +-- lift (o1, o2) = tupE [lift o1, lift o2] +-- @ +genTupInstances :: Int -- ^ number of outputs to generate + -> Q [Dec] +genTupInstances n = do + -- Generate N o names + outNames <- replicateM n (newName "o") + let tupType = foldl accumApp (tupleT n) outNames + accumApp accumT vName = accumT `appT` varT vName + if n <= 7 + then sequence [genProcTypeIns outNames tupType] + else sequence [genDataIns outNames tupType, + genLiftIns outNames tupType, + genProcTypeIns outNames tupType] + + where + undef t = sigE [| undefined |] (varT t) + genProcTypeIns :: [Name] -> Q Type -> Q Dec + genProcTypeIns names tupType = do + let getEnumsExpr = + foldr1 (\e1 e2 -> infixE (Just e1) + (varE 'union) + (Just e2) ) + (map (\n -> varE 'getEnums `appE` undef n) names) + getEnumsD = funD 'getEnums [clause [wildP] (normalB getEnumsExpr) []] + readProcTypeExpr = doE $ + bindS wildP [| skipSpaces >> char '(' |] : + (intersperse (bindS wildP [| skipSpaces >> char ',' |]) + (map (\n -> bindS (varP n) [| readProcType |]) names) ++ + [bindS wildP [| skipSpaces >> char ')' |], + noBindS [| return $(tupE $ map varE names) |] ] ) + readProcTypeD = funD 'readProcType + [clause [] (normalB readProcTypeExpr) []] + procTypeCxt = map (\vName -> appT (conT ''ProcType) (varT vName)) names ++ + map (\vName -> appT (conT ''Data) (varT vName)) names ++ + map (\vName -> appT (conT ''Lift) (varT vName)) names + instanceD (cxt procTypeCxt) + (conT ''ProcType `appT` tupType) + [getEnumsD, readProcTypeD] + genDataIns :: [Name] -> Q Type -> Q Dec + genDataIns names tupType = do + k <- newName "k" + z <- newName "z" + a <- newName "a" + let tupCons = conE tupName + tupName = tupleDataName n + gfoldlExpr = foldl (\acum n -> infixE (Just acum) + (varE k) + (Just $ varE n)) + (varE z`appE` tupCons) + names + gfoldlD = funD 'gfoldl + [clause [varP k, varP z, tupP (map varP names)] + (normalB gfoldlExpr) []] + gunfoldExpr = let nKs 0 = (varE z `appE` tupCons) + nKs n = varE k `appE` (nKs (n-1)) + in nKs n + gunfoldD = funD 'gunfold + [clause [varP k, varP z, wildP] (normalB gunfoldExpr) []] + toConstrExpr = [| mkConstr (dataTypeOf $(varE a)) + $(litE $ stringL (nameBase tupName)) + [] + Prefix |] + toConstrD = funD 'toConstr + [clause [varP a] (normalB toConstrExpr) []] + dataTypeOfExpr = [| mkDataType $(litE $ stringL (show tupName)) + [toConstr $(varE a)] |] + dataTypeOfD = funD 'dataTypeOf + [clause [varP a] (normalB dataTypeOfExpr) []] + dataCxt = map (\vName -> appT (conT ''Data) (varT vName)) names + instanceD (cxt dataCxt) + (conT ''Data `appT` tupType) + [gfoldlD, gunfoldD, toConstrD, dataTypeOfD] + genLiftIns :: [Name] -> Q Type -> Q Dec + genLiftIns names tupType = do + let liftExpr = + varE 'tupE `appE` listE (map (\n -> varE 'lift `appE` varE n) names) + liftD = funD 'lift + [clause [tupP (map varP names)] (normalB liftExpr) []] + liftCxt = map (\vName -> appT (conT ''Lift) (varT vName)) names + instanceD (cxt liftCxt) + (conT ''Lift `appT` tupType) + [liftD] + + diff --git a/src/ForSyDe/Deep/Process/ProcType/Instances.hs b/src/ForSyDe/Deep/Process/ProcType/Instances.hs new file mode 100644 --- /dev/null +++ b/src/ForSyDe/Deep/Process/ProcType/Instances.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE ScopedTypeVariables, FlexibleInstances, + UndecidableInstances, TemplateHaskell #-} +----------------------------------------------------------------------------- +-- | +-- Module : ForSyDe.Deep.System.SysFun.Instances +-- Copyright : (c) ES Group, KTH/ICT/ES 2007-2013 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : forsyde-dev@ict.kth.se +-- Stability : experimental +-- Portability : non-portable (Template Haskell) +-- +-- This module provides the 'ProcType' instances (and 'Data', +-- 'Typeable' and 'Lift' when necessary) . It cannot be included in +-- "ForSyDe.Process.ProcType" directly due to a Template Haskell bug +-- which prevents Template Haskell from executing functions defined in +-- the same module: +-- +----------------------------------------------------------------------------- +module ForSyDe.Deep.Process.ProcType.Instances where + +import ForSyDe.Deep.Config (maxTupleSize) +import ForSyDe.Deep.Process.ProcType +import ForSyDe.Deep.AbsentExt + +import Data.TypeLevel.Num.Sets (Nat, toInt) +import Data.Param.FSVec (FSVec, reallyUnsafeVector) + + +import Data.Data +import Control.Monad (liftM, liftM2, mzero) +import Text.ParserCombinators.ReadP +import Data.Set (empty, singleton) +import Language.Haskell.TH.Syntax (Lift(..), runIO) + +------------------------------------------------------------- +-- Checking if a member of Data belongs to an enumerated type +------------------------------------------------------------- + +-- | Phony type used to check if a data constructor is enumerate (has ) +newtype IsConsEnum a = IsConsEnum {unIsConsEnum :: Bool} + +-- | Tell if a member of "Data" belongs to an enumerated type +isConsEnum :: Data a => Constr -> IsConsEnum a +isConsEnum = gunfold (\_ -> IsConsEnum False) (\_ -> IsConsEnum True) + +-- | Tell if a member of "Data" belongs to an enumerated type +-- and return its description. +getEnumAlgTy :: forall a . (Typeable a, Data a) => a -> Maybe EnumAlgTy +getEnumAlgTy a = case dataTypeRep dt of + AlgRep cons -> do + strs <- mapM (\c -> toMaybe (unIsConsEnum (isConsEnum c :: IsConsEnum a)) + (showConstr c)) cons + return (EnumAlgTy dn strs) + _ -> Nothing + where dt = dataTypeOf a + tycon = typeRepTyCon.typeOf $ a + modName = tyConModule tycon + baseName = tyConName tycon + dn = modName ++ "." ++ baseName + toMaybe bool c = if bool then Just c else Nothing + +------------- +-- Instances +------------- + +instance {-# OVERLAPPABLE #-} (Lift a, Data a) => ProcType a where + getEnums _ = maybe empty singleton (getEnumAlgTy (undefined :: a)) + -- We add parenthesis and try to use gread. + -- In addition, since gread is broken for unit (), we create or own parser + readProcType = do skipSpaces + -- get all the input while no separator is found + str <- munch1 (\c -> not (elem c " ,()<>" )) + gReadUnaryCons str + where -- Generically read a unary constructor (possibly an integer, float etc .. ) + gReadUnaryCons :: forall a . Data a => String -> ReadP a + gReadUnaryCons str = do + cons <- maybe mzero return $ readConstr (dataTypeOf (undefined :: a)) str + fromConstrM (fail "readProcType: non-unary constructor found") cons + + + +instance (Typeable s, Nat s, ProcType a) => ProcType (FSVec s a) where + getEnums _ = getEnums (undefined :: a) + readProcType = do + skipSpaces + _ <- char '<' + elems <- countSepBy (toInt (undefined :: s)) + readProcType + (skipSpaces >> char ',' >> skipSpaces) + _ <- char '>' + return (reallyUnsafeVector elems) + where countSepBy n p sep = + if n == 0 + then return [] + else liftM2 (:) p (sequence (replicate (n-1) (sep >> p))) + + +instance ProcType a => ProcType (AbstExt a) where + getEnums _ = getEnums (undefined :: a) + readProcType = skipSpaces >> (absP <++ prstP) + where absP = do _ <- string "Abst" + return Abst + prstP = do _ <- string "Prst" + skipSpaces + v <- readProcType + return $ Prst v + +-- Tuple instances +$(let concatMapM f xs = liftM concat (mapM f xs) + msg = "Generating and compiling " ++ show (maxTupleSize -2) ++ + " tuple instances of " ++ + show ''ProcType ++ + ", this might take some time ... \n" + in runIO (putStrLn $ msg) >> + concatMapM genTupInstances [2..maxTupleSize]) + + + diff --git a/src/ForSyDe/Deep/Process/ProcVal.hs b/src/ForSyDe/Deep/Process/ProcVal.hs new file mode 100644 --- /dev/null +++ b/src/ForSyDe/Deep/Process/ProcVal.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE ScopedTypeVariables #-} +---------------------------------------------------------------------------- +-- | +-- Module : ForSyDe.Deep.Process.ProcVal +-- Copyright : (c) ES Group, KTH/ICT/ES 2007-2013 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : forsyde-dev@ict.kth.se +-- Stability : experimental +-- Portability : non-portable (Template Haskell) +-- +-- This module provides a type ('ProcVal') to store the value arguments passed +-- to process constructors. +-- +----------------------------------------------------------------------------- +module ForSyDe.Deep.Process.ProcVal where + + +import ForSyDe.Deep.Process.ProcType + +import Data.Typeable (typeRep) +import Data.Dynamic (toDyn, Dynamic) +import Data.Set +import Data.Proxy +import Language.Haskell.TH (Exp, runQ) +import Language.Haskell.TH.Syntax (Lift(..)) +import System.IO.Unsafe (unsafePerformIO) +import Data.Typeable.FSDTypeRepLib (fsdTy, FSDTypeRep) + + +data ProcVal = ProcVal + {dyn :: Dynamic, -- Dynamic value + valAST :: ProcValAST} -- its AST + +data ProcValAST = ProcValAST + {expVal :: Exp, -- Its AST representation + expTyp :: FSDTypeRep, -- Type of the expression + expEnums :: Set EnumAlgTy} -- Enumerated types associated + -- with the expression + +-- | 'ProcVal' constructor +mkProcVal :: (Lift a, ProcType a) => a -> ProcVal +-- FIXME: would unsafePerformIO cause any harm to get the exp out of the +-- Q monad in this context? +mkProcVal val = ProcVal (toDyn val) (mkProcValAST val) + +mkProcValAST :: (Lift a, ProcType a) => a -> ProcValAST +-- FIMXE: the unsafePerformIO won't be needed once the Data a => Lift a +-- instance is created +mkProcValAST (val :: x) = ProcValAST (unsafePerformIO.runQ.lift $ val) + (fsdTy.typeRep $ (Proxy :: Proxy x)) + (getEnums val) diff --git a/src/ForSyDe/Deep/Process/SynchProc.hs b/src/ForSyDe/Deep/Process/SynchProc.hs new file mode 100644 --- /dev/null +++ b/src/ForSyDe/Deep/Process/SynchProc.hs @@ -0,0 +1,899 @@ +{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, RelaxedPolyRec, + PatternGuards #-} +-- The PatternGuards are used to hush innapropiate compiler warnings +-- see http://hackage.haskell.org/trac/ghc/ticket/2017 +----------------------------------------------------------------------------- +-- | +-- Module : ForSyDe.Deep.Process.SynchProc +-- Copyright : (c) ES Group, KTH/ICT/ES 2007-2013 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : forsyde-dev@ict.kth.se +-- Stability : experimental +-- Portability : non-portable (Template Haskell) +-- +-- This module provides the synchronous process constructors of +-- ForSyDe and some useful synchronous processes. +-- +----------------------------------------------------------------------------- +module ForSyDe.Deep.Process.SynchProc ( + -- * Combinational process constructors + -- | Combinational process constructors are used for processes that do not + -- have a state. + constSY, mapSY, zipWithSY, zipWith3SY, + zipWith4SY, zipWith5SY, zipWith6SY, zipWithxSY, + -- * Sequential process constructors + -- | Sequential process constructors are used for processes that have a state. + -- One of the input parameters is the initial state. + delaySY, delaynSY, + scanlSY, scanl2SY, scanl3SY, scanl4SY, + scanldSY, scanld2SY, scanld3SY, scanld4SY, + mooreSY, moore2SY, moore3SY, moore4SY, + mealySY, mealy2SY, mealy3SY, mealy4SY, + sourceSY, filterSY, fillSY, holdSY, + -- * Synchronous Processes + -- | The library contains a few simple processes that are applicable to many + -- cases. + whenSY, zipSY, zip3SY, zip4SY, zip5SY, zip6SY, + unzipSY, unzip3SY, unzip4SY, unzip5SY, unzip6SY, + zipxSY, unzipxSY, mapxSY, + fstSY, sndSY, groupSY) where + + +import ForSyDe.Deep.Ids +import ForSyDe.Deep.Process.ProcType +import ForSyDe.Deep.Process.ProcType.Instances() +import ForSyDe.Deep.Process.ProcFun +import ForSyDe.Deep.Process.ProcVal +import ForSyDe.Deep.OSharing +import ForSyDe.Deep.Netlist +import ForSyDe.Deep.AbsentExt + +import qualified Data.Param.FSVec as V +import Data.Param.FSVec hiding ((++), map) +import Data.TypeLevel (Nat, toInt) +import Data.Typeable.FSDTypeRepLib + +import Data.Set (union) +import Data.Maybe +import Data.Dynamic + +----------------------------------- +-- Synchronous Process Constructors +----------------------------------- + +---------------------------------------- +-- -- +-- COMBINATIONAL PROCESS CONSTRUCTORS -- +-- -- +---------------------------------------- + + +-- | Creates a constant process. A process which outputs the +-- same signal value in every clock cycle. +constSY :: ProcType a => + ProcId -- ^ Identifier of the process + -> a -- ^ Value to output + -> Signal a -- ^ Resulting output signal +constSY id v = Signal (newNodeOutSig nodeRef ConstOut) + where nodeRef = newURef $ Proc id $ Const (mkProcVal v) + + + + +-- | The process constructor 'mapSY' takes an identifier and a +-- combinational function as arguments and returns a process with one +-- input signal and one output signal. +mapSY :: forall a b . (ProcType a, ProcType b) => + ProcId -- ^ Identifier of the process + -> ProcFun (a -> b) -- ^ Function applied to the input signal + -- in every cycle + -> Signal a -- ^ Input 'Signal' + -> Signal b -- ^ Output 'Signal' +mapSY id f s = Signal (newNodeOutSig nodeRef ZipWithNSYOut) + where nodeRef = newURef $ Proc id $ ZipWithNSY dynPF [unSignal s] + dynPF = procFun2Dyn (getEnums (undefined ::a) `union` + getEnums (undefined ::b)) + f + +-- | The process constructor 'zipWithSY' takes an identifier and a +-- combinational function as arguments and returns a process with +-- two input signals and one output signal. +zipWithSY :: forall a b c . (ProcType a, ProcType b, ProcType c) => + ProcId -- ^ Identifier of the process + -> ProcFun (a -> b -> c) -- ^ Function applied to the input signals + -- in every cycle + -> Signal a -- ^ First input 'Signal' + -> Signal b -- ^ Second input 'Signal' + -> Signal c -- ^ Output Signal +zipWithSY id f s1 s2 = Signal (newNodeOutSig nodeRef ZipWithNSYOut) + where nodeRef = newURef $ Proc id $ + ZipWithNSY dynPF [unSignal s1,unSignal s2] + dynPF = procFun2Dyn (getEnums (undefined ::a) `union` + getEnums (undefined ::b) `union` + getEnums (undefined ::c) ) + f + +-- | The process constructor 'zipWith3SY' takes an identifier and a +-- combinational function as arguments and returns a process with +-- three input signals and one output signal. +zipWith3SY :: forall a b c d. + (ProcType a, ProcType b, ProcType c, ProcType d) => + ProcId -- ^ Identifier of the process + -> ProcFun (a -> b -> c -> d) -- ^ Function applied to the input + -- signals in every cycle + -> Signal a -- ^ First input 'Signal' + -> Signal b -- ^ Second input 'Signal' + -> Signal c -- ^ Third input 'Signal' + -> Signal d -- ^ Output Signal +zipWith3SY id f s1 s2 s3 = Signal (newNodeOutSig nodeRef ZipWithNSYOut) + where nodeRef = newURef $ Proc id $ + ZipWithNSY dynPF + [unSignal s1, + unSignal s2, + unSignal s3] + dynPF = procFun2Dyn (getEnums (undefined ::a) `union` + getEnums (undefined ::b) `union` + getEnums (undefined ::c) `union` + getEnums (undefined ::d)) + f + + +-- | The process constructor 'zipWith4SY' takes an identifier and a +-- combinational function as arguments and returns a process with +-- four input signals and one output signal. +zipWith4SY ::forall a b c d e. + (ProcType a, ProcType b, ProcType c, ProcType d, ProcType e) => + ProcId -- ^ Identifier of the process + -> ProcFun (a -> b -> c -> d -> e) -- ^ Function applied to the + -- input signals in every cycle + -> Signal a -- ^ First input 'Signal' + -> Signal b -- ^ Second input 'Signal' + -> Signal c -- ^ Third input 'Signal' + -> Signal d -- ^ Fourth input 'Signal' + -> Signal e -- ^ Output Signal +zipWith4SY id f s1 s2 s3 s4 = Signal (newNodeOutSig nodeRef ZipWithNSYOut) + where nodeRef = newURef $ Proc id $ + ZipWithNSY dynPF + [unSignal s1, + unSignal s2, + unSignal s3, + unSignal s4] + dynPF = procFun2Dyn (getEnums (undefined ::a) `union` + getEnums (undefined ::b) `union` + getEnums (undefined ::c) `union` + getEnums (undefined ::d) `union` + getEnums (undefined ::e) ) + f +-- | The process constructor 'zipWith5SY' takes an identifier and a +-- combinational function as arguments and returns a process with +-- five input signals and one output signal. +zipWith5SY :: forall a b c d e f. + (ProcType a, ProcType b, ProcType c, ProcType d, ProcType e, + ProcType f) => + ProcId -- ^ Identifier of the process + -> ProcFun (a -> b -> c -> d -> e -> f) + -- ^ Function applied to the + -- input signals in every cycle + -> Signal a -- ^ First input 'Signal' + -> Signal b -- ^ Second input 'Signal' + -> Signal c -- ^ Third input 'Signal' + -> Signal d -- ^ Fourth input 'Signal' + -> Signal e -- ^ Fifth input 'Signal' + -> Signal f -- ^ Output Signal +zipWith5SY id f s1 s2 s3 s4 s5 = Signal (newNodeOutSig nodeRef ZipWithNSYOut) + where nodeRef = newURef $ Proc id $ + ZipWithNSY dynPF + [unSignal s1, + unSignal s2, + unSignal s3, + unSignal s4, + unSignal s5] + dynPF = procFun2Dyn (getEnums (undefined ::a) `union` + getEnums (undefined ::b) `union` + getEnums (undefined ::c) `union` + getEnums (undefined ::d) `union` + getEnums (undefined ::e) `union` + getEnums (undefined ::f) ) + f + + +-- | The process constructor 'zipWith6SY' takes an identifier and a +-- combinational function as arguments and returns a process with +-- five input signals and one output signal. +zipWith6SY :: forall a b c d e f g. + (ProcType a, ProcType b, ProcType c, ProcType d, ProcType e, + ProcType f, ProcType g) => + ProcId -- ^ Identifier of the process + -> ProcFun (a -> b -> c -> d -> e -> f -> g) + -- ^ Function applied to the + -- input signals in every cycle + -> Signal a -- ^ First input 'Signal' + -> Signal b -- ^ Second input 'Signal' + -> Signal c -- ^ Third input 'Signal' + -> Signal d -- ^ Fourth input 'Signal' + -> Signal e -- ^ Fifth input 'Signal' + -> Signal f -- ^ Sixth input 'Signal' + -> Signal g -- ^ Output Signal +zipWith6SY id f s1 s2 s3 s4 s5 s6 = Signal (newNodeOutSig nodeRef ZipWithNSYOut) + where nodeRef = newURef $ Proc id $ + ZipWithNSY dynPF + [unSignal s1, + unSignal s2, + unSignal s3, + unSignal s4, + unSignal s5, + unSignal s6] + dynPF = procFun2Dyn (getEnums (undefined ::a) `union` + getEnums (undefined ::b) `union` + getEnums (undefined ::c) `union` + getEnums (undefined ::d) `union` + getEnums (undefined ::e) `union` + getEnums (undefined ::f) `union` + getEnums (undefined ::g) ) + f + +-- | The process constructor 'mapxSY' creates a process network that maps a +-- function onto all signals in a vector of signals. The identifier is used +-- as the identifier prefix of the processes created (a number starting with 1 +-- will be appended to each identifier) +mapxSY :: (Nat s, ProcType a, ProcType b) => + ProcId + -> ProcFun (a -> b) + -> FSVec s (Signal a) + -> FSVec s (Signal b) +mapxSY id f = V.zipWith (\n s -> mapSY (id ++ show n) f s) + (V.reallyUnsafeVector [(1::Int)..]) + +-- | The process constructor 'zipWithxSY' works as 'zipWithSY', but takes a +-- vector of signals as input. +zipWithxSY :: forall s a b . + (Nat s, Typeable s, ProcType a, ProcType b) => + ProcId + -> ProcFun (FSVec s a -> b) + -> FSVec s (Signal a) + -> Signal b +zipWithxSY id f sv = Signal (newNodeOutSig nodeRef ZipWithxSYOut) + where nodeRef = newURef $ Proc id $ + ZipWithxSY (vecProcFun2List dynPF) + (map unSignal (V.fromVector sv)) + -- Transform the vector argument of a procfun into a list + vecProcFun2List :: TypedProcFun (FSVec s' a' -> b') -> + TypedProcFun ([a'] -> b') + vecProcFun2List f = f{tval = \x -> (tval f) (reallyUnsafeVector x)} + dynPF = contProcFun2Dyn (getEnums (undefined ::a) `union` + getEnums (undefined ::b) ) + f + + +------------------------------------- +-- -- +-- SEQUENTIAL PROCESS CONSTRUCTORS -- +-- -- +------------------------------------- + +-- | The process constructor 'delaySY' delays the signal one event cycle +-- by introducing an initial value at the beginning of the output signal. +-- Note, that this implies that there is one event (the first) at the +-- output signal that has no corresponding event at the input signal. +-- One could argue that input and output signals are not fully synchronized, +-- even though all input events are synchronous with a corresponding output +-- event. However, this is necessary to initialize feed-back loops. +delaySY :: ProcType a => + ProcId -- ^ Identifier of the process + -> a -- ^ Initial value + -> Signal a -- ^ 'Signal' to be delayed + -> Signal a -- ^ Resulting delayed 'Signal' +delaySY id v s = Signal (newNodeOutSig nodeRef DelaySYOut) + where procVal = mkProcVal v + nodeRef = newURef $ Proc id $ DelaySY procVal (unSignal s) + + +-- | The process constructor 'delaynSY' delays the signal n events by +-- introducing n identical default values. It creates a chain of 'delaySY' +-- processes. +delaynSY :: ProcType a => + ProcId -- ^ Identifier + -> a -- ^Initial state + -> Int -- ^ Number of Delay cycles + -> Signal a -- ^Input signal + -> Signal a -- ^Output signal +delaynSY id e n s = (\(a,_,_) -> a) $ delaynSYacum (s, 1, n) + where + delaynSYacum acum@(lastSig, curr, max) + | curr > max = acum + | otherwise = + delaynSYacum (delaySY (id ++ "_" ++ show curr) e lastSig, curr+1, max) + + + +-- | The process constructor 'scanlSY' is used to construct a finite state +-- machine process without output decoder. It takes an initial value and +-- a function for the next state decoder. The process constructor behaves +-- similar to the Haskell prelude function 'scanlSY' and has the value of +-- the new state as its output value as illustrated by the +-- following example. +-- +-- This is in contrast to the function 'scanldSY', which has its current +-- state as its output value. +scanlSY :: (ProcType a, ProcType b) => + ProcId -- ^Process Identifier + -> ProcFun (a -> b -> a) -- ^Combinational function for next + -- state decoder + -> a -- ^Initial state + -> Signal b -- ^ Input signal + -> Signal a -- ^ Output signal +scanlSY id f mem s = s' + where s' = zipWithSY (id ++ "_NxtSt") f + (delaySY (id ++ "_Delay") mem s') s + + +-- | The process constructor 'scanl2SY' behaves like 'scanlSY', but has two +-- input signals. +scanl2SY :: (ProcType a, ProcType b, ProcType c) => + ProcId -- ^Process Identifier + -> ProcFun (a -> b -> c -> a) -- ^Combinational function for next + -- state decoder + -> a -- ^Initial state + -> Signal b -- ^ First Input signal + -> Signal c -- ^ Second Input signal + -> Signal a -- ^ Output signal +scanl2SY id f mem s1 s2 = s' + where s' = zipWith3SY (id ++ "_NxtSt") f + (delaySY (id ++ "_Delay") mem s') s1 s2 + + +-- | The process constructor 'scanl3SY' behaves like 'scanlSY', but has +-- three input signals. +scanl3SY :: (ProcType a, ProcType b, ProcType c, ProcType d) => + ProcId -- ^Process Identifier + -> ProcFun (a -> b -> c -> d -> a) -- ^Combinational function for next + -- state decoder + -> a -- ^Initial state + -> Signal b -- ^ First Input signal + -> Signal c -- ^ Second Input signal + -> Signal d -- ^ Third Input signal + -> Signal a -- ^ Output signal +scanl3SY id f mem s1 s2 s3 = s' + where s' = zipWith4SY (id ++ "_NxtSt") f + (delaySY (id ++ "_Delay") mem s') s1 s2 s3 + +-- | The process constructor 'scanl4SY' behaves like 'scanlSY', but has +-- four input signals. +scanl4SY :: (ProcType a, ProcType b, ProcType c, ProcType d, ProcType e) => + ProcId -- ^Process Identifier + -> ProcFun (a -> b -> c -> d -> e -> a) -- ^Combinational function + -- for next state decoder + -> a -- ^Initial state + -> Signal b -- ^ First Input signal + -> Signal c -- ^ Second Input signal + -> Signal d -- ^ Third Input signal + -> Signal e -- ^ Fourth Input signal + -> Signal a -- ^ Output signal +scanl4SY id f mem s1 s2 s3 s4 = s' + where s' = zipWith5SY (id ++ "_NxtSt") f + (delaySY (id ++ "_Delay") mem s') s1 s2 s3 s4 + +-- | The process constructor 'scanldSY' is used to construct a finite state +-- machine process without output decoder. It takes an initial value and a +-- function for the next state decoder. The process constructor behaves +-- similarly to the Haskell prelude function 'scanlSY'. In contrast to the +-- process constructor 'scanlSY' here the output value is the current state +-- and not the one of the next state. +scanldSY :: (ProcType a, ProcType b) => + ProcId + -> ProcFun (a -> b -> a) -- ^Combinational function + -- for next state decoder + -> a -- ^Initial state + -> Signal b -- ^ Input signal + -> Signal a -- ^ Output signal +scanldSY id f mem s = s' + where s' = delaySY (id ++ "_Delay") mem $ + zipWithSY (id ++ "_NxtSt") f s' s + +-- | The process constructor 'scanld2SY' behaves like 'scanldSY', but has +-- two input signals. +scanld2SY :: (ProcType a, ProcType b, ProcType c) => + ProcId + -> ProcFun (a -> b -> c -> a) -- ^Combinational function + -- for next state decoder + -> a -- ^Initial state + -> Signal b -- ^ First Input signal + -> Signal c -- ^ Second Input signal + -> Signal a -- ^ Output signal +scanld2SY id f mem s1 s2 = s' + where s' = delaySY (id ++ "_Delay") mem $ + zipWith3SY (id ++ "_NxtSt") f s' s1 s2 + +-- | The process constructor 'scanld3SY' behaves like 'scanldSY', but has +-- three input signals. +scanld3SY :: (ProcType a, ProcType b, ProcType c, ProcType d) => + ProcId + -> ProcFun (a -> b -> c -> d -> a) -- ^Combinational function + -- for next state decoder + -> a -- ^Initial state + -> Signal b -- ^ First Input signal + -> Signal c -- ^ Second Input signal + -> Signal d -- ^ Second Input signal + -> Signal a -- ^ Output signal +scanld3SY id f mem s1 s2 s3 = s' + where s' = delaySY (id ++ "_Delay") mem $ + zipWith4SY (id ++ "_NxtSt") f s' s1 s2 s3 + +-- | The process constructor 'scanld4SY' behaves like 'scanldSY', but has +-- four input signals. +scanld4SY :: (ProcType a, ProcType b, ProcType c, ProcType d, ProcType e) => + ProcId + -> ProcFun (a -> b -> c -> d -> e -> a) -- ^Combinational function + -- for next state decoder + -> a -- ^Initial state + -> Signal b -- ^ First Input signal + -> Signal c -- ^ Second Input signal + -> Signal d -- ^ Third Input signal + -> Signal e -- ^ Fourth Input signal + -> Signal a -- ^ Output signal +scanld4SY id f mem s1 s2 s3 s4 = s' + where s' = delaySY (id ++ "_Delay") mem $ + zipWith5SY (id ++ "_NxtSt") f s' s1 s2 s3 s4 + +-- | The process constructor 'mooreSY' is used to model state machines +-- of \"Moore\" type, where the output only depends on the current +-- state. The process constructor is based on the process constructor +-- 'scanldSY', since it is natural for state machines in hardware, that +-- the output operates on the current state and not on the next +-- state. The process constructors takes a function to calculate the +-- next state, another function to calculate the output and a value for +-- the initial state. +-- +-- In contrast the output of a process created by the process constructor +-- 'mealySY' depends not only on the state, but also on the input values. +mooreSY :: (ProcType a, ProcType b, ProcType c) => + ProcId + -> ProcFun (a -> b -> a) -- ^ Combinational function for + -- next state decoder + -> ProcFun (a -> c) -- ^Combinational function for output decoder + -> a -- ^Initial state + -> Signal b -- ^Input signal + -> Signal c -- ^Output signal +mooreSY id nextState output initial = + mapSY (id ++ "_OutDec") output .scanldSY id nextState initial + + +-- | The process constructor 'moore2SY' behaves like 'mooreSY', but has two +-- input signals. +moore2SY :: (ProcType a, ProcType b, ProcType c, ProcType d) => + ProcId + -> ProcFun (a -> b -> c -> a) -- ^ Combinational function for + -- next state decoder + -> ProcFun (a -> d) -- ^Combinational function for output decoder + -> a -- ^Initial state + -> Signal b -- ^First Input signal + -> Signal c -- ^Second Input signal + -> Signal d -- ^Output signal +moore2SY id nextState output initial i1 i2 = + mapSY (id ++ "_OutDec") output $ scanld2SY id nextState initial i1 i2 + + +-- | The process constructor 'moore3SY' behaves like 'mooreSY', but has +-- three input signals. +moore3SY :: (ProcType a, ProcType b, ProcType c, ProcType d, ProcType e) => + ProcId + -> ProcFun (a -> b -> c -> d -> a) -- ^ Combinational function for + -- next state decoder + -> ProcFun (a -> e) -- ^Combinational function for output decoder + -> a -- ^Initial state + -> Signal b -- ^First Input signal + -> Signal c -- ^Second Input signal + -> Signal d -- ^Third Input signal + -> Signal e -- ^Output signal +moore3SY id nextState output initial i1 i2 i3 = + mapSY (id ++ "_OutDec") output $ scanld3SY id nextState initial i1 i2 i3 + +-- | The process constructor 'moore3SY' behaves like 'mooreSY', but has +-- four input signals. +moore4SY :: (ProcType a, ProcType b, ProcType c, ProcType d, ProcType e, ProcType f) => + ProcId + -> ProcFun (a -> b -> c -> d -> e -> a) -- ^ Combinational function for + -- next state decoder + -> ProcFun (a -> f) -- ^Combinational function for output decoder + -> a -- ^Initial state + -> Signal b -- ^First Input signal + -> Signal c -- ^Second Input signal + -> Signal d -- ^Third Input signal + -> Signal e -- ^Fourth Input signal + -> Signal f -- ^Output signal +moore4SY id nextState output initial i1 i2 i3 i4 = + mapSY (id ++ "_OutDec") output $ scanld4SY id nextState initial i1 i2 i3 i4 + +-- | The process constructor 'melaySY' is used to model state machines of +-- \"Mealy\" type, where the output only depends on the current state and +-- the input values. The process constructor is based on the process +-- constructor 'scanldSY', since it is natural for state machines in +-- hardware, that the output operates on the current state and not on the +-- next state. The process constructors takes a function to calculate the +-- next state, another function to calculate the output and a value for the +-- initial state. +-- +-- In contrast the output of a process created by the process constructor +-- 'mooreSY' depends only on the state, but not on the input values. +mealySY :: (ProcType a, ProcType b, ProcType c) => + ProcId + -> ProcFun (a -> b -> a) -- ^Combinational function for next + -- state decoder + -> ProcFun (a -> b -> c) -- ^Combinational function for output decoder + -> a -- ^Initial state + -> Signal b -- ^Input signal + -> Signal c -- ^Output signal +mealySY id nextState output initial i = + zipWithSY (id ++ "_OutDec") output state i + where state = scanldSY id nextState initial i + +-- | The process constructor 'mealy2SY' behaves like 'mealySY', but has +-- two input signals. +mealy2SY :: (ProcType a, ProcType b, ProcType c, ProcType d) => + ProcId + -> ProcFun (a -> b -> c -> a) -- ^Combinational function for next + -- state decoder + -> ProcFun (a -> b -> c -> d) -- ^Combinational function for output + -- decoder + -> a -- ^Initial state + -> Signal b -- ^First Input signal + -> Signal c -- ^Second Input signal + -> Signal d -- ^Output signal +mealy2SY id nextState output initial i1 i2 = + zipWith3SY (id ++ "_OutDec") output state i1 i2 + where state = scanld2SY id nextState initial i1 i2 + + +-- | The process constructor 'mealy3SY' behaves like 'mealySY', but has +-- three input signals. +mealy3SY :: (ProcType a, ProcType b, ProcType c, ProcType d, + ProcType e) => + ProcId + -> ProcFun (a -> b -> c -> d -> a) -- ^Combinational function for next + -- state decoder + -> ProcFun (a -> b -> c -> d -> e) -- ^Combinational function for + -- output decoder + -> a -- ^Initial state + -> Signal b -- ^First Input signal + -> Signal c -- ^Second Input signal + -> Signal d -- ^Third Input signal + -> Signal e -- ^Output signal +mealy3SY id nextState output initial i1 i2 i3 = + zipWith4SY (id ++ "_OutDec") output state i1 i2 i3 + where state = scanld3SY id nextState initial i1 i2 i3 + +-- | The process constructor 'mealy4SY' behaves like 'mealySY', but has +-- four input signals. +mealy4SY :: (ProcType a, ProcType b, ProcType c, ProcType d, + ProcType e, ProcType f) => + ProcId + -> ProcFun (a -> b -> c -> d -> e -> a) -- ^Combinational function for next + -- state decoder + -> ProcFun (a -> b -> c -> d -> e -> f) -- ^Combinational function for + -- output decoder + -> a -- ^Initial state + -> Signal b -- ^First Input signal + -> Signal c -- ^Second Input signal + -> Signal d -- ^Third Input signal + -> Signal e -- ^Fourth Input signal + -> Signal f -- ^Output signal +mealy4SY id nextState output initial i1 i2 i3 i4 = + zipWith5SY (id ++ "_OutDec") output state i1 i2 i3 i4 + where state = scanld4SY id nextState initial i1 i2 i3 i4 + + +-- | The process constructor 'filterSY' discards the values who do not fulfill a predicate given by a predicate function and replaces them with absent events. +filterSY :: ProcType a => + ProcId + -> ProcFun (a -> Bool) -- ^ Predicate function + -> Signal a -- ^ Input signal + -> Signal (AbstExt a) -- ^ Output signal +filterSY id pred = mapSY id (filterer `defArgPF` pred) + where filterer = + $(newProcFun [d| filterer :: (a -> Bool) -> a -> AbstExt a + filterer pred val = + if pred val then Prst val + else Abst |]) + +-- | The process 'sourceSY' takes a function and an initial state and generates +-- an infinite signal starting with the initial state as first output +-- followed by the recursive application of the function on the current +-- state. The state also serves as output value. +-- +-- The process that has the infinite signal of natural numbers as output is +-- con structed by +-- +-- sourceSY \"naturals\" (+1) 0 +sourceSY :: ProcType a => + ProcId + -> ProcFun (a -> a) + -> a + -> Signal a +sourceSY id f s0 = o + where o = delaySY (id ++ "_Delay") s0 s + s = mapSY (id ++ "_Nxt") f o + + +-- | The process constructor 'fillSY' creates a process that 'fills' a signal +-- with present values by replacing absent values with a given value. The +-- output signal is not any more of the type 'AbstExt'. +fillSY :: ProcType a => + ProcId + -> a -- ^Default value + -> Signal (AbstExt a) -- ^Absent extended input signal + -> Signal a -- ^Output signal +fillSY id v s = mapSY id (replaceAbst `defArgVal` v) s + where replaceAbst :: ProcFun (a -> AbstExt a -> a) + replaceAbst = $(newProcFun + [d| replaceAbst :: a -> AbstExt a -> a + replaceAbst x y = fromAbstExt x y |]) + +-- | The process constructor 'holdSY' creates a process that 'fills' a signal +-- with values by replacing absent values by the preceding present value. +-- Only in cases, where no preceding value exists, the absent value is +-- replaced by a default value. The output signal is not any more of the +-- type 'AbstExt'. +holdSY :: ProcType a => + ProcId -- ^Default value + -> a + -> Signal (AbstExt a) -- ^Absent extended input signal + -> Signal a -- ^Output signal +holdSY id a s = scanlSY id hold a s + where hold = $(newProcFun [d| hold :: a -> AbstExt a -> a + hold a abs = fromAbstExt a abs |]) + +--------------------------- +-- -- +-- SYNCHRONOUS PROCESSES -- +-- -- +--------------------------- + + +-- | The process constructor 'whenSY' creates a process that synchronizes a +-- signal of absent extended values with another signal of absent extended +-- values. The output signal has the value of the first signal whenever an +-- event has a present value and 'Abst' when the event has an absent value. +whenSY :: (ProcType a, ProcType b) => + ProcId + -> Signal (AbstExt a) -> Signal (AbstExt b) -> Signal (AbstExt a) +whenSY id = zipWithSY id whenF + where whenF = $(newProcFun [d| whenF :: AbstExt a -> AbstExt b -> AbstExt a + whenF v1 v2 = if isAbsent v2 + then Abst + else v1 |]) + + +-- | The process 'zipSY' \"zips\" two incoming signals into one signal of +-- tuples. +zipSY :: (ProcType a, ProcType b) => + ProcId + -> Signal a + -> Signal b + -> Signal (a,b) +zipSY id = zipWithSY id tup2 + where tup2 :: ProcFun (a -> b -> (a,b)) + tup2 = $(newProcFun [d| tup2 :: a -> b -> (a,b) + tup2 a b = (a,b) |]) + +-- | The process 'zip3SY' works as 'zipSY', but takes three input signals. +zip3SY :: (ProcType a, ProcType b, ProcType c) => + ProcId -> + Signal a -> + Signal b -> + Signal c -> + Signal (a,b,c) +zip3SY id = zipWith3SY id tup3 + where tup3 :: ProcFun (a -> b -> c -> (a,b,c)) + tup3 = $(newProcFun [d| tup3 :: a -> b -> c -> (a,b,c) + tup3 a b c = (a,b,c) |]) + + +-- | The process 'zip4SY' works as 'zipSY', but takes four input signals. +zip4SY :: (ProcType a, ProcType b, ProcType c, ProcType d) => + ProcId -> + Signal a -> + Signal b -> + Signal c -> + Signal d -> + Signal (a,b,c,d) +zip4SY id = zipWith4SY id tup4 + where tup4 :: ProcFun (a -> b -> c -> d -> (a,b,c,d)) + tup4 = $(newProcFun [d| tup4 :: a -> b -> c -> d -> (a,b,c,d) + tup4 a b c d = (a,b,c,d) |]) + + +-- | The process 'zip5SY' works as 'zipSY', but takes five input signals. +zip5SY :: (ProcType a, ProcType b, ProcType c, ProcType d, ProcType e) => + ProcId -> + Signal a -> + Signal b -> + Signal c -> + Signal d -> + Signal e -> + Signal (a,b,c,d,e) +zip5SY id = zipWith5SY id tup5 + where tup5 :: ProcFun (a -> b -> c -> d -> e -> (a,b,c,d,e)) + tup5 = $(newProcFun [d| tup5 :: a -> b -> c -> d -> e -> (a,b,c,d,e) + tup5 a b c d e = (a,b,c,d,e) |]) + + +-- | The process 'zip6SY' works as 'zipSY', but takes six input signals. +zip6SY :: (ProcType a, ProcType b, ProcType c, ProcType d, ProcType e, + ProcType f) => + ProcId -> + Signal a -> + Signal b -> + Signal c -> + Signal d -> + Signal e -> + Signal f -> + Signal (a,b,c,d,e,f) +zip6SY id = zipWith6SY id tup6 + where tup6 :: ProcFun (a -> b -> c -> d -> e -> f -> (a,b,c,d,e,f)) + tup6 = $(newProcFun [d| tup6 :: a -> b -> c -> d -> e -> f -> + (a,b,c,d,e,f) + tup6 a b c d e f = (a,b,c,d,e,f) |]) + + +-- | The process 'unzipSY' \"unzips\" a signal of tuples into two signals. +unzipSY :: forall a b . (ProcType a, ProcType b) => + ProcId + -> Signal (a,b) + -> (Signal a,Signal b) +unzipSY id s = (Signal (newNodeOutSig nodeRef (UnzipNSYOut 1)), + Signal (newNodeOutSig nodeRef (UnzipNSYOut 2))) + where ts = [fsdTypeOf (undefined :: a), fsdTypeOf (undefined :: b)] + nodeRef = newURef $ Proc id $ + UnzipNSY ts untup (unSignal s) + untup :: Dynamic -> [Dynamic] + untup i = let (t1,t2) = ((fromJust.fromDynamic) i) :: (a,b) + in [toDyn t1, toDyn t2] + + + +-- | The process 'unzip3SY' \"unzips\" a signal of tuples into three signals. +unzip3SY :: forall a b c . (ProcType a, ProcType b, ProcType c) => + ProcId + -> Signal (a,b,c) + -> (Signal a, Signal b, Signal c) +unzip3SY id s = (Signal (newNodeOutSig nodeRef (UnzipNSYOut 1)), + Signal (newNodeOutSig nodeRef (UnzipNSYOut 2)), + Signal (newNodeOutSig nodeRef (UnzipNSYOut 3))) + where ts = [fsdTypeOf (undefined :: a), fsdTypeOf (undefined :: b), + fsdTypeOf (undefined :: c)] + nodeRef = newURef $ Proc id $ + UnzipNSY ts untup3 (unSignal s) + untup3 :: Dynamic -> [Dynamic] + untup3 i = let (t1,t2,t3) = ((fromJust.fromDynamic) i) :: (a,b,c) + in [toDyn t1, toDyn t2, toDyn t3] + + +-- | The process 'unzip4SY' \"unzips\" a signal of tuples into four signals. +unzip4SY :: forall a b c d . (ProcType a, ProcType b, ProcType c, + ProcType d) => + ProcId + -> Signal (a,b,c,d) + -> (Signal a, Signal b, Signal c, Signal d) +unzip4SY id s = (Signal (newNodeOutSig nodeRef (UnzipNSYOut 1)), + Signal (newNodeOutSig nodeRef (UnzipNSYOut 2)), + Signal (newNodeOutSig nodeRef (UnzipNSYOut 3)), + Signal (newNodeOutSig nodeRef (UnzipNSYOut 4))) + where ts = [fsdTypeOf (undefined :: a), fsdTypeOf (undefined :: b), + fsdTypeOf (undefined :: c), fsdTypeOf (undefined :: d)] + nodeRef = newURef $ Proc id $ + UnzipNSY ts untup4 (unSignal s) + untup4 :: Dynamic -> [Dynamic] + untup4 i = let (t1,t2,t3,t4) = ((fromJust.fromDynamic) i) :: (a,b,c,d) + in [toDyn t1, toDyn t2, toDyn t3, toDyn t4] + + +-- | The process 'unzip5SY' \"unzips\" a signal of tuples into five signals. +unzip5SY :: forall a b c d e . (ProcType a, ProcType b, ProcType c, + ProcType d, ProcType e) => + ProcId + -> Signal (a,b,c,d,e) + -> (Signal a, Signal b, Signal c, Signal d, Signal e) +unzip5SY id s = (Signal (newNodeOutSig nodeRef (UnzipNSYOut 1)), + Signal (newNodeOutSig nodeRef (UnzipNSYOut 2)), + Signal (newNodeOutSig nodeRef (UnzipNSYOut 3)), + Signal (newNodeOutSig nodeRef (UnzipNSYOut 4)), + Signal (newNodeOutSig nodeRef (UnzipNSYOut 5))) + where ts = [fsdTypeOf (undefined :: a), fsdTypeOf (undefined :: b), + fsdTypeOf (undefined :: c), fsdTypeOf (undefined :: d), + fsdTypeOf (undefined :: e)] + nodeRef = newURef $ Proc id $ + UnzipNSY ts untup5 (unSignal s) + untup5 :: Dynamic -> [Dynamic] + untup5 i = let (t1,t2,t3,t4,t5) + = ((fromJust.fromDynamic) i) :: (a,b,c,d,e) + in [toDyn t1, toDyn t2, toDyn t3, toDyn t4, toDyn t5] + + +-- | The process 'unzip6SY' \"unzips\" a signal of tuples into six signals. +unzip6SY :: forall a b c d e f . (ProcType a, ProcType b, ProcType c, + ProcType d, ProcType e, ProcType f) => + ProcId + -> Signal (a,b,c,d,e,f) + -> (Signal a, Signal b, Signal c, Signal d, Signal e, Signal f) +unzip6SY id s = (Signal (newNodeOutSig nodeRef (UnzipNSYOut 1)), + Signal (newNodeOutSig nodeRef (UnzipNSYOut 2)), + Signal (newNodeOutSig nodeRef (UnzipNSYOut 3)), + Signal (newNodeOutSig nodeRef (UnzipNSYOut 4)), + Signal (newNodeOutSig nodeRef (UnzipNSYOut 5)), + Signal (newNodeOutSig nodeRef (UnzipNSYOut 6))) + where ts = [fsdTypeOf (undefined :: a), fsdTypeOf (undefined :: b), + fsdTypeOf (undefined :: c), fsdTypeOf (undefined :: d), + fsdTypeOf (undefined :: e), fsdTypeOf (undefined :: f)] + nodeRef = newURef $ Proc id $ + UnzipNSY ts untup6 (unSignal s) + untup6 :: Dynamic -> [Dynamic] + untup6 i = let (t1,t2,t3,t4,t5,t6) + = ((fromJust.fromDynamic) i) :: (a,b,c,d,e,f) + in [toDyn t1, toDyn t2, toDyn t3, toDyn t4, toDyn t5, + toDyn t6] + +-- | The process 'zipxSY' \"zips\" a signal of vectors into a vector of signals. +zipxSY :: (Nat s, Typeable s, ProcType a) => + ProcId + -> FSVec s (Signal a) + -> Signal (FSVec s a) +zipxSY id = zipWithxSY id vectId + where vectId = $(newProcFun [d| vectId :: FSVec s a -> FSVec s a + vectId v = v |]) + +-- | The process 'unzipxSY' \"unzips\" a vector of n signals into a signal of +-- vectors. +unzipxSY :: forall s a . (Typeable s, Nat s, ProcType a) => + ProcId + -> Signal (FSVec s a) + -> FSVec s (Signal a) +unzipxSY id vs = V.map (\tag -> Signal (newNodeOutSig nodeRef tag) ) + (reallyUnsafeVector [UnzipxSYOut i | i <- [1..n]]) + where n = toInt (undefined :: s) + t = fsdTypeOf (undefined :: a) + nodeRef = newURef $ Proc id $ + UnzipxSY t n unvector (unSignal vs) + unvector :: Dynamic -> [Dynamic] + unvector i = let v = ((fromJust.fromDynamic) i) :: FSVec s a + in map toDyn (V.fromVector v) + +-- | The process 'fstSY' selects always the first value from a signal of pairs +fstSY :: (ProcType a, ProcType b) => ProcId -> Signal (a,b) -> Signal a +fstSY id = mapSY id first + where first = $(newProcFun [d| first :: (a,b) -> a + first (a,_) = a |]) + + +-- | The process 'sndSY' selects always the second value from a signal of pairs +sndSY :: (ProcType a, ProcType b) => ProcId -> Signal (a,b) -> Signal b +sndSY id = mapSY id second + where second = $(newProcFun [d| second :: (a,b) -> b + second (_,b) = b |]) + + + +-- | The function 'groupSY' groups values into a vector of size n, which takes +-- n cycles. While the grouping takes place the output from this process +-- consists of absent values. +groupSY :: forall k a . (Nat k, Typeable k, ProcType a) => + ProcId -> k -> Signal a -> Signal (AbstExt (FSVec k a)) +groupSY id k = mooreSY id (f `defArgVal` kV) (g `defArgVal` kV) s0 + where + kV = toInt k + -- FIXME, FIXME, this won't work in th VHDL backend + -- due to the undefined and probably unsafeReplace + s0 = (0, V.copy k (undefined :: a)) + f = $(newProcFun [d| f :: Nat k' => Int -> (Int, FSVec k' a') -> a' -> + (Int, FSVec k' a') + f k (count,v) a = + (count+1 `mod` k, unsafeReplace v count a) |]) + g = $(newProcFun [d| g :: Nat k' => Int -> (Int, FSVec k' a') -> AbstExt (FSVec k' a') + g k (count,v) = if k-1 == count then Prst v else Abst |]) + unsafeReplace :: Nat s => FSVec s a' -> Int -> a' ->FSVec s a' + unsafeReplace v i a = + reallyUnsafeVector $ unsafeReplace' (fromVector v) i a + where unsafeReplace' [] _ _ = [] + unsafeReplace' (_:xs) 0 y = (y:xs) + unsafeReplace' (x:xs) n y = x : (unsafeReplace' xs (n - 1) y) + diff --git a/src/ForSyDe/Deep/Signal.hs b/src/ForSyDe/Deep/Signal.hs new file mode 100644 --- /dev/null +++ b/src/ForSyDe/Deep/Signal.hs @@ -0,0 +1,30 @@ +----------------------------------------------------------------------------- +-- | +-- Module : ForSyDe.Deep.Signal +-- Copyright : (c) ES Group, KTH/ICT/ES 2007-2013 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : forsyde-dev@ict.kth.se +-- Stability : experimental +-- Portability : portable +-- +-- +-- This module provides the fundamental data structure for deep-embedded +-- ForSyDe models: 'Signal'. +-- +----------------------------------------------------------------------------- + + +-- This module is simply used to export Signal to the end user hiding its internal +-- representation +module ForSyDe.Deep.Signal (Signal) where + + +import ForSyDe.Deep.Netlist (Signal) + + + + + + + diff --git a/src/ForSyDe/Deep/System.hs b/src/ForSyDe/Deep/System.hs new file mode 100644 --- /dev/null +++ b/src/ForSyDe/Deep/System.hs @@ -0,0 +1,24 @@ +----------------------------------------------------------------------------- +-- | +-- Module : ForSyDe.Deep.System +-- Copyright : (c) ES Group, KTH/ICT/ES 2007-2013 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : forsyde-dev@ict.kth.se +-- Stability : experimental +-- Portability : non-portable (Template Haskell) +-- +-- This module provides publicly usable functions to build a system definition +-- and instantiate it. +-- +----------------------------------------------------------------------------- +module ForSyDe.Deep.System +(SysDef, newSysDef, newSysDefTH, newSysDefTHName, + SysFun, SysFunToSimFun, SysFunToIOSimFun, + instantiate) +where + +import ForSyDe.Deep.System.SysDef (SysDef, newSysDef, newSysDefTH, newSysDefTHName) +import ForSyDe.Deep.System.SysFun (SysFun, SysFunToSimFun, SysFunToIOSimFun) +import ForSyDe.Deep.System.SysFun.Instances () +import ForSyDe.Deep.System.Instantiate (instantiate) diff --git a/src/ForSyDe/Deep/System/Instantiate.hs b/src/ForSyDe/Deep/System/Instantiate.hs new file mode 100644 --- /dev/null +++ b/src/ForSyDe/Deep/System/Instantiate.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE TemplateHaskell #-} +----------------------------------------------------------------------------- +-- | +-- Module : ForSyDe.Deep.System.Instantiate +-- Copyright : (c) ES Group, KTH/ICT/ES 2007-2013 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : forsyde-dev@ict.kth.se +-- Stability : experimental +-- Portability : portable +-- +-- This module provides instantiation capabilities to System Definitions +-- ('SysDef's).through a Template-Haskell-based function: 'instantiate'. +-- +-- Thanks to 'instantiate' ForSyDe models have hierarchy capabilities. +-- +----------------------------------------------------------------------------- +module ForSyDe.Deep.System.Instantiate (instantiate) where + +import ForSyDe.Deep.Ids (ProcId) +import ForSyDe.Deep.OSharing (readURef) +import ForSyDe.Deep.Netlist +import ForSyDe.Deep.System.SysDef (SysDef) +import ForSyDe.Deep.System.SysFun (SysFun(fromListSysFun)) + + + + +-- | Generates an instance of a 'SysDef' in the form of +-- function out of the name of a 'SysDef' with the same type as its +-- system function. The resulting function can then be used to plug the +-- instance to the rest of the system. +instantiate :: SysFun f => ProcId -> SysDef f -> f +instantiate id sysDef = fromListSysFun (instantiateList id sysDef) [] + + +------------------- +-- Helper Functions +------------------- + +instantiateList :: ProcId -> SysDef a -> [NlSignal] -> [NlSignal] +instantiateList id sysDef inSigs = map (\t -> newNodeOutSig instanceSig t) tags + where instanceSig = newSysIns id sysDef inSigs + tags = outTags $ readURef instanceSig diff --git a/src/ForSyDe/Deep/System/SysDef.hs b/src/ForSyDe/Deep/System/SysDef.hs new file mode 100644 --- /dev/null +++ b/src/ForSyDe/Deep/System/SysDef.hs @@ -0,0 +1,410 @@ +{-# LANGUAGE CPP,TemplateHaskell #-} +----------------------------------------------------------------------------- +-- | +-- Module : ForSyDe.Deep.System.SysDef +-- Copyright : (c) ES Group, KTH/ICT/ES 2007-2013 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : forsyde-dev@ict.kth.se +-- Stability : experimental +-- Portability : portable +-- +-- This module provides the System Definition type ('SysDef') together with +-- a Template Haskell constructor to build it. +-- +----------------------------------------------------------------------------- +module ForSyDe.Deep.System.SysDef + (SysDef(..), + PrimSysDef(..), + SysDefVal(..), + SysLogic(..), + newSysDef, + newSysDefTH, + newSysDefTHName, + Iface) where + +import ForSyDe.Deep.Ids +import ForSyDe.Deep.Netlist +import ForSyDe.Deep.Netlist.Traverse +import ForSyDe.Deep.OSharing +import ForSyDe.Deep.ForSyDeErr +import ForSyDe.Deep.System.SysFun (checkSysFType, SysFun(..)) + +import Data.Maybe (isJust, fromJust) +import Control.Monad.ST +import Control.Monad.State +import Data.Typeable +import Language.Haskell.TH hiding (Loc) +import Language.Haskell.TH.LiftInstances () +import Data.Typeable.FSDTypeRepLib + + + + +-- | Interface, describes the input or output ports of the system. +-- Each entry contains the name of the port and its type. +type Iface = [(PortId, FSDTypeRep)] + + +-- | We add a phantom parameter to indicate the type of the system +newtype SysDef a = SysDef {unSysDef :: PrimSysDef} + +-- | The Primitive System Definition. +-- Instead of just providing the value, a reference is provided +-- to allow sharing between instances. +newtype PrimSysDef = PrimSysDef {unPrimSysDef :: URef SysDefVal} + + + +-- | Indicates wether a system is combinational or sequential +-- In practice, a system is sequential if if contains a delay process or +-- a sequential system instance, otherwise its combinational. +data SysLogic = Combinational | Sequential + deriving (Eq, Show) + + +-- | The System Definition value +data SysDefVal = SysDefVal + {sid :: SysId, -- ^ Identifier of the System + netlist :: Netlist [], -- ^ System netlist + subSys :: [PrimSysDef], -- ^ List of all unique nested subsystems + -- (i.e. flattened tree, without duplicates, + -- of all the systems in lower levels of the + -- hierarchy) + logic :: SysLogic, -- ^ 'SysLogic' of the system + + iIface :: Iface, -- ^ Input interface + oIface :: Iface, -- ^ Output interface + loc :: Maybe Loc} -- ^ Location of the call to newSysDef + -- which created this System definition + -- (used for later error reporting) + -- It will initialized or not depending + -- on the newSysDef* function used + + + +-- | 'SysDef' constructor +-- +-- Builds a system definition out of a system function describing the system +-- and its port identifers. +newSysDef :: SysFun f => f -- ^ system function + -> SysId -- ^ System identifier + -> [PortId] -- ^ Input interface port identifiers + -> [PortId] -- ^ Output interface port identifiers + -> SysDef f +newSysDef f sysId inIds outIds = either currError id eProneResult + where currError = uError "newSysDef" + eProneResult = newSysDefEProne f Nothing sysId inIds outIds + +-- | CURRENTLY BROKEN, do not use! +-- +-- 'SysDef' constructor, Template Haskell version +-- +-- Builds a system definition out of a system function, a system identifiers +-- and its port identifers. +-- +-- For example @$(newSysDefTH mySysFun \"mysys\" [\"in1\"] [\"out1\"])@ creates a +-- system definition from system funcion @mySysFun@ which should have +-- one input and output signals. +-- +-- The advantage of 'newSysDefTH' over 'newSysDef' is that it +-- reports errors (e.g duplicated port and process identifiers) earlier, +-- at host-language (Haskell) compile-time. +-- +-- In addition, due to the use of Template Haskell, 'newSysDefTH' is +-- aware of the source location at which it was called, making +-- further error reports friendlier to the user. +newSysDefTH :: SysFun f => f -- ^ system function + -> SysId -- ^ System identifier + -> [PortId] -- ^ Input interface port identifiers + -> [PortId] -- ^ Output interface port identifiers + -> ExpQ +newSysDefTH f sysId inIds outIds = + case eProneResult of + Left err -> currError err + -- unfortunately SysDef can't easily be an instance of Lift + -- due to the unsafe, unmutable references used in observable sharing + -- Right sysDef -> [| sysDef |] + Right _ -> intError "newSysDefTH" (Other "Unimplemented") +-- FIXME: Fix this function or remove (updating the documentation of +-- newSysDef* in the latter case). +{- + Right _ -> do + loc <- currentModule + [| let iIds = inIds + oIds = outIds + (nlist, inTypes, outTypes) = applySysFun f iIds + in SysDef $ PrimSysDef $ newURef $ SysDefVal sysId + (Netlist nlist) + (zip iIds inTypes) + (zip oIds outTypes) + (Just loc) |] +-} + where currError = qError "newSysDefTH" + eProneResult = newSysDefEProne f Nothing sysId inIds outIds + + +-- | 'SysDef' constructor, Template Haskell 'Name' version +-- +-- Builds a 'SysDef' out of the name of a system function +-- and its port identifers. +-- +-- The system will later be identified by the basename +-- (i.e. unqualified name) of the function. +-- +-- For example @$(newSysDefTHName \'mySysFun [\"in1\"] [\"out1\"])@ creates a +-- system definition from system funcion @mySysFun@ which has one input and +-- output signals. +-- +-- The advantage of 'newSysDefTHName' over 'newSysDefTH' is that it +-- doesn't suffer from the Template Haskell bug , or in other words, it allows to declare the system +-- defintion and system function in the same module. +-- +-- However, since it doesn't have acces to the system function itself, +-- it can only give early error reports related to incorrect port identifiers +-- (process identifier duplicate errors will be reported at runtime). +newSysDefTHName :: Name -- ^ Name of the system function + -> [PortId] -- ^ Input interface port identifiers + -> [PortId] -- ^ Output interface port identifiers + -> ExpQ +newSysDefTHName sysFName inIds outIds = do + sysFInfo <- reify sysFName + -- Check that a function name was provided + sysFType <- case sysFInfo of +#if __GLASGOW_HASKELL__ >= 800 + -- Last parameter Fixity was removed in GHC8 + VarI _ t _ -> return t +#else + VarI _ t _ _ -> return t +#endif + _ -> currError (NonVarName sysFName) + -- Check that the function complies with the expected type + -- and extract the port types + ((inTypes,inN),(outTypes, outN)) <- recover + (currError $ IncomSysF sysFName sysFType) + (checkSysFType sysFType) + -- Check the ports + let portCheck = checkSysDefPorts (show sysFName) + (inIds, inN) + (outIds, outN) + when (isJust portCheck) (currError (fromJust portCheck)) + -- Build the system definition + loc <- location + let + errInfo = loc_module loc + -- Input arguments passed to the system function + -- in order to get the netlist + inArgs = [ [| Signal $ newInPort $(litE $ stringL id) |] + | id <- inIds ] + -- The system definition without type signature for the + -- phantom parameter + untypedSysDef = + -- The huge let part of this quasiquote is not + -- really necesary but generates clearer code + [|let + -- Generate the system netlist + toList = $(signalTup2List outN) + outNlSignals = toList $ $(appsE $ varE sysFName : inArgs) + -- Rest of the system defintion + inIface = $(genIface inIds inTypes) + outIface = $(genIface outIds outTypes) + errorInfo = errInfo + nlist = Netlist outNlSignals + (subSys,logic) = either (intError currFun) id + (checkSysDef nlist) + in SysDef $ PrimSysDef $ newURef $ + SysDefVal (nameBase sysFName) + nlist + subSys + logic + inIface + outIface + (Just errorInfo) |] + -- We are done, we simply specify the concrete type of the SysDef + sigE untypedSysDef (return $ ConT ''SysDef `AppT` sysFType) + where currError = qError currFun + currFun = "newSysDef" + + + + +---------------------------- +-- Internal Helper Functions +---------------------------- + +-- | Error prone version of 'newSysDef' +newSysDefEProne :: SysFun f => f -- ^ system function + -> Maybe Loc -- ^ Location where the originating + -- call took place (if available) + -> SysId -- ^ System function + -> [PortId] -- ^ Input interface port identifiers + -> [PortId] -- ^ Output interface port identifiers + -> EProne (SysDef f) +newSysDefEProne f mLoc sysId inIds outIds + -- check the ports for problems + | isJust portCheck = throwError (fromJust portCheck) + | otherwise = do + let nl = Netlist nlist + (subSys, logic) <- checkSysDef nl + return (SysDef $ PrimSysDef $ newURef $ SysDefVal sysId + nl + subSys + logic + (zip inIds inTypes) + (zip outIds outTypes) + mLoc) + where (nlist, inTypes, outTypes) = applySysFun f inIds + inN = length inIds + outN = length outIds + portCheck = checkSysDefPorts sysId (inIds, inN) (outIds, outN) + +-- | Check that the system definition ports match certain lengths and +-- don't containt duplicates +checkSysDefPorts :: SysId -- ^ System currently being checked + -> ([PortId], Int) -- ^ input ports and expected length + -> ([PortId], Int) -- ^ output ports and expected length + -> Maybe ForSyDeErr +checkSysDefPorts sysId (inIds, inN) (outIds, outN) + | inN /= inIdsL = Just $ InIfaceLength (sysId, inN) (inIds, inIdsL) + | outN /= outIdsL = Just $ OutIfaceLength (sysId, outN) (outIds, outIdsL) + | isJust (maybeDup) = Just $ MultPortId (fromJust maybeDup) + | otherwise = Nothing + where inIdsL = length inIds + outIdsL = length outIds + maybeDup = findDup (inIds ++ outIds) + + +-- | In order to check the system for identifier duplicates we keep track +-- of the process identifiers and of the accumulated subsytem definitions +data CheckState = CheckState {accumSubSys :: [PrimSysDef], + accumProcIds :: [ProcId] , + accumLogic :: SysLogic } + +-- Monad used to traverse the system in order to check that there are no +-- duplicates +type CheckSysM st a = TravSEST CheckState ForSyDeErr st a + +-- | Check that the system netlist does not contain process identifier +-- duplicates (i.e. different processes with the same process +-- identifier) or instances of different systems with the same identifier. +-- In case there are no duplicates, the list of nested subsystems together +-- with the the logic is returned. +checkSysDef :: Netlist [] -> EProne ([PrimSysDef], SysLogic) +checkSysDef nl = do + endSt <- runST (runErrorT + (execStateT (traverseSEST newCheckSys defineCheckSys nl) initState)) + let finalSubSys = accumSubSys endSt + -- we already checked all the delay processes of the system + -- but the system can still be sequential if any of the subsystems is + -- sequential + finalLogic = + if (accumLogic endSt == Sequential) || + (any (\s -> (logic.readURef.unPrimSysDef) s == Sequential) finalSubSys) + then Sequential + else Combinational + return (finalSubSys, finalLogic) + where initState = CheckState [] [] Combinational + + +defineCheckSys :: [(NlNodeOut, ())] -> NlNode () -> CheckSysM st () +defineCheckSys _ _= return () + +newCheckSys :: NlNode NlSignal -> CheckSysM st [(NlNodeOut, ())] +newCheckSys node = do + st <- get + let acIds = accumProcIds st + acSys = accumSubSys st + acLog = accumLogic st + -- check the process Id of current node for duplicates + acIds' <- case node of + -- input ports don't count as process identifiers + InPort _ -> return acIds + Proc pid _ -> if pid `elem` acIds + then throwError $ MultProcId pid + else return (pid:acIds) + -- If the node is a system instance, check that + -- the system and all its subsytems are either: + -- * already in the accumulated systems + -- * not in the accumulated systems, but have a different system + -- identifiers + -- FIXME: in order to avoid making so many comparisons, it + -- would probably be more efficient to also mark which + -- subsystems belong to the first hierarchy level in + -- SysVal (i.e. creating a tree-structure as a reult). + -- Then, if the system to compare (psys) matches a + -- root in the accumulated subsystems there would be + -- no need to continue comparing the childs of psys. + acSys' <- case node of + Proc _ (SysIns pSys _) -> + liftEither $ + mergeSysIds (pSys:(subSys.readURef.unPrimSysDef) pSys) acSys + _ -> return acSys + let acLog' = case node of + Proc _ (DelaySY _ _) -> Sequential + _ -> acLog + put $ CheckState acSys' acIds' acLog' + -- return a phony value for each output of the node + return $ map (\tag -> (tag,())) (outTags node) + + where mergeSysIds :: [PrimSysDef] -> [PrimSysDef] -> EProne [PrimSysDef] + mergeSysIds xs [] = return xs + mergeSysIds [] xs = return xs + mergeSysIds (x:xs) ys = do + shouldAdd <- addSysId x ys + if shouldAdd then do rest <- mergeSysIds xs ys + return (x:rest) + else mergeSysIds xs ys + -- should we add the Id to the accumulated ones? + addSysId :: PrimSysDef -> [PrimSysDef] -> EProne Bool + addSysId _ [] = return True + addSysId psdef (x:xs) + -- Both systems are equal + | unx == unpsdef = return False + -- Both systems are different, but their ids + -- are equal + | sdefid == sid xval = + throwError (SubSysIdClash sdefid (loc sdefval) (loc xval)) + | otherwise = addSysId psdef xs + where unpsdef = unPrimSysDef psdef + unx = unPrimSysDef x + xval = readURef unx + sdefval = readURef unpsdef + sdefid = sid sdefval + + +-- | Generate a lambda expression to transform a tuple of N 'Signal's into a +-- a list of 'NlSignal's +signalTup2List :: Int -- ^ size of the tuple + -> ExpQ +signalTup2List n = do -- Generate N signal variable paterns and + -- variable expressions refering to the same names + names <- replicateM n (newName "i") + let tupPat = tupP [conP 'Signal [varP n] | n <- names] + listExp = listE [varE n | n <- names] + lamE [tupPat] listExp + + +-- | Find a duplicate in a list +findDup :: Eq a => [a] -> Maybe a +findDup [] = Nothing +findDup [_] = Nothing +findDup (x:xs) + | elem x xs = Just x + | otherwise = findDup xs + + +-- | Generate a TypeRep expression given a Template Haskell Type +-- note that the use of typeOf cannot lead to errors since all the signal +-- types in a system function are guaranteed to be Typeable by construction +type2TypeRep :: Type -> ExpQ +type2TypeRep t = [| typeOf $(sigE [| undefined |] (return t) ) |] + +-- | Generate an interface given its identifiers and Template Haskell Types +genIface :: [PortId] -> [Type] -> ExpQ +genIface [] _ = listE [] +genIface _ [] = listE [] +genIface (i:ix) (t:tx) = do + ListE rest <- genIface ix tx + tupExp <- tupE [[| i |], type2TypeRep t] + return (ListE (tupExp:rest)) + diff --git a/src/ForSyDe/Deep/System/SysDef.hs-boot b/src/ForSyDe/Deep/System/SysDef.hs-boot new file mode 100644 --- /dev/null +++ b/src/ForSyDe/Deep/System/SysDef.hs-boot @@ -0,0 +1,21 @@ +{-# LANGUAGE RoleAnnotations #-} +-- SysDef.hs-boot: GHC bootstrapping module for Netlist.hs +-- (it breaks the recursive import loop with Netlist.hs) +-- See "How to compile mutually recursive modules" in GHC's manual for details + +module ForSyDe.Deep.System.SysDef where + +import ForSyDe.Deep.OSharing +import ForSyDe.Deep.Ids +import Data.Typeable.FSDTypeRepLib + +type Iface = [(PortId, FSDTypeRep)] + +type role SysDef phantom +newtype SysDef a = SysDef {unSysDef :: PrimSysDef} + +newtype PrimSysDef = PrimSysDef {unPrimSysDef :: URef SysDefVal} + +data SysDefVal + +oIface :: SysDefVal -> Iface diff --git a/src/ForSyDe/Deep/System/SysFun.hs b/src/ForSyDe/Deep/System/SysFun.hs new file mode 100644 --- /dev/null +++ b/src/ForSyDe/Deep/System/SysFun.hs @@ -0,0 +1,311 @@ +{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, MultiParamTypeClasses, + FunctionalDependencies #-} +----------------------------------------------------------------------------- +-- | +-- Module : ForSyDe.System.SysFun +-- Copyright : (c) ES Group, KTH/ICT/ES 2007-2013 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : forsyde-dev@ict.kth.se +-- Stability : experimental +-- Portability : portable +-- +-- This module provides the 'SysFun' class and a Template Haskell +-- function to check whether a 'Type' complies with the expected +-- type of a system function not. +-- +----------------------------------------------------------------------------- +module ForSyDe.Deep.System.SysFun + (SysFun(..), + SysFunToSimFun(..), + SysFunToIOSimFun(..), + funOutInstances, + checkSysFType) where + +import ForSyDe.Deep.Ids(PortId) +import ForSyDe.Deep.Netlist (NlSignal, Signal(..)) +import ForSyDe.Deep.ForSyDeErr +import ForSyDe.Deep.Process.ProcType (ProcType(..)) + +import Language.Haskell.TH.TypeLib + +import Data.Dynamic +import Text.Regex.Posix ((=~)) +import qualified Language.Haskell.TH as TH (Exp) +import Language.Haskell.TH +import Text.ParserCombinators.ReadP (readP_to_S) +import Data.Typeable.FSDTypeRepLib + +--------------- +-- SysFun class +--------------- + +-- | Class used to describe a System function. It uses the same trick +-- as 'Text.Printf' to implement the variable number of arguments. +class SysFun f where + -- | Gets the result of applying a system function to input port signals + -- whose name is given in first argument. + -- In case the input id list is not long enough, \"default\" will be used + -- as the id of the remaining ports. + applySysFun :: f + -> [PortId] -- ^ ids used to build the input ports + -> ([NlSignal], [FSDTypeRep], [FSDTypeRep]) + -- ^ (output signals returned by the system function, + -- types of input ports, + -- types of output ports) + + -- | Transforms a primitive-signal-list version of a system function + -- into a standard system function. + -- Note the length of input/output lists of the list version must match with + -- the argument number and return tuple size of the system function. + fromListSysFun :: ([NlSignal] -> [NlSignal]) -- ^ primitive-signal-list sysfun + -> [NlSignal] -- ^ accumulated primitive signals + -- (must be initialized to []) + -> f + + + +----------------------- +-- SysFunToSimFun class +----------------------- + +-- | Multiparameter class to transform a System Function into a Simulation +-- Function, able to simulate a System using a list-based representation +-- of its signals. +class SysFun sysFun => + SysFunToSimFun sysFun simFun | sysFun -> simFun, simFun -> sysFun where + -- | Transforms a dynamic-list version of a simulation function + -- into a standard simulation function. + -- Note the length of input/output lists of the list version must match with + -- the argument number and return tuple size of the simulation function. + fromDynSimFun :: ([[Dynamic]] -> [[Dynamic]]) -- ^ dynamic-list simfun + -> [[Dynamic]] -- ^ accumulated dynamic values + -- (must be initialized to []) + -> simFun + +------------------------- +-- SysFunToIOSimFun class +------------------------- + +-- | Multiparameter class to transform a System Function into an IO +-- Simulation Function, able to externally simulate a System using a +-- list-based representation of its signals. +class SysFun sysFun => + SysFunToIOSimFun sysFun simFun | + sysFun -> simFun, simFun -> sysFun where + -- | Transforms a TH/String version of a simulation function into a + -- standard simulation function. + -- Again, the length of input/output lists of the list version must + -- match with the argument number and return tuple size of the + -- simulation function. + fromTHStrSimFun :: ([[TH.Exp]] -> IO [[String]]) -- ^ TH/String-list simfun + -> [[TH.Exp]] -- ^ accumulated dynamic values + -- (must be initialized to []) + -> simFun + +-- Function to automatically generate instances for the system and +-- simulate function outputs with Template Haskell. For example, in +-- the case of 2 outputs, the code generated would be: +-- +-- @ +-- NOTE: even if all ProcType constraints could be less restrictive (Typeable +-- would do), it makes more sense, and who nows, maybe we end up requiring +-- full ProcType functionality at some point. +-- +-- +-- instance (ProcType o1, ProcType o2) => SysFun (Signal o1, Signal o2) where +-- applyFun (o1, o2) _ = +-- ([unSignal o1, unSignal o2], [], [typeOf o1, typeOf o2]) +-- fromListSysFun f accum = (Signal o1, Signal o2) +-- where [o1, o2] = f (reverse accum) +-- +-- instance (ProcType o1, ProcType o2) => +-- SysFun2SimFun (Signal o1, Signal o2) ([o1], [o2]) where +-- fromDynSimFun f accum = (map unsafeFromDyn o1, map unsafeFromDyn o2) +-- -- use pattern (o1:o2:_) and not not [o1,o2] +-- -- because the second one doesn't when o1 and o2 are infinite lists +-- where (o1:o2:_) = f (reverse accum) +-- +-- instance (ProcType o1, ProcType o2) => +-- SysFun2SimFun (Signal o1, Signal o2) (IO ([o1], [o2])) where +-- fromTHStrSimFun f accum = do +-- [o1, o2] <- f (reverse accum) +-- return (map parseProcType o1, map parseProcType o2) +-- +-- +-- @ +funOutInstances :: Int -- ^ number of outputs to generate + -> Q (Dec, Dec, Dec) +funOutInstances n = do + -- Generate N output names + outNames <- replicateM n (newName "o") + + -- 1) Generate applyFun + -- Generate an input tuple pattern for applyFun + -- (o1, o2, ..., on) + let tupPatApply = tupP (map varP outNames) + -- Generate the output primitive signal list expression for applyFun + -- [unsignal o1, unsignal o2, ...., unsignal on] + outPrimSignalsApply = + listE $ map (\oName -> varE 'unSignal `appE` varE oName) outNames + -- Generate the output signal types for ApplyFun + -- [typeOf o1, typeOf o2, ...., typeOf on] + outTypeRepsApply = + listE $ map (\oName -> varE 'fsdTypeOf `appE` varE oName) outNames + -- Generate the full output expression + outEApply = [| ($outPrimSignalsApply, [], $outTypeRepsApply) |] + -- Finally, the full declaration of applyFun + applySysFunDec = + funD 'applySysFun [clause [tupPatApply, wildP] (normalB outEApply) []] + -- 2) Generate fromListSysFun + -- Generate the parameter names + fParFromSys <- newName "f" + accumParFromSys <- newName "accum" + -- Generate the parameter patterns + let fPatFromSys = varP fParFromSys + accumPatFromSys = varP accumParFromSys + -- Generate the list pattern: [o1, o2, .., on] + listPatFromSys = listP $ map varP outNames + -- Generate the rhs of the where declaration + whereRHSFromSys = + [| $(varE fParFromSys) (reverse $(varE accumParFromSys)) |] + -- Generate the where clause declaration + whereDecFromSys = valD listPatFromSys (normalB whereRHSFromSys) [] + -- Generate output expression: (Signal o1, Signal o2, ..., Signal on) + outEFromSys = + tupE $ map (\oName -> conE 'Signal `appE` varE oName) outNames + -- Finally, the full declaration of fromListSysFun + fromListSysFunDec = + funD 'fromListSysFun [clause [fPatFromSys, accumPatFromSys] + (normalB outEFromSys) + [whereDecFromSys] ] + -- 3) Generate fromDynSimFun reusing parts of fromListSysFun + -- Generate the list pattern: o1:o2: .. on:_ + listPatFromDynSim = foldr (\oName pat -> infixP (varP oName) '(:) pat) + wildP outNames + -- Generate the rhs of the where declaration + whereRHSFromDynSim = + [| $(varE fParFromSys) (reverse $(varE accumParFromSys)) |] + -- Generate the where clause declaration + whereDecFromDynSim = valD listPatFromDynSim (normalB whereRHSFromSys) [] + -- Generate output expression: (Signal o1, Signal o2, ..., Signal on) + outEFromDynSim = tupE $ map + (\oName -> varE 'map `appE` varE 'unsafeFromDyn `appE` varE oName) + outNames + -- Finally, the full declaration of fromDynSimFun + fromDynSimFunDec = + funD 'fromDynSimFun [clause [fPatFromSys, accumPatFromSys] + (normalB outEFromDynSim) + [whereDecFromDynSim] ] + -- 4) Generate fromTHStrSimFun reusing parts of fromListSysFun + listPatFromTHStrSim = listP $ map varP outNames + -- Generate the rhs of the where declaration + doFromTHStrSim = doE $ + [bindS listPatFromDynSim [| $(varE fParFromSys) + (reverse $(varE accumParFromSys)) |], + noBindS $ + (varE 'return) `appE` + (tupE $ map + (\oName -> varE 'map `appE` varE 'parseProcType `appE` varE oName) + outNames) ] + -- Finally, the full declaration of fromThStrSimFun + fromTHStrSimFunDec = + funD 'fromTHStrSimFun [clause [fPatFromSys, accumPatFromSys] + (normalB doFromTHStrSim) + [] ] + -- 5) Generate the SysFun instance + -- We reuse the output signal names for the head type variables + -- (Signal o1, Signal o2, ..., Signal on) + signalTupT = if n == 1 then conT ''Signal `appT` varT (head outNames) + else foldl accumApp (tupleT n) outNames + where accumApp accumT vName = + accumT `appT` (conT ''Signal `appT` varT vName) + -- Create the ProcType context + procTypeCxt = map (\vName -> appT (conT ''ProcType) (varT vName)) outNames + + -- Finally return the instance declaration + sysFunIns = instanceD (cxt procTypeCxt) + (conT ''SysFun `appT` signalTupT) + [applySysFunDec, fromListSysFunDec] + -- 6) Generate the SysFun2SimFun instance + listTupT = if n == 1 then listT `appT` varT (head outNames) + else foldl accumApp (tupleT n) outNames + where accumApp accumT vName = + accumT `appT` (listT `appT` varT vName) + simFunIns = instanceD (cxt procTypeCxt) + (conT ''SysFunToSimFun `appT` signalTupT `appT` listTupT) + [fromDynSimFunDec] + -- 7) Generate the SysFun2IOSimFun instance + ioSimFunIns = instanceD (cxt procTypeCxt) + (conT ''SysFunToIOSimFun `appT` + signalTupT `appT` + (conT ''IO `appT` listTupT)) + [fromTHStrSimFunDec] + -- Finally, return the declarations + liftM3 (,,) sysFunIns simFunIns ioSimFunIns + +--------------------------------------------------------------- +-- Checking the type of a System Function with Template Haskell +--------------------------------------------------------------- + +-- | Given a function type expressed with Template Haskell, check +-- whether it complies with the expected type of a system function +-- and, in that case, provide the type and number of the system +-- inputs and outputs. +checkSysFType :: Type -> Q (([Type],Int),([Type],Int)) +checkSysFType t = do let (inputTypes, retType, context) = unArrowT t + (outCons, outTypes, _) = unAppT retType + -- Discard polymorphic system functions + -- FIXME: We could support polymorphic signals, but it + -- requires more work and we don't still know if it + -- will be necessary anyway. + when (isPoly context) (qGiveUp name) + -- Check that all inputs are signals + when (not $ all isSignalT inputTypes) (qGiveUp name) + -- Check the outputs + outInfo <- checkSysFOutputs (outCons, outTypes) + return ((inputTypes, length inputTypes), outInfo) + where name = "ForSyDe.System.checkSysFType" + + +-- | Check the output types of the system function given its +-- constructor and its type arguments +checkSysFOutputs :: (Type, [Type]) -> Q ([Type], Int) +-- The system function doesn't output any signals at all +checkSysFOutputs (ConT n, []) | n == ''() = return ([],0) +-- The system function just returns a signal +checkSysFOutputs (ConT s, [arg]) | s == ''Signal = + return ([ConT ''Signal `AppT` arg ], 1) +-- The system function returns various signals in a tuple +-- NOTE: Unfortunatelly due to ghc's bug 1849 TupleT is never returned by reify +-- so we have to match the constructor with a regex +-- FIXME: Update this function whenever the bug is fixed +-- http://hackage.haskell.org/trac/ghc/ticket/1849 +checkSysFOutputs (ConT name, outTypes) + | show name =~ "^Data\\.Tuple\\.\\(,+\\)$" = do + when (not $ all isSignalT outTypes) (qGiveUp checkSysFOutputsNm) + return (outTypes, length outTypes) +-- Otherwise the function output type is incorrect +checkSysFOutputs _ = qGiveUp checkSysFOutputsNm + +checkSysFOutputsNm :: String +checkSysFOutputsNm = "ForSyDe.System.SysFun.checkSysFOutputs" + +-- | Check if a type corresponds to a signal +isSignalT :: Type -> Bool +isSignalT ((ConT name) `AppT` _ ) | name == ''Signal = True +isSignalT _ = False + +-- | Unsafely transform from a dynamic value +unsafeFromDyn :: forall a . Typeable a => Dynamic -> a +unsafeFromDyn dyn = fromDyn dyn err + where err = intError "unsafeFromDyn" (DynMisMatch dyn targetType) + targetType = typeOf (undefined :: a) + +-- | Parse a proctype value +parseProcType :: forall a .ProcType a => String -> a +parseProcType s = + case (readP_to_S readProcType) s of + [(a,_)] -> a + _ -> error ("parseProcType: error parsing element of type " ++ + show (typeOf (undefined :: a)) ) diff --git a/src/ForSyDe/Deep/System/SysFun/Instances.hs b/src/ForSyDe/Deep/System/SysFun/Instances.hs new file mode 100644 --- /dev/null +++ b/src/ForSyDe/Deep/System/SysFun/Instances.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE TemplateHaskell, FlexibleInstances, ScopedTypeVariables, + MultiParamTypeClasses, UndecidableInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : ForSyDe.Deep.System.SysFun.Instances +-- Copyright : (c) The ForSyDe Team 2008-2013 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : forsyde-dev@ict.kth.se +-- Stability : experimental +-- Portability : non-portable (Template Haskell) +-- +-- This module provides the instances for 'SysFun', it cannot +-- be included in "ForSyDe.System.SysFun" directly due to a Template Haskell +-- bug which prevents Template Haskell from executing functions defined in the +-- same module: +-- +----------------------------------------------------------------------------- +module ForSyDe.Deep.System.SysFun.Instances () where + +import Data.Dynamic +import Control.Monad (liftM) +import Language.Haskell.TH.Syntax (runIO, runQ, lift) +import System.IO.Unsafe (unsafePerformIO) + +import ForSyDe.Deep.Config (maxTupleSize) +import ForSyDe.Deep.System.SysFun ( + SysFun(..), + SysFunToSimFun(..), + SysFunToIOSimFun(..), + funOutInstances) +import ForSyDe.Deep.Netlist +-- This aparently unnecesary SysDef import is needed as a workaround for +-- http://hackage.haskell.org/trac/ghc/ticket/1012 +import ForSyDe.Deep.System.SysDef() +import ForSyDe.Deep.Process.ProcType (ProcType(..)) +import Data.Typeable.FSDTypeRepLib + + +-- IMPORTANT NOTE: even if all ProcType constraints in SysFun and +-- SysFunToSimFun instances could be less restrictive +-- (Typeable would do), it makes more sense, and who nows, +-- maybe we end up requiring full ProcType functionality at +-- some point. + + +-- This three instances are the ones in charge of providing the necessary +-- recursion step needed to support the variable number of arguments. +-- In each step, the system function is provided with a new input signal port +-- until the output signals are obtained. +instance (ProcType a, SysFun f) => SysFun (Signal a -> f) where + applySysFun f ids = (outSignals, currInType : nextInTypeReps, outTypeReps) + where (outSignals, nextInTypeReps, outTypeReps) = + case ids of + [] -> applySysFun (f (Signal (newInPort "default"))) [] + (i:is) -> applySysFun (f (Signal (newInPort i))) is + currInType = fsdTypeOf (undefined :: Signal a) + fromListSysFun f accum s = fromListSysFun f ((unSignal s):accum) + +instance (ProcType a, SysFunToSimFun sysFun simFun) => + SysFunToSimFun (Signal a -> sysFun) ([a] -> simFun) where + fromDynSimFun f accum s = fromDynSimFun f ((map toDyn s):accum) + +instance (ProcType a, SysFunToIOSimFun sysFun simFun) => + SysFunToIOSimFun (Signal a -> sysFun) ([a] -> simFun) where + fromTHStrSimFun f accum s = fromTHStrSimFun f ((map unsafeLift s):accum) + -- FIXME: This won't be needed once the Data a => Lift a instance + -- is created + where unsafeLift = unsafePerformIO.runQ.lift + +-- Generate instances for the system function outputs up to the maximum +-- tuple size +$(let concatMapM f xs = liftM concat (mapM f xs) + listFunOutInstances = liftM (\(a,b,c) -> [a,b,c]) . funOutInstances + msg = "Generating and compiling " ++ show maxTupleSize ++ + " output instances of " ++ + show ''SysFun ++ ", " ++ show ''SysFunToSimFun ++ + " and " ++ show ''SysFunToIOSimFun ++ + ", this might take some time ... \n" + in runIO (putStrLn $ msg) >> + concatMapM listFunOutInstances [0..maxTupleSize] + ) diff --git a/src/ForSyDe/Deep/Version.hs b/src/ForSyDe/Deep/Version.hs new file mode 100644 --- /dev/null +++ b/src/ForSyDe/Deep/Version.hs @@ -0,0 +1,35 @@ +----------------------------------------------------------------------------- +-- | +-- Module : ForSyDe.Deep.Version +-- Copyright : (c) ES Group, KTH/ICT/ES 2016 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : forsyde-dev@ict.kth.se +-- Stability : experimental +-- Portability : portable +-- +-- Version information for the current build +-- +----------------------------------------------------------------------------- + +module ForSyDe.Deep.Version (getVersion) where + +import Paths_forsyde_deep (version) +import Data.Version (showVersion) + +import Language.Haskell.TH (runIO) +import Language.Haskell.TH.Syntax +import System.Process (readProcess) +import Control.Exception (catch) +import System.IO.Error (IOError) + +getVersion :: Q Exp +getVersion = do + vstr <- runIO $ catch version_git version_cabal + return (LitE $ StringL $ init vstr) + + where + version_git :: IO String + version_git = readProcess "git" ["describe", "--tags", "--dirty"] "" + version_cabal :: IOError -> IO String + version_cabal _ = return $ showVersion version diff --git a/src/Language/Haskell/TH/Lift.hs b/src/Language/Haskell/TH/Lift.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/TH/Lift.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE MagicHash, TemplateHaskell, CPP #-} +{-# OPTIONS_GHC -fno-warn-deprecations #-} +-- Due to the use of unboxed types, TH, and deprecated Packed Strings +----------------------------------------------------------------------------- +-- | +-- Module : Language.Haskell.TH.Lift +-- Copyright : (c) Ian Lynagh, 2006, (c) SAM Group, KTH/ICT/ECS 2007-2008 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : forsyde-dev@ict.kth.se +-- Stability : experimental +-- Portability : portable +-- +-- Automatically derive Template Haskell's 'Lift' class for datatypes +-- using Template Haskell splices. +-- +-- Based on Lynagh's th-lift package: +----------------------------------------------------------------------------- +module Language.Haskell.TH.Lift (deriveLift1, deriveLift) where + +import GHC.Exts +import Language.Haskell.TH +import Language.Haskell.TH.Syntax +import Control.Monad (liftM) + +modName :: String +modName = "Language.Haskell.TH.Lift" + +-- | Automatically generate an instance of 'Lift' for one data type. For example: +-- +-- >{-# LANGUAGE TemplateHaskell #-} +-- >module Colour where +-- >import Language.Haskell.TH.Lift +-- > +-- >data RGB = Red | Green | Blue +-- > +-- >-- Generate the Lift instance of RGB +-- >$(deriveLift1 ''RGB) +deriveLift1 :: Name -> Q [Dec] +deriveLift1 = (liftM (\a -> [a])) . deriveLift + +-- | Version of 'deriveLif1' used to automatically generate instances +-- of Lift for multiple data types. For instance: +-- +-- >{-# LANGUAGE TemplateHaskell #-} +-- >module Colour where +-- >import Language.Haskell.TH.Lift +-- > +-- >data RGB = Red | Green | Blue +-- > +-- >data Num a => Pixel a = Pixel a a a +-- > +-- >-- Generate Lift instances for RGB and Pixel +-- >$(mapM deriveLift [''RGB, ''Pixel]) +deriveLift :: Name -> Q Dec +deriveLift n + = do i <- reify n + case i of +#if __GLASGOW_HASKELL__ >= 800 + TyConI (DataD dcxt _ vs _ cons _) -> +#else + TyConI (DataD dcxt _ vs cons _) -> +#endif + let ctxt = liftM (++ dcxt) $ + cxt [appT (conT ''Lift) (varT v') | v' <- vs'] + typ = foldl appT (conT n) $ map varT vs' + fun = funD 'lift (map doCons cons) + vs' = map (\v -> case v of + PlainTV name -> name + KindedTV name _ -> name) vs + in instanceD ctxt (conT ''Lift `appT` typ) [fun] + --do sh<-instanceD ctxt (conT ''Lift `appT` typ) [fun] + -- error (pprint sh) + _ -> error (modName ++ ".deriveLift: unhandled: " ++ pprint i) + +doCons :: Con -> Q Clause +doCons (NormalC c sts) + = do let ns = zipWith (\_ i -> "x" ++ show i) sts [(0::Integer)..] + con = [| conE c |] + args = [ [| lift $(varE (mkName n)) |] | n <- ns ] + e = foldl (\e1 e2 -> [| appE $e1 $e2 |]) con args + clause [conP c (map (varP . mkName) ns)] (normalB e) [] +doCons (InfixC st1 n st2) = doCons (NormalC n [st1,st2]) +doCons (RecC n vsts) + = let st (_, s, t) = (s, t) + in doCons (NormalC n (map st vsts)) +doCons c = error (modName ++ ".doCons: Unhandled constructor: " ++ pprint c) + +instance Lift Name where + lift (Name occName nameFlavour) = [| Name occName nameFlavour |] + +instance Lift OccName where + lift (OccName str) = [| OccName str |] + +instance Lift ModName where + lift (ModName str) = [| ModName str |] + +instance Lift PkgName where + lift (PkgName str) = [| PkgName str |] + +--instance Lift PackedString where +-- lift ps = [| packString $(lift $ unpackPS ps) |] + +instance Lift NameFlavour where + lift NameS = [| NameS |] + lift (NameQ modName) = [| NameQ modName |] + lift (NameU i) = [| NameU i |] + lift (NameL i) = [| NameL i |] + lift (NameG nameSpace pkgName modName) + = [| NameG nameSpace pkgName modName |] + +instance Lift NameSpace where + lift VarName = [| VarName |] + lift DataName = [| DataName |] + lift TcClsName = [| TcClsName |] + diff --git a/src/Language/Haskell/TH/LiftInstances.hs b/src/Language/Haskell/TH/LiftInstances.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/TH/LiftInstances.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE TemplateHaskell,CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Language.Haskell.TH.LiftInstances +-- Copyright : (c) SAM Group, KTH/ICT/ECS 2007-2008 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : forsyde-dev@ict.kth.se +-- Stability : experimental +-- Portability : portable +-- +-- This module provides 'Lift' instances for all the AST-types defined +-- in "Language.Haskell.Syntax" +-- +-- Furthermore it provides a function (metaLift) which lifts an expression +-- twice, obtaing its meta AST (the AST of the AST) +-- +----------------------------------------------------------------------------- +module Language.Haskell.TH.LiftInstances (metaLift) where + +import Language.Haskell.TH.Lift (deriveLift) + +import Language.Haskell.TH.Syntax + (Guard, +#if __GLASGOW_HASKELL__ >= 800 + -- Strict was replaced and became a synonym for Bang in GHC 8.0.1 + Bang, + Overlap, + SourceUnpackedness, + SourceStrictness, + DecidedStrictness, + TypeFamilyHead, + InjectivityAnn, + FamilyResultSig, +#else + -- This is only for backwards compatibility with ghc 7.10. + Strict, +#endif + Callconv, + Safety, + Body, + Con, + FunDep, + Foreign, + Lit, + Pat, + Match, + Stmt, + Range, + Clause, + Type, + Dec, + Exp, + Q, + Lift(..), + TyVarBndr, + FamFlavour, + Pragma, + AnnLookup, + AnnTarget, + Fixity, + FixityDirection, + Inline, + Module, + ModuleInfo, + Phases, + Role, + RuleBndr, + RuleMatch, + TyLit, + TySynEqn + ) + +$(mapM deriveLift + [''Guard, +#if __GLASGOW_HASKELL__ >= 800 + -- Strict was replaced and became a synonym (for which we don't need any + -- lift instances) for Bang in GHC 8.0.1 + ''Bang, + ''Overlap, + ''SourceUnpackedness, + ''SourceStrictness, + ''DecidedStrictness, + ''TypeFamilyHead, + ''InjectivityAnn, + ''FamilyResultSig, +#else + -- This is only for backwards compatibility with ghc 7.10. + ''Strict, +#endif + ''Callconv, + ''Safety, + ''Body, + ''Con, + ''FunDep, + ''Foreign, + ''Lit, + ''Pat, + ''Match, + ''Stmt, + ''Range, + ''Clause, + ''Type, + ''Dec, + ''Exp, + ''TyVarBndr, + ''FamFlavour, + ''Pragma, + + ''AnnLookup, + ''AnnTarget, + ''Fixity, + ''FixityDirection, + ''Inline, + ''Module, + ''ModuleInfo, + ''Phases, + ''Role, + ''RuleBndr, + ''RuleMatch, + ''TyLit, + ''TySynEqn + ]) + +-- | lift twice, getting the meta AST (the AST of the AST) +metaLift :: Lift a => a -> Q Exp +metaLift exp = do expAST <- lift exp + lift expAST + diff --git a/src/Language/Haskell/TH/TypeLib.hs b/src/Language/Haskell/TH/TypeLib.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/TH/TypeLib.hs @@ -0,0 +1,320 @@ +{-# LANGUAGE TemplateHaskell #-} +----------------------------------------------------------------------------- +-- | +-- Module : Language.Haskell.TH.TypeLib +-- Copyright : (c) SAM Group, KTH/ICT/ECS 2007-2008 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : forsyde-dev@ict.kth.se +-- Stability : experimental +-- Portability : portable +-- +-- This module provides basic functions related to Template-Haskell's 'Type'. +-- +----------------------------------------------------------------------------- +module Language.Haskell.TH.TypeLib + (Context, + mkContext, + monoContext, + isPoly, + contextVarNames, + contextConstraints, + mkForallT, + unArrowT, + unAppT, + (-->), + reAppT, + reArrowT, + dynTHType, + thTypeOf, + typeRep2Type, + tyCon2Type, + type2TypeRep) + where + +import Data.Typeable.Internal +import Data.Dynamic +import Language.Haskell.TH (Type(..), Cxt, TyVarBndr(..), pprint, mkName, nameModule, nameBase) +import Text.Regex.Posix ((=~)) +import Data.Maybe(isJust, fromMaybe) + +-- Due to type translations +import Data.Word (Word, Word8, Word16, Word32, Word64) +import Data.Int (Int8, Int16, Int32, Int64) +import System.IO (Handle) +import Data.IORef (IORef) +import Foreign (Ptr, FunPtr, StablePtr, ForeignPtr) +--import Control.OldException (Exception, +-- AsyncException, +-- ArrayException, +-- ArithException, +-- IOException) +import Data.Ratio (Ratio) +import Control.Concurrent.MVar (MVar) + +----------- +-- Context +----------- + +-- | A 'Context' represents the forall part and constraints of a type +-- (see 'ForallT') +-- For instance, the context of the type +-- @ +-- forall a b. (Show a, Show b) => (a,b) +-- @ +-- is @forall a b. (Show a, Show b) =>@ +-- where @a@ and @b@ are the the context variables and +-- @(Show a, Show b)@ are the context constraints +data Context = Context + [TyVarBndr] -- Variable names + Cxt -- Constraints (the context itself) + +instance Show Context where +-- FIXME: this is really ugly, refactor and improve its look + showsPrec _ (Context tvb cxt) = + showVars tvb . showConstraints cxt + where showVars tvb = showForall (not (null tvb)) (showVars' tvb) + showVars' ((PlainTV n):tvbs) = shows n . showChar ' ' . showVars' tvbs + showVars' [] = id + showConstraints c = (\s -> if not (null c) then ' ':s else s). + showParen (length c > 1) (showConstraints' c) . + (\s -> if not (null c) then s ++ " =>" else s) + showConstraints' [c] = shows c + showConstraints' (c:cx) = showString (pprint c) . showString ", " . + showConstraints' cx + showConstraints' [] = id + showForall b s = if b then showString "forall " . s . showChar '.' + else s + +-- | 'Context' constructor +mkContext :: [TyVarBndr] -> Cxt -> Context +mkContext tvb c = Context tvb c + +-- | Empty context for monomorphic types +monoContext :: Context +monoContext = Context [] [] + +-- | Tells if the context corresponds to a polymorphic type +isPoly :: Context -> Bool +isPoly (Context [] _) = False +isPoly _ = True + +-- | Returns the variable names related to a context +contextVarNames :: Context -> [TyVarBndr] +contextVarNames (Context tvb _) = tvb + +-- | Returns the context constraints +contextConstraints :: Context -> Cxt +contextConstraints (Context _ cxt) = cxt + +-- | Builds a 'ForallT' type out of a context and a type +mkForallT :: Context -> Type -> Type +mkForallT (Context tvb cxt) t = ForallT tvb cxt t + +-------------------------------- +-- Functions to observe a 'Type' +-------------------------------- + +-- | Obtains the arguments and return type of a given 'Type' +-- (normally a function) +-- together with its 'Context' (non-empty if the type is polymorphic) +unArrowT :: Type -- ^ Type to observe + -> ([Type], Type, Context) -- ^ (args 'Type', ret 'Type', 'Context') +unArrowT (ForallT names cxt t) = let (args,ret) = unArrowT' t + in (args, ret, Context names cxt) +unArrowT t = let (args,ret) = unArrowT' t + in (args, ret, Context [] []) + +-- unArrowT for non-Forall Types +unArrowT' :: Type -> ([Type], Type) +unArrowT' ((ArrowT `AppT` first) `AppT` rest) = let (args, ret) = unArrowT' rest + in (first:args, ret) +unArrowT' t = ([],t) + +-- | Obtains the type constructor of a 'Type' together with its +-- arguments and its 'Context' (non-empty if the type is polymorphic) +unAppT :: Type -- ^ Type to observe + -> (Type, [Type], Context) -- ^ (Constructor, args 'Type', Context) +unAppT (ForallT names cxt t) = let (cons, args) = unAppT' t + in (cons, args, Context names cxt) +unAppT t = let (cons, args) = unAppT' t + in (cons, args, Context [] []) + +-- unAppT for non-Forall Types +unAppT' :: Type -> (Type, [Type]) +unAppT' t = (first,rest) + where first:rest = unAppT'ac [] t + -- Since the constructor is a leaf of the Type tree representation, + -- it is the last element to be gathered and thus, an accumulator + -- is used to reverse the list to be returned + unAppT'ac :: [Type] -> Type -> [Type] + unAppT'ac acum (prefix `AppT` lastarg) = unAppT'ac (lastarg:acum) prefix + unAppT'ac acum cons = cons:acum +------------------------------ +-- Functions to build a 'Type' +------------------------------ + +-- | Form a function type out of two types +(-->) :: Type -- ^ Argument type + -> Type -- ^ Return type + -> Type -- ^ Resulting function +arg --> ret = (ArrowT `AppT` arg) `AppT` ret + +-- | Rebuild a type out of a constructor, its argument types and its context +-- (inverse of 'unAppT') +reAppT :: (Type, [Type], Context) -- ^ (Constructor, type arguments, context) + -> Type -- ^ resulting 'Type' +-- Polymorphic types +reAppT (cons, args, cxt) | isPoly cxt = + mkForallT cxt (reAppT (cons, args, monoContext)) +-- Monomorphic types +reAppT (cons, args, _) = foldl1 AppT (cons:args) + +-- | Rebuild a function type out of its argument types, return type +-- and context (inverse of 'ArrowT') +reArrowT :: ([Type], Type, Context) -- ^ (Constructor, type arguments, context) + -> Type -- ^ resulting 'Type' +-- Polymorphic types +reArrowT (args, ret, cxt) | isPoly cxt = + mkForallT cxt (reArrowT (args, ret, monoContext)) +-- Monomorphic types +reArrowT (args, ret, _) = foldr1 (-->) (args ++ [ret]) + +------------------------------------------------------------------- +-- Transforming Language.Haskell.TH.Type into Data.Typeable.TypeRep +------------------------------------------------------------------- + +-- | Translate monomorphic Template Haskell Types to TypeReps +-- If the type os polymorhpic 'Nothing' will be returned +type2TypeRep :: Type -> Maybe TypeRep +-- Note: In the case of constructors, we don't need to translate to a TyCon first +-- because: +-- +-- mkTyConApp tCon [t1 .. tn] = mkTyConApp tCon [] `mkAppTy` t1 ... `mkAppTy` tn +type2TypeRep (ForallT (_:_) _ _) = Nothing +type2TypeRep (ForallT _ (_:_) _) = Nothing +type2TypeRep (ForallT _ _ t) = type2TypeRep t +type2TypeRep (VarT _) = Nothing +-- Tuple tyCon strings don't correspond to hierarchical names. They are +-- simply sequences of commas plus paranthesis: e.g. 2-tuple "(,)" 3-tuple "(,,)" .... +type2TypeRep (TupleT n) = Just $ strCon ('(':replicate (n-1) ','++")") +type2TypeRep ArrowT = Just $ typeableCon (undefined :: () -> ()) +type2TypeRep ListT = Just $ typeableCon (undefined :: [()]) +type2TypeRep (t1 `AppT` t2) = do + tRep1 <- type2TypeRep t1 + tRep2 <- type2TypeRep t2 + return $ tRep1 `mkAppTy` tRep2 +-- Constructors +type2TypeRep (ConT name) + -- FIXME: This should not be needed in the newer versions of ghc: + -- There are certain TyCons whose string does not correspond + -- to the hierarchical name of the constructor (the instances generated + -- in Data.Typeable), we have to cover all those cases by hand + -- See http://hackage.haskell.org/trac/ghc/ticket/1841 for details + | isJust mSpecialTypeRep = mSpecialTypeRep + -- Tuples (they cannot be put in the table) + | isTup = Just $ strCon tupCons + -- General case + | otherwise = Just $ strCon (show name) + where (isTup, tupCons) = + case (show name =~ "^Data\\.Tuple\\.\\((,+)\\)$") + :: (String, String, String, [String]) of + -- it's a tuple, we get the commas subpart (,+) + (_, _, _, [commas]) -> (True, commas) + _ -> (False, "") + mSpecialTypeRep = lookup name specialConTable + specialConTable = + [(''() , typeableCon (undefined :: ()) ), + (''[] , typeableCon (undefined :: [()]) ), + (''Maybe , typeableCon (undefined :: Maybe ()) ), + (''Ratio , typeableCon (undefined :: Ratio ()) ), + (''Either , typeableCon (undefined :: Either () ()) ), + (''(->) , typeableCon (undefined :: () -> ()) ), + (''MVar , typeableCon (undefined :: MVar ()) ), + --(''Exception , typeableCon (undefined :: Exception) ), + --(''IOException , typeableCon (undefined :: IOException) ), + --(''ArithException , typeableCon (undefined :: ArithException) ), + --(''ArrayException , typeableCon (undefined :: ArrayException) ), + --(''AsyncException , typeableCon (undefined :: AsyncException) ), + (''Ptr , typeableCon (undefined :: Ptr ()) ), + (''FunPtr , typeableCon (undefined :: FunPtr ()) ), + (''ForeignPtr , typeableCon (undefined :: ForeignPtr ()) ), + (''StablePtr , typeableCon (undefined :: StablePtr ()) ), + (''IORef , typeableCon (undefined :: IORef ()) ), + (''Bool , typeableCon (undefined :: Bool) ), + (''Char , typeableCon (undefined :: Char) ), + (''Float , typeableCon (undefined :: Float) ), + (''Double , typeableCon (undefined :: Double) ), + (''Int , typeableCon (undefined :: Int) ), + (''Word , typeableCon (undefined :: Word) ), + (''Integer , typeableCon (undefined :: Integer) ), + (''Ordering , typeableCon (undefined :: Ordering) ), + (''Handle , typeableCon (undefined :: Handle) ), + (''Int8 , typeableCon (undefined :: Int8) ), + (''Int16 , typeableCon (undefined :: Int16) ), + (''Int32 , typeableCon (undefined :: Int32) ), + (''Int64 , typeableCon (undefined :: Int64) ), + (''Word8 , typeableCon (undefined :: Word8) ), + (''Word16 , typeableCon (undefined :: Word16) ), + (''Word32 , typeableCon (undefined :: Word32) ), + (''Word64 , typeableCon (undefined :: Word64) ), + (''TyCon , typeableCon (undefined :: TyCon) ), + (''TypeRep , typeableCon (undefined :: TypeRep) )] + + +------------------------------------------------------------------- +-- Transforming Data.Typeable.TypeRep into Language.Haskell.TH.Type +------------------------------------------------------------------- + +-- | Obtain the Template Haskel type of a dynamic object +dynTHType :: Dynamic -> Type +dynTHType = typeRep2Type . dynTypeRep + +-- | Give the template haskell 'Type' of a Typeable object +thTypeOf :: Typeable a => a -> Type +thTypeOf = typeRep2Type . typeOf + +-- | Translate a 'TypeRep' to a Template Haskell 'Type' +typeRep2Type :: TypeRep -> Type +typeRep2Type rep = let (con, reps) = splitTyConApp rep + in reAppT (tyCon2Type con, map typeRep2Type reps, monoContext) + +-- | Gives the corresponding Template Haskell 'Type' of a 'TyCon' +tyCon2Type :: TyCon -> Type +tyCon2Type = tyConStr2Type . tyConName + + +---------------------------- +-- Internal Helper Functions +---------------------------- + +-- | transfrom a Typeable type constructor to a Template Haskell Type +tyConStr2Type :: String -> Type +-- NOTE: The tyCon strings of basic types are not qualified and buggy in +-- some cases. +-- See http://hackage.haskell.org/trac/ghc/ticket/1841 +-- FIXME: update this function whenever the bug is fixed +-- FIXME FIXME: This code is incorrect: +-- mkName doesn't generate global names! ''Maybe /= mkName "Data.Maybe.Maybe" +-- in addition global names contain a packagename which cannot be guessed from +-- the type representation. +tyConStr2Type "->" = ArrowT +tyConStr2Type tupStr | tupStr =~ "^,+$" = + ConT (mkName $ "Data.Tuple.(" ++ tupStr ++ ")") +tyConStr2Type str = ConT $ mkName str + +-- Get the type constructor corresponding to a String +-- in form of a type representation +strCon :: String -> TypeRep +strCon str = mkTyCon3 pkg mod base `mkTyConApp` [] + where + name = mkName str + pkg = "" + mod = fromMaybe "" (nameModule name) + base = nameBase name + + +-- Get the type constructor corresponding to a typeable value +-- in form of a type representation +typeableCon :: Typeable a => a -> TypeRep +typeableCon t = (typeRepTyCon . typeOf) t `mkTyConApp` [] diff --git a/tests/Install.hs b/tests/Install.hs new file mode 100644 --- /dev/null +++ b/tests/Install.hs @@ -0,0 +1,47 @@ +module Install (testInstall) where + +import Distribution.Simple.SetupWrapper +import System.Process +import System.Directory +import System.FilePath +import System.Exit +import System.IO + +-- Test if the ForSyDe project configures, builds, generates +-- the haddock documentation and installs without problems. +-- In order to avoid poisoning the haskell-package databases +-- and the file system, the package is configured with +-- the local prefix "testInstallation/" and registered +-- in a fresh local package database called "testInstallation.conf" +-- Note that this test will only work with ghc because the creation +-- of a new package database relies on ghc-pkg. +-- Also note that the current working directory must be the root of the project. +testInstall :: IO () +testInstall = do + cwd <- getCurrentDirectory + putStrLn "Configuring ForSyDe ..." + setupCWD ["configure","--user","--prefix=" ++ cwd "testInstallation", + "-v0"] + putStrLn " done.\n" + putStrLn "Building ForSyDe ..." + setupCWD ["build","-v0"] + putStrLn " done.\n" + putStrLn "Testing the haddock markup of ForSyDe ... " + setupCWD ["haddock", "-v0"] + putStrLn " done.\n" + putStrLn "Copying ForSyDe under testInstallation/ ... " + setupCWD ["copy", "-v0"] + putStrLn " done.\n" + putStrLn ("Registering ForSyDe in fresh package database " ++ + "(testInstallation.conf) ...") + -- Cabal doesn't allow specifying an alternative package database: + -- http://hackage.haskell.org/trac/hackage/ticket/307 + -- Thus, we register the package by hand using ghc-pkg + setupCWD ["register", "--gen-pkg-config=ForSyDeconfig","-v0"] + code <- waitForProcess =<< + runCommand "ghc-pkg -f testInstallation.conf register ForSyDeconfig" + case code of + ExitSuccess -> return () + e@(ExitFailure _) -> exitWith e + putStrLn "done." + where setupCWD command = setupWrapper command Nothing diff --git a/tests/examples/Main.hs b/tests/examples/Main.hs new file mode 100644 --- /dev/null +++ b/tests/examples/Main.hs @@ -0,0 +1,22 @@ +-- Property-testing wrapper module +module Main (main) where +import Test.HUnit +import System.Exit +import System.IO +import System.Directory (createDirectoryIfMissing, setCurrentDirectory) +import VHDLBackend (vhdlBackendTest) + + +main :: IO () +main = do + hSetBuffering stdout LineBuffering + putStrLn "Running ForSyDe's unit test suite" + createDirectoryIfMissing True workdir + setCurrentDirectory workdir + runTestCount $ test ["VHDL Backend Test" ~: vhdlBackendTest ] + where runTestCount t = do (c, _) <- myRunTestText t + if errors c /= 0 || failures c /= 0 + then exitFailure + else exitWith ExitSuccess + myRunTestText = runTestText (PutText (\str _ _ -> putStrLn str) ()) + workdir = "dist/test/temp" diff --git a/tests/examples/VHDLBackend.hs b/tests/examples/VHDLBackend.hs new file mode 100644 --- /dev/null +++ b/tests/examples/VHDLBackend.hs @@ -0,0 +1,289 @@ +{-# LANGUAGE TemplateHaskell #-} +-- VHDL-Backend property testing module +-- ALl the tests are based on asserting that the internal simulation of the system +-- equals the simulation of the generated vhdl code with modelsim +module VHDLBackend (vhdlBackendTest) where +-- import the example-modules +import ALU +--import Counter +import ParAddFour +import Multiplexer +--import Multiplexer_FSVector +import SeqAddFour +import ButtonEncoder +import ZipTwist +import CarrySelectAdder +import Null +import LFSR +import MapVector +import MapVectorOperatorSection +import MapVectorTransformation +import MapLambdaVector +import FoldlVector +import ZipWithVector +import FoldlVectorOperator +import ZipWithVectorOperator + +import Control.Monad (liftM, replicateM) +import Data.List (transpose) +import Data.Param.FSVec (vectorTH, reallyUnsafeVector) +import System.Random +import Test.HUnit +import ForSyDe.Deep +import Data.Int +import Test.QuickCheck (generate, vectorOf, choose) + +vhdlBackendTest :: Test +vhdlBackendTest = test [aluTest, + --counterTest, + parAddFourTest, + muxTest, + --muxFSVecTest, + seqAddFourTest, + buttonEncoderTest, + zipTwistTest, + nullTest, + lfsrTest, + mapVTest, + mapVectorTransformationTest, + mapLambdaVectorTest, + mapVectorOperatorSectionTest, + foldlVOpTest, + zipWithVOpTest, + foldlVTest, + zipWithVTest + ] + +-- systematic test for the ALU +aluTest :: Test +aluTest = "aluTest" ~: outSim <~=?> outVHDL + where and = $(vectorTH [H,H]) + or = $(vectorTH [H,L]) + add = $(vectorTH [L,H]) + shiftl = $(vectorTH [L,L]) + fourBitCombs = map reallyUnsafeVector (combN 4 [L,H]) + [arg1,arg2] = parCombN 2 fourBitCombs + l = length arg1 + select = replicate l and ++ + replicate l or ++ + replicate l add ++ + replicate l shiftl + op1 = arg1 ++ arg1 ++ arg1 ++ arg1 + op2 = arg2 ++ arg2 ++ arg2 ++ arg2 + outSim = simALU select op1 op2 + outVHDL = vhdlTest Nothing aluSys select op1 op2 + +counterTest :: Test +counterTest = TestCase $ assertFailure "Not running counterTest due to broken newSysFunTHName" +--counterTest = "counterTest" ~: "first 400 outputs" ~: +-- out400Sim <~=?> out400VHDLSim +-- where out400Sim = take 400 simCounter +-- out400VHDLSim = vhdlTest (Just 400) counterSys + +parAddFourTest :: Test +parAddFourTest = "parAddFourTest" ~: test doTest + where -- testt the overflows, and 400 different pseudorandom numbers + lastInt32 :: Num a => a + lastInt32 = 2147483647 + firstInt32 :: Num a => a + -- FIXME: this should be -2147483648, but due to bug http://code.google.com/p/forsyde-comp/issues/detail?id=22 it was set to -2147483647 + firstInt32 = -2147483647 + gen400Int32 :: IO [Int32] + gen400Int32 = do + let randomInt32 :: IO Int32 + randomInt32 = do + let getInt32Range :: IO Integer + getInt32Range = getStdRandom (randomR (firstInt32, lastInt32)) + liftM fromIntegral getInt32Range + replicateM 400 randomInt32 + doTest :: IO () + doTest = do arg1 <- gen400Int32 + arg2 <- gen400Int32 + arg3 <- gen400Int32 + arg4 <- gen400Int32 + arg5 <- gen400Int32 + let sim = simParAddFour (1:(-1):arg1) + -- (firstInt32:lastInt32:arg2) + -- (lastInt32:firstInt32:arg3) + arg2 + arg3 + (-1:1:arg4) + (0:1:arg5) + simVHDL = vhdlTest Nothing + parAddFourSys + (1:(-1):arg1) + -- (firstInt32:lastInt32:arg2) + -- (lastInt32:firstInt32:arg3) + arg2 + arg3 + (-1:1:arg4) + (0:1:arg5) + resVHDL <- simVHDL + sim @=? resVHDL + + +muxTest :: Test +muxTest = "muxTest" ~: Multiplexer.simMux sel input <~=?> + vhdlTest Nothing Multiplexer.muxSysDef sel input + where sel = [(L,L),(L,H),(H,L),(H,H)] + input = [(L,L,L,H),(L,L,H,L),(L,H,L,L),(H,L,L,L)] + + + +muxFSVecTest :: Test +muxFSVecTest = TestCase $ assertFailure "Not running muxFSVecTest due to broken newSysFunTHName" +--muxFSVecTest = "muxTest" ~: Multiplexer_FSVector.simMux sel input <~=?> +-- vhdlTest Nothing Multiplexer_FSVector.muxSysDef sel input +-- where sel = [$(vectorTH [L,L]),$(vectorTH [L,H]),$(vectorTH [H,L]),$(vectorTH [H,H])] +-- input = [$(vectorTH [L,L,L,H]), $(vectorTH [L,L,H,L]), $(vectorTH [L,H,L,L]), +-- $(vectorTH [H,L,L,L])] +-- +seqAddFourTest :: Test +seqAddFourTest = "seqAddFourTest" ~: simAddFour input <~=?> + vhdlTest Nothing addFourSys input + where input = [-100,-99..100] + +buttonEncoderTest :: Test +buttonEncoderTest = "buttonEncoderTest" ~: simButtonEncoder input <~=?> + vhdlTest Nothing buttonEncoderSys input + where input = [(H,L,L,L), (L,H,L,L), (L,L,H,L), (L,L,L,H), (L,L,L,L)] + +zipTwistTest :: Test +zipTwistTest = "zipTwistTest" ~: + simZipTwist input1 input2 input3 input4 input5 input6 <~=?> + vhdlTest Nothing zipTwistSys input1 input2 input3 input4 input5 input6 + where input1 = [-100..0] + input2 = [-10..90] + input3 = [100..200] + input4 = [350..450] + input5 = [-400..(-300)] + input6 = [-50..50] + +nullTest :: Test +-- we don't test quartus here, because it complains about no logic +--nullTest = "nullTest" ~: simNull <~=?> writeAndModelsimVHDL Nothing nullSysDef +nullTest = "nullTest" ~: simNull <~=?> vhdlTest Nothing nullSysDef + +lfsrTest :: Test +lfsrTest = "lsfrTest" ~: outSim <~=?> outVHDL + where take400Tup4 (i1,i2,i3,i4) = (take 400 i1, take 400 i2, take 400 i3, + take 400 i4) + outSim = take400Tup4 simlfsr + outVHDL = vhdlTest (Just 400) lfsrSys + +mapVTest :: Test +mapVTest = "mapVTest" ~: outSim <~=?> outVHDL + where + outSim = take 100 simVecCounter + outVHDL = vhdlTest (Just 100) vecCounterSys + +foldlVTest :: Test +foldlVTest = "foldlVTest" ~: TestCase ioTest + where + int32Range = (-2147483647,2147483647):: (Int32, Int32) + ioTest = do + testData <- generate.(vectorOf 100).(vectorOf 4).choose $ int32Range + let input = map reallyUnsafeVector testData + outSim = simFoldingAdder input + outVHDL <- vhdlTest (Just 100) foldingAdderSys input + outSim @=? outVHDL + +zipWithVTest :: Test +zipWithVTest = "zipWithVTest" ~: TestCase ioTest + where + int32Range = (-2147483647,2147483647):: (Int32, Int32) + ioTest = do + testDataA <- generate.(vectorOf 100).(vectorOf 4).choose $ int32Range + testDataB <- generate.(vectorOf 100).(vectorOf 4).choose $ int32Range + let inputA = map reallyUnsafeVector testDataA + inputB = map reallyUnsafeVector testDataB + outSim = simZipWithVSys inputA inputB + outVHDL <- vhdlTest (Just 100) zipWithVSys inputA inputB + outSim @=? outVHDL + +foldlVOpTest :: Test +foldlVOpTest = "foldlVOpTest" ~: TestCase ioTest + where + int32Range = (-2147483647,2147483647):: (Int32, Int32) + ioTest = do + testData <- generate.(vectorOf 100).(vectorOf 4).choose $ int32Range + let input = map reallyUnsafeVector testData + outSim = simFoldingAdderOp input + outVHDL <- vhdlTest (Just 100) foldingAdderOpSys input + outSim @=? outVHDL + +zipWithVOpTest :: Test +zipWithVOpTest = "zipWithVOpTest" ~: TestCase ioTest + where + int32Range = (-2147483647,2147483647):: (Int32, Int32) + ioTest = do + testDataA <- generate.(vectorOf 100).(vectorOf 4).choose $ int32Range + testDataB <- generate.(vectorOf 100).(vectorOf 4).choose $ int32Range + let inputA = map reallyUnsafeVector testDataA + inputB = map reallyUnsafeVector testDataB + outSim = simZipWithVOpSys inputA inputB + outVHDL <- vhdlTest (Just 100) zipWithVOpSys inputA inputB + outSim @=? outVHDL + + +mapVectorOperatorSectionTest :: Test +mapVectorOperatorSectionTest = "mapVectorOperatorSectionTest" ~: outSim <~=?> outVHDL + where + outSim = take 100 simVecOpSecCounter + outVHDL = vhdlTest (Just 100) vecOpSecCounterSys + +mapLambdaVectorTest :: Test +mapLambdaVectorTest = "mapLambdaVectorTest" ~: outSim <~=?> outVHDL + where + outSim = take 100 simLamVecCounter + outVHDL = vhdlTest (Just 100) vecLamCounterSys + +mapVectorTransformationTest :: Test +mapVectorTransformationTest = "mapVectorTransformationTest" ~: outSim <~=?> outVHDL + where + outSim = take 100 simTransfVecCounter + outVHDL = vhdlTest (Just 100) transfVecCounterSys + +------------------- +-- Helper functions +------------------- + + +-- run a vhdl testbench with custom backend options +vhdlTest :: SysFunToIOSimFun sysF simF => Maybe Int -> SysDef sysF -> simF +-- vhdlTest = writeAndModelsimVHDLOps testVHDLOps +vhdlTest = writeAndGhdlVHDL + +-- testing VHDL options +testVHDLOps :: VHDLOps +testVHDLOps = defaultVHDLOps{execQuartus=Just checkSynthesisQuartus} + +-- Compare an IO test with a pure expected result +(<~=?>) :: (Eq a, Show a) => a -> IO a -> Test +expected <~=?> actualM = TestCase $ do a <- actualM + expected @=? a + + +-- | permutation a list +-- Each element of the input list indicates the posibilities of each +-- positional elements in the resulting lists +permut :: [[a]] -> [[a]] +permut [] = [] +permut [xs] = map (\x -> [x]) xs +permut (xs:xss) = let res = permut xss + in concatMap (\e -> map (:e) xs) res + +-- | Combinations of 2 elements from a set of values +comb2 :: [a] -> [(a,a)] +comb2 xs = concatMap (\i -> map (\j -> (i,j) ) xs) xs + +-- | Parallel combination of N elements +parCombN :: Int -> [a] -> [[a]] +parCombN n xs = transpose $ combN n xs + +-- | Combinations os N elements from a set of values +combN :: Int -> [a] -> [[a]] +combN n _ | n <= 0 = [] +combN 1 xs = map (\x -> [x]) xs +combN n xs = let res = combN (n-1) xs + in concatMap (\i -> map (\j -> j:i) xs) res