packages feed

forsyde-deep (empty) → 0.2.0

raw patch · 81 files changed

+13618/−0 lines, 81 filesdep +HUnitdep +QuickCheckdep +basebuild-type:Customsetup-changed

Dependencies added: HUnit, QuickCheck, base, containers, directory, filepath, forsyde-deep, mtl, parameterized-data, pretty, process, random, regex-posix, syb, template-haskell, type-level

Files

+ LICENSE view
@@ -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.
+ README.md view
@@ -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+
+ Setup.hs view
@@ -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
+ examples/ALU.hs view
@@ -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]]
+ examples/ALU_Shallow.hs view
@@ -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
+ examples/BitVector.hs view
@@ -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"]
+ examples/ButtonEncoder.hs view
@@ -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+
+ examples/CarrySelectAdder.hs view
@@ -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) -- <C_OUT, SUM3, SUM2, SUM1, SUM0>+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
+ examples/Counter.hs view
@@ -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
+ examples/DeepShallow.hs view
@@ -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
+ examples/LFSR.hs view
@@ -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)
+ examples/Multiplexer.hs view
@@ -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")]+++
+ examples/Multiplexer_FSVector.hs view
@@ -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+
+ examples/Null.hs view
@@ -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
+ examples/ParAddFour.hs view
@@ -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
+ examples/SeqAddFour.hs view
@@ -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
+ examples/ZipTwist.hs view
@@ -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
+ forsyde-deep.cabal view
@@ -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: <https://forsyde.github.io/>.++ 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
+ lib/forsyde.vhd view
@@ -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;
+ src/Data/Traversable/GenericZipWith.hs view
@@ -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)
+ src/Data/Typeable/FSDTypeRepLib.hs view
@@ -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
+ src/Data/Typeable/TypeRepLib.hs view
@@ -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 :: () -> ())
+ src/ForSyDe/Deep.hs view
@@ -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)
+ src/ForSyDe/Deep/AbsentExt.hs view
@@ -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
+ src/ForSyDe/Deep/Backend.hs view
@@ -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+++
+ src/ForSyDe/Deep/Backend/GraphML.hs view
@@ -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
+ src/ForSyDe/Deep/Backend/GraphML/AST.hs view
@@ -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
+ src/ForSyDe/Deep/Backend/GraphML/FileIO.hs view
@@ -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
+ src/ForSyDe/Deep/Backend/GraphML/Ppr.hs view
@@ -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 "<graph" <+> text ("id=\"" ++ id ++ "\"") <+> +                     text "edgedefault=\"directed\" >" $+$+    nest nestVal (vSpace $+$    +                  pprOps_list yFiles (vNSpaces 1) nodes $+$+                  vSpace $+$+                  pprOps_list yFiles (vNSpaces 1) edges $+$+                  vSpace) $+$+  text "</graph>" ++instance PprOps YFilesMarkup GraphMLNode where+ pprOps yFiles node =+   text "<node" <+> 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 "</node>" +  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 "<data key=\"d0\">" $+$+         nest nestVal +          (text "<y:ShapeNode>" $+$+           nest nestVal +            (text "<y:Geometry height=\"" <> float ysize <> text "\" width=\"" <> float xsize <> text "\" x=\"0.0\" y=\"0.0\"/>" $+$+             text "<y:Fill color=\"" <> text color <> text "\" transparent=\"false\"/>" $+$+             text "<y:NodeLabel alignment=\"center\" autoSizePolicy=\"content\" fontFamily=\"Dialog\" fontSize=\"12\" fontStyle=\"plain\" hasBackgroundColor=\"false\" hasLineColor=\"false\"" <+> text labelLocation <+> text "textColor=\"#000000\" visible=\"true\">" <> text label <> text "</y:NodeLabel>" $+$+             text "<y:Shape type=\"" <> text shape <> text "\"/>"+           ) $+$+          text "</y:ShapeNode>" +         ) $+$+       text "</data>"+     else empty++instance PprOps YFilesMarkup  GraphMLEdge where+ pprOps yFiles (GraphMLEdge origN origP targetN targetP) = +    text "<edge" <+> text ("source=\"" ++ origId ++ "\"") <+> +                     text ("sourceport=\"" ++ origP ++ "\"") <+>+                     text ("target=\"" ++ targetId ++ "\"") <+> +                     text ("targetport=\"" ++ targetP ++ "\"") <> +    if not yFiles +      then text "/>"+      else char '>' $+$+           nest nestVal+            (text "<data key=\"d2\">" $+$+               nest nestVal+                (text "<y:PolyLineEdge>" $+$+                 nest nestVal+                  (text "<y:Path sx=\"" <> float edgeOrigX <> text "\" sy=\"" <> float edgeOrigY <> text "\" tx=\"" <> float edgeTargetX <> text "\" ty=\""<> float edgeTargetY <> text "\"/>" $+$+                   text "<y:LineStyle color=\"#000000\" type=\"line\" width=\"1.0\"/>" $+$+                   text "<y:Arrows source=\"none\" target=\"standard\"/>" $+$+                   text "<y:BendStyle smoothed=\"false\"/>"+                  ) $+$+                 text "</y:PolyLineEdge>") $+$+             text "</data>") $+$+           text "</edge>" +  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 "<?xml version=\"1.0\" encoding=\"UTF-8\"?>" $+$+  text "<!-- Automatically generated by ForSyDe -->" $+$+  text "<graphml" <+> xmlns <+>  +  text "xmlns:xsi=\"http://www.w3.org/2001/XMLSchema-instance\"" <+>+  xmlns_y <+>++  xsi_schemaLocation <>+  char '>' $+$ +  nest nestVal (+    text "<key id=\"process_type\" for=\"node\" attr.name=\"process_type\" attr.type=\"string\"/>" $+$+    text "<key id=\"value_arg\" for=\"node\" attr.name=\"value_arg\" attr.type=\"string\"/>" $+$+    text "<key id=\"procfun_arg\" for=\"node\" attr.name=\"procfun_arg\" attr.type=\"string\"/>" $+$+    text "<key id=\"instance_parent\" for=\"node\" attr.name=\"instance_parent\" attr.type=\"string\"/>" $+$+    yFilesAttribs $+$+    pprOps yFiles graph) $+$+  text "</graphml>"+ 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 "<key for=\"node\" id=\"d0\" yfiles.type=\"nodegraphics\"/>"  $+$+   text "<key attr.name=\"description\" attr.type=\"string\" for=\"node\" id=\"d1\"/>" $+$+   text "<key for=\"edge\" id=\"d2\" yfiles.type=\"edgegraphics\"/>" $+$+   text "<key attr.name=\"description\" attr.type=\"string\" for=\"edge\" id=\"d3\"/>" ++-------------------------+-- Tag printing functions+-------------------------+  +port :: GraphMLPortId -> Doc+port id = text "<port" <+> text ("name=\"" ++ id ++ "\"") <> text "/>"   +++process_type :: String -> Doc+process_type str = + text "<data key=\"process_type\">" <> text str <> text "</data>"   +++value_arg :: Exp -> Doc+value_arg exp = + text "<data key=\"value_arg\">" <> text (pprint exp)  <> text "</data>"   ++procfun_arg :: ProcFunAST -> Doc+-- FIXME: support default parameters+procfun_arg (ProcFunAST n cls _) = + text "<data key=\"procfun_arg\">" $+$+  nest nestVal (text $ pprint (FunD n cls)) $+$+ text "</data>"   +++instance_parent :: SysId -> Doc+instance_parent  id = + text "<data key=\"instance_parent\">" <> text id <> text "</data>"   ++-------------------------+-- 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)
+ src/ForSyDe/Deep/Backend/GraphML/Traverse.hs view
@@ -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++++
+ src/ForSyDe/Deep/Backend/GraphML/Traverse/GraphMLM.hs view
@@ -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+
+ src/ForSyDe/Deep/Backend/Ppr.hs view
@@ -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
+ src/ForSyDe/Deep/Backend/Simulate.hs view
@@ -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/: <http://www.cs.chalmers.se/~koen/Lava/>+--+-----------------------------------------------------------------------------+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 _ _ _ = []++++
+ src/ForSyDe/Deep/Backend/VHDL.hs view
@@ -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
+ src/ForSyDe/Deep/Backend/VHDL/AST.hs view
@@ -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+-}
+ src/ForSyDe/Deep/Backend/VHDL/Constants.hs view
@@ -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
+ src/ForSyDe/Deep/Backend/VHDL/FileIO.hs view
@@ -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}
+ src/ForSyDe/Deep/Backend/VHDL/Generate.hs view
@@ -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+
+ src/ForSyDe/Deep/Backend/VHDL/Ghdl.hs view
@@ -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 <tgingold@free.fr>+-- 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+
+ src/ForSyDe/Deep/Backend/VHDL/GlobalNameTable.hs view
@@ -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
+ src/ForSyDe/Deep/Backend/VHDL/GlobalNameTable.hs-boot view
@@ -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 ) )]
+ src/ForSyDe/Deep/Backend/VHDL/Modelsim.hs view
@@ -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
+ src/ForSyDe/Deep/Backend/VHDL/Ppr.hs view
@@ -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)+
+ src/ForSyDe/Deep/Backend/VHDL/Quartus.hs view
@@ -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         +
+ src/ForSyDe/Deep/Backend/VHDL/TestBench.hs view
@@ -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)
+ src/ForSyDe/Deep/Backend/VHDL/Translate.hs view
@@ -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 "."
+ src/ForSyDe/Deep/Backend/VHDL/Translate/HigherOrderFunctions.hs view
@@ -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 ()
+ src/ForSyDe/Deep/Backend/VHDL/Traverse.hs view
@@ -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
+ src/ForSyDe/Deep/Backend/VHDL/Traverse/VHDLM.hs view
@@ -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+
+ src/ForSyDe/Deep/Bit.hs view
@@ -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+ ++ +
+ src/ForSyDe/Deep/Config.hs view
@@ -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)
+ src/ForSyDe/Deep/DFT.hs view
@@ -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++
+ src/ForSyDe/Deep/FIR.hs view
@@ -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 |])+++
+ src/ForSyDe/Deep/ForSyDeErr.hs view
@@ -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 "<unkown>" mLoc1+        finalLoc2 = fromMaybe "<unkown>" 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 "<unkown>" 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 <http://hackage.haskell.org/trac/ghc/ticket/1265>+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 <http://hackage.haskell.org/trac/ghc/ticket/1265>+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
+ src/ForSyDe/Deep/Ids.hs view
@@ -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
+ src/ForSyDe/Deep/Netlist.hs view
@@ -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/: <http://www.cs.chalmers.se/~koen/Lava/>+-- +-----------------------------------------------------------------------------++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"
+ src/ForSyDe/Deep/Netlist/Traverse.hs view
@@ -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/: <http://www.cs.chalmers.se/~koen/Lava/>+-- +-----------------------------------------------------------------------------+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
+ src/ForSyDe/Deep/OSharing.hs view
@@ -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: <http://www.cs.chalmers.se/~koen/pubs/entry-asian99-lava.html>+--+-- 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/:+--   <http://www.cs.chalmers.se/~koen/Lava/>+--+-- 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 #-}
+ src/ForSyDe/Deep/OSharing/UDynamic.hs view
@@ -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/: <http://www.cs.chalmers.se/~koen/Lava/>+-- +-----------------------------------------------------------------------------+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
+ src/ForSyDe/Deep/Process.hs view
@@ -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 ()
+ src/ForSyDe/Deep/Process/Desugar.hs view
@@ -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
+ src/ForSyDe/Deep/Process/Desugar.hs-boot view
@@ -0,0 +1,7 @@+{-# LANGUAGE Rank2Types #-}+module ForSyDe.Deep.Process.Desugar (desugarTransform) where++import Language.Haskell.TH+import Data.Generics++desugarTransform :: [Dec] -> Q [Dec]
+ src/ForSyDe/Deep/Process/ProcFun.hs view
@@ -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"
+ src/ForSyDe/Deep/Process/ProcType.hs view
@@ -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]++
+ src/ForSyDe/Deep/Process/ProcType/Instances.hs view
@@ -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: <http://hackage.haskell.org/trac/ghc/ticket/1800>+--+----------------------------------------------------------------------------- +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])+++
+ src/ForSyDe/Deep/Process/ProcVal.hs view
@@ -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)
+ src/ForSyDe/Deep/Process/SynchProc.hs view
@@ -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)+
+ src/ForSyDe/Deep/Signal.hs view
@@ -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)++++           +++
+ src/ForSyDe/Deep/System.hs view
@@ -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)
+ src/ForSyDe/Deep/System/Instantiate.hs view
@@ -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
+ src/ForSyDe/Deep/System/SysDef.hs view
@@ -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 <http://hackage.haskell.org/trac/ghc/ticket/1800>, 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)) +
+ src/ForSyDe/Deep/System/SysDef.hs-boot view
@@ -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
+ src/ForSyDe/Deep/System/SysFun.hs view
@@ -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)) )
+ src/ForSyDe/Deep/System/SysFun/Instances.hs view
@@ -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: <http://hackage.haskell.org/trac/ghc/ticket/1800>+--+----------------------------------------------------------------------------- +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]+  )
+ src/ForSyDe/Deep/Version.hs view
@@ -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
+ src/Language/Haskell/TH/Lift.hs view
@@ -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: <http://hackage.haskell.org/cgi-bin/hackage-scripts/package/th-lift>+-----------------------------------------------------------------------------+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 |]+
+ src/Language/Haskell/TH/LiftInstances.hs view
@@ -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+
+ src/Language/Haskell/TH/TypeLib.hs view
@@ -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` []
+ tests/Install.hs view
@@ -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
+ tests/examples/Main.hs view
@@ -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"
+ tests/examples/VHDLBackend.hs view
@@ -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