diff --git a/ForSyDe.cabal b/ForSyDe.cabal --- a/ForSyDe.cabal +++ b/ForSyDe.cabal @@ -1,5 +1,5 @@ name: ForSyDe -version: 3.1 +version: 3.1.1 cabal-version: >= 1.2 build-type: Custom license: BSD3 @@ -15,8 +15,10 @@ 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: . -category: Language -tested-with: GHC==6.10.4 + + This will be most probably the last update on this package. It will be splitted to ForSyDe-shallow and ForSyDe-deep in the next release. +category: Language, Hardware +tested-with: GHC==6.12.3 data-files: lib/forsyde.vhd -- In order to include all this files with sdist extra-source-files: LICENSE, @@ -85,9 +87,8 @@ Library build-depends: type-level, - parameterized-data, + parameterized-data >= 0.1.5, containers, - packedstring, base>=4 && <6, regex-posix, mtl, @@ -98,9 +99,9 @@ filepath, old-time, random, - array, - syb + array + hs-source-dirs: src exposed-modules: Language.Haskell.TH.Lift, Language.Haskell.TH.LiftInstances, @@ -139,7 +140,8 @@ ForSyDe.Shallow.UtilityLib, ForSyDe.Shallow.Gaussian, ForSyDe.Shallow.Vector, - ForSyDe.Shallow.Memory + ForSyDe.Shallow.Memory, + ForSyDe.Shallow.DataflowLib other-modules: Paths_ForSyDe, diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -53,7 +53,7 @@ forsyde_vhd_dir = (datadir $ absoluteInstallDirs pd lbi cd) "lib" modelsimError err = putStrLn $ - "Error: " ++ err ++ "\n" ++ + "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" ++ diff --git a/examples/Equalizer_Shallow/ButtonControl.lhs b/examples/Equalizer_Shallow/ButtonControl.lhs --- a/examples/Equalizer_Shallow/ButtonControl.lhs +++ b/examples/Equalizer_Shallow/ButtonControl.lhs @@ -27,9 +27,8 @@ buttonControl overrides bassDn bassUp trebleDn trebleUp = (bass, treble) where (bass, treble) = unzipSY levels - levels = ((holdSY (0.0, 0.0)) `funComb2` levelControl) - button overrides - button = buttonInterface bassDn bassUp trebleDn trebleUp + levels = holdSY (0.0, 0.0) $ levelControl button overrides + button = buttonInterface bassDn bassUp trebleDn trebleUp \end{code} \subsection{The Process \process{Button Interface}} diff --git a/src/ForSyDe/AbsentExt.hs b/src/ForSyDe/AbsentExt.hs --- a/src/ForSyDe/AbsentExt.hs +++ b/src/ForSyDe/AbsentExt.hs @@ -20,7 +20,7 @@ isAbsent, isPresent, abstExtFunc) where -import Data.Generics +import Data.Data import Language.Haskell.TH.Lift diff --git a/src/ForSyDe/Backend/Simulate.hs b/src/ForSyDe/Backend/Simulate.hs --- a/src/ForSyDe/Backend/Simulate.hs +++ b/src/ForSyDe/Backend/Simulate.hs @@ -24,12 +24,11 @@ import ForSyDe.ForSyDeErr import ForSyDe.Process.ProcVal -import Control.Monad (liftM, mapM_, zipWithM_) import Data.Maybe (fromJust) import Control.Monad.ST import Data.STRef import qualified Data.Traversable as DT -import Data.List (lookup, transpose) +import Data.List (transpose) import Data.Dynamic -- | 'simulate' takes a system definition and generates a function diff --git a/src/ForSyDe/Backend/VHDL/Quartus.hs b/src/ForSyDe/Backend/VHDL/Quartus.hs --- a/src/ForSyDe/Backend/VHDL/Quartus.hs +++ b/src/ForSyDe/Backend/VHDL/Quartus.hs @@ -24,7 +24,6 @@ import System.IO import System.Directory import System.Process -import System.FilePath import Control.Monad.State import System.Exit (ExitCode(..)) diff --git a/src/ForSyDe/Backend/VHDL/Translate.hs b/src/ForSyDe/Backend/VHDL/Translate.hs --- a/src/ForSyDe/Backend/VHDL/Translate.hs +++ b/src/ForSyDe/Backend/VHDL/Translate.hs @@ -35,7 +35,7 @@ import Data.Typeable.TypeRepLib (unArrowT) import Language.Haskell.TH.TypeLib (type2TypeRep) -import Data.Generics (tyconUQname) +import Data.Data (tyconUQname) import Data.Int import Data.Char (digitToInt) import Data.List (intersperse) diff --git a/src/ForSyDe/Backend/VHDL/Traverse/VHDLM.hs b/src/ForSyDe/Backend/VHDL/Traverse/VHDLM.hs --- a/src/ForSyDe/Backend/VHDL/Traverse/VHDLM.hs +++ b/src/ForSyDe/Backend/VHDL/Traverse/VHDLM.hs @@ -24,7 +24,7 @@ import ForSyDe.Netlist.Traverse (TravSEIO) import ForSyDe.Process.ProcType (EnumAlgTy(..)) -import Data.Generics (tyconModule) +import Data.Data (tyconModule) import Data.Maybe (fromJust) import qualified Data.Set as S (filter) import Data.Set (Set, union, empty, toList) diff --git a/src/ForSyDe/Bit.hs b/src/ForSyDe/Bit.hs --- a/src/ForSyDe/Bit.hs +++ b/src/ForSyDe/Bit.hs @@ -29,7 +29,7 @@ import Language.Haskell.TH.Lift import Data.Int import Data.Bits -import Data.Generics (Data, Typeable) +import Data.Data (Data, Typeable) import Prelude hiding (not) import Data.Param.FSVec (FSVec, reallyUnsafeVector) diff --git a/src/ForSyDe/ForSyDeErr.hs b/src/ForSyDe/ForSyDeErr.hs --- a/src/ForSyDe/ForSyDeErr.hs +++ b/src/ForSyDe/ForSyDeErr.hs @@ -42,7 +42,6 @@ import Debug.Trace import Control.Monad.Error import Data.Dynamic -import Data.Typeable import Language.Haskell.TH.Syntax hiding (Loc) import Language.Haskell.TH.Ppr import Language.Haskell.TH.PprLib diff --git a/src/ForSyDe/Netlist/Traverse.hs b/src/ForSyDe/Netlist/Traverse.hs --- a/src/ForSyDe/Netlist/Traverse.hs +++ b/src/ForSyDe/Netlist/Traverse.hs @@ -31,7 +31,6 @@ import qualified Data.Traversable as DT (Traversable(traverse,mapM)) import Control.Applicative (pure, (<$>)) import Control.Monad.State -import Data.List (lookup) import Control.Monad.ST (ST) -- Instances to traverse a netlist Node (and implicitly the whole netlist) diff --git a/src/ForSyDe/Process/ProcType.hs b/src/ForSyDe/Process/ProcType.hs --- a/src/ForSyDe/Process/ProcType.hs +++ b/src/ForSyDe/Process/ProcType.hs @@ -20,7 +20,7 @@ import Control.Monad (replicateM) import Data.List (intersperse) -import Data.Generics +import Data.Data import Data.Set (Set, union) import Language.Haskell.TH import Language.Haskell.TH.Syntax (Lift(..)) @@ -118,16 +118,16 @@ (map (\n -> varE 'getEnums `appE` undef n) names) getEnumsD = funD 'getEnums [clause [wildP] (normalB getEnumsExpr) []] readProcTypeExpr = doE $ - noBindS [| skipSpaces >> char '(' |] : - (intersperse (noBindS [| skipSpaces >> char ',' |]) + bindS wildP [| skipSpaces >> char '(' |] : + (intersperse (bindS wildP [| skipSpaces >> char ',' |]) (map (\n -> bindS (varP n) [| readProcType |]) names) ++ - [noBindS [| skipSpaces >> char ')' |], + [bindS wildP [| skipSpaces >> char ')' |], noBindS [| return $(tupE $ map varE names) |] ] ) readProcTypeD = funD 'readProcType [clause [] (normalB readProcTypeExpr) []] - procTypeCxt = map (\vName -> conT ''ProcType `appT` varT vName) names ++ - map (\vName -> conT ''Data `appT` varT vName) names ++ - map (\vName -> conT ''Lift `appT` varT vName) names + procTypeCxt = map (\vName -> return $ ClassP ''ProcType [VarT vName]) names ++ + map (\vName -> return $ ClassP ''Data [VarT vName]) names ++ + map (\vName -> return $ ClassP ''Lift [VarT vName]) names instanceD (cxt procTypeCxt) (conT ''ProcType `appT` tupType) [getEnumsD, readProcTypeD] @@ -162,7 +162,7 @@ [toConstr $(varE a)] |] dataTypeOfD = funD 'dataTypeOf [clause [varP a] (normalB dataTypeOfExpr) []] - dataCxt = map (\vName -> conT ''Data `appT` varT vName) names + dataCxt = map (\vName -> return $ ClassP ''Data [VarT vName]) names instanceD (cxt dataCxt) (conT ''Data `appT` tupType) [gfoldlD, gunfoldD, toConstrD, dataTypeOfD] @@ -178,7 +178,7 @@ |] typeOfD = funD 'typeOf [clause [wildP] (normalB typeOfExpr) []] - typeableCxt = map (\vName -> conT ''Typeable `appT` varT vName) names + typeableCxt = map (\vName -> return $ ClassP ''Typeable [VarT vName]) names instanceD (cxt typeableCxt) (conT ''Typeable `appT` tupType) [typeOfD] @@ -188,7 +188,7 @@ 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 -> conT ''Lift `appT` varT vName) names + liftCxt = map (\vName -> return $ ClassP ''Lift [VarT vName]) names instanceD (cxt liftCxt) (conT ''Lift `appT` tupType) [liftD] diff --git a/src/ForSyDe/Process/ProcType/Instances.hs b/src/ForSyDe/Process/ProcType/Instances.hs --- a/src/ForSyDe/Process/ProcType/Instances.hs +++ b/src/ForSyDe/Process/ProcType/Instances.hs @@ -27,7 +27,7 @@ import Data.Param.FSVec (FSVec, reallyUnsafeVector) -import Data.Generics +import Data.Data import Control.Monad (liftM, liftM2, mzero) import Text.ParserCombinators.ReadP import Data.Set (empty, singleton) @@ -81,11 +81,11 @@ getEnums _ = getEnums (undefined :: a) readProcType = do skipSpaces - char '<' + _ <- char '<' elems <- countSepBy (toInt (undefined :: s)) readProcType (skipSpaces >> char ',' >> skipSpaces) - char '>' + _ <- char '>' return (reallyUnsafeVector elems) where countSepBy n p sep = if n == 0 @@ -96,9 +96,9 @@ instance ProcType a => ProcType (AbstExt a) where getEnums _ = getEnums (undefined :: a) readProcType = skipSpaces >> (absP <++ prstP) - where absP = do string "Abst" + where absP = do _ <- string "Abst" return Abst - prstP = do string "Prst" + prstP = do _ <- string "Prst" skipSpaces v <- readProcType return $ Prst v diff --git a/src/ForSyDe/Shallow/AdaptivityLib.hs b/src/ForSyDe/Shallow/AdaptivityLib.hs --- a/src/ForSyDe/Shallow/AdaptivityLib.hs +++ b/src/ForSyDe/Shallow/AdaptivityLib.hs @@ -11,15 +11,23 @@ -- Adaptivity Library, yet to be completed. -- ----------------------------------------------------------------------------- -module ForSyDe.Shallow.AdaptivityLib (applyfSY, applyfU) where +module ForSyDe.Shallow.AdaptivityLib (applyfSY, applyf2SY, applyf3SY, + applyfU) where import ForSyDe.Shallow.Signal import ForSyDe.Shallow.SynchronousLib import ForSyDe.Shallow.UntimedLib applyfSY :: Signal (a -> b) -> Signal a -> Signal b -applyfSY = zipWithSY apply - where apply f x = f x +applyfSY = zipWithSY ($) + +applyf2SY :: Signal (a -> c -> d) + -> Signal a -> Signal c -> Signal d +applyf2SY = zipWith3SY ($) + +applyf3SY :: Signal (a -> c -> d -> e) + -> Signal a -> Signal c -> Signal d -> Signal e +applyf3SY = zipWith4SY ($) applyfU :: Int -> Signal ([a] -> [b]) -> Signal a -> Signal b applyfU tokenNum = comb2UC tokenNum apply diff --git a/src/ForSyDe/Shallow/DataflowLib.hs b/src/ForSyDe/Shallow/DataflowLib.hs new file mode 100644 --- /dev/null +++ b/src/ForSyDe/Shallow/DataflowLib.hs @@ -0,0 +1,436 @@ +----------------------------------------------------------------------------- +-- | +-- Module : ForSyDe.Shallow.DataflowLib +-- 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 +-- +-- The dataflow library defines data types, process constructors and +-- functions to model dataflow process networks, as described by Lee and +-- Parks in Dataflow process networks, IEEE Proceedings, 1995 ([LeeParks95]). +-- +-- Each process is defined by a set of firing rules and corresponding +-- actions. A process fires, if the incoming signals match a firing +-- rule. Then the process consumes the matched tokens and executes the +-- action corresponding to the firing rule. +-- +----------------------------------------------------------------------------- + +module ForSyDe.Shallow.DataflowLib + ( + -- * Data Types + -- | The data type @FiringToken@ defines the data type for tokens. The + -- constructor @Wild@ constructs a token wildcard, the constructor + -- @Value a@ constructs a token with value @a@. + -- + -- A sequence (pattern) matches a signal, if the sequence is a prefix of + -- the signal. The following list illustrates the firing rules: + -- + -- * [⊥] matches always (/NullS/ in ForSyDe) + -- + -- * [*] matches signal with at least one token (/[Wild]/ in ForSyDe) + -- + -- * [v] matches signal with v as its first value (/[Value v]/ in ForSyDe) + -- + -- * [*,*] matches signals with at least two tokens (/[Wild,Wild]/ in ForSyDe) + -- + FiringToken(Wild, Value), + -- * Combinational Process Constructors + -- | Combinatorial processes + -- do not have an internal state. This means, that the output + -- signal only depends on the input signals. + -- + -- To illustrate the concept of data flow processes, we create a process that selects tokens from two inputs according to a control signal. + -- + -- The process has the following firing rules [LeeParks95]: + -- + -- + -- * R1 = {[*], ⊥, [T]} + -- + -- * R2 = {⊥, [*], [F]} + -- + -- + -- The corresponding ForSyDe formulation of the firing rules is: + -- + -- @ + -- selectRules = [ ([Wild], [], [Value True]), + -- ([], [Wild], [Value False]) ] + -- @ + -- + -- For the output we formulate the following set of output functions: + -- + -- @ + -- selectOutput xs ys _ = [ [headS xs], [headS ys] ] + -- @ + -- + -- The select process /selectDF/ is then defined by: + -- + -- @ + -- selectDF :: Eq a => Signal a -> Signal a + -- -> Signal Bool -> Signal a + -- selectDF = zipWith3DF selectRules selectOutput + -- @ + -- + -- Given the signals /s1/, /s2/ and /s3/ + -- + -- @ + -- s1 = signal [1,2,3,4,5,6] + -- s2 = signal [7,8,9,10,11,12] + -- s3 = signal [True, True, False, False, True, True] + -- @ + -- + -- the executed process gives the following results: + -- + -- @ + -- DataflowLib> selectDF s1 s2 s3 + -- {1,2,7,8,3,4} :: Signal Integer + -- @ + -- + -- The library contains the following combinational process constructors: + mapDF, zipWithDF, zipWith3DF, + -- * Sequential Process Constructors + -- | Sequential processes have + -- an internal state. This means, that the output signal may + -- depend internal state and on the input signal. + -- + -- As an example we can view a process calculating the running sum + -- of the input tokens. It has only one firing rule, which is + -- illustrated below. + -- + -- @ + -- Firing Rule Next State Output + -- ------------------------------------ + -- (*,[*]) state + x {state} + -- @ + -- + -- A dataflow process using these firing rules and the initial state 0 can be formulated in ForSyDe as + -- + -- @ + -- rs xs = mealyDF firingRule nextState output initState xs + -- where + -- firingRule = [(Wild, [Wild])] + -- nextState state xs = [(state + headS xs)] + -- output state _ = [[state]] + -- initState = 0 + -- @ + -- + -- Execution of the process gives + -- + -- @ + -- DataflowLib> rs (signal[1,2,3,4,5,6]) + -- {0,1,3,6,10,15} :: Signal Integer + -- @ + -- + -- Another 'running sum' process /rs2/ takes two tokens, pushes + -- them into a queue of five elements and calculates the sum as + -- output. + -- + -- @ + -- rs2 = mealyDF fs ns o init + -- where + -- init = [0,0,0,0,0] + -- fs = [(Wild, ([Wild, Wild]))] + -- ns state xs = [drop 2 state ++ fromSignal (takeS 2 xs)] + -- o state _ = [[(sum state)]] + -- @ + -- + -- Execution of the process gives + -- + -- @ + -- DataflowLib>rs2 (signal [1,2,3,4,5,6,7,8,9,10]) + -- {0,3,10,20,30} :: Signal Integer + -- @ + scanlDF, mooreDF, mealyDF + ) where + +import ForSyDe.Shallow.CoreLib + + +------------------------------------------------------------------------ +-- +-- DATA TYPES +-- +------------------------------------------------------------------------ + +data FiringToken a = Wild + | Value a deriving (Eq, Show) + + +------------------------------------------------------------------------ +-- +-- COMBINATIONAL PROCESS CONSTRUCTORS +-- +------------------------------------------------------------------------ + +-- |The process constructor @mapDF@ takes a list of firing rules, a list of corresponding output functions and generates a data flow process with one input and one output signal. +mapDF :: Eq a => [[FiringToken a]] + -> (Signal a -> [[b]]) -> Signal a -> Signal b + +mapDF _ _ NullS = NullS +mapDF rs as xs = output +-+ mapDF rs as xs' + where + xs' = if matchedRule < 0 then + NullS + else + consumeDF rule xs + matchedRule = (matchDF rs xs) + rule = rs !! matchedRule + output = if matchedRule < 0 then + NullS + else + signal ((as xs) !! matchedRule) +-- |The process constructors @zipWithDF@ takes a list of firing rules, a list of corresponding output functions to generate a data flow process with two input signals and one output signal. +zipWithDF :: (Eq a, Eq b) => + [([FiringToken b], [FiringToken a])] + -> (Signal b -> Signal a -> [[c]]) -> Signal b + -> Signal a -> Signal c + +zipWithDF _ _ NullS NullS = NullS +zipWithDF rs as xs ys = output +-+ zipWithDF rs as xs' ys' + where + (xs', ys') = if matchedRule < 0 then + (NullS, NullS) + else + consume2DF rule xs ys + matchedRule = (match2DF rs xs ys) + rule = rs !! matchedRule + output = if matchedRule < 0 then + NullS + else + signal ((as xs ys) !! matchedRule) + +-- |The process constructors @zipWith3DF@ takes a list of firing rules, a list of corresponding output functions to generate a data flow process with three input signals and one output signal. +zipWith3DF :: (Eq a, Eq b, Eq c) => + [([FiringToken a],[FiringToken b],[FiringToken c])] + -> (Signal a -> Signal b -> Signal c -> [[d]]) + -> Signal a -> Signal b -> Signal c -> Signal d +zipWith3DF _ _ NullS NullS NullS = NullS +zipWith3DF rs as xs ys zs = output +-+ zipWith3DF rs as xs' ys' zs' + where + (xs', ys', zs') = if matchedRule < 0 then + (NullS, NullS, NullS) + else + consume3DF rule xs ys zs + matchedRule = (match3DF rs xs ys zs) + rule = rs !! matchedRule + output = if matchedRule < 0 then + NullS + else + signal ((as xs ys zs) !! matchedRule) + + +------------------------------------------------------------------------ +-- +-- SEQUENTIAL PROCESS CONSTRUCTORS +-- +------------------------------------------------------------------------ +-- | The process constructor @scanlDF@ implements a finite state machine without output decoder in the ForSyDe methodology. It takes a set of firing rules and a set of corresponding next state functions as arguments. A firing rule is a tuple. The first value is a pattern for the state, the second value corresponds to an input pattern. When a pattern matches, the process fires, the corresponding next state is executed, and the tokens matching the pattern are consumed. +scanlDF :: (Eq a, Eq b) => [(FiringToken b,[FiringToken a])] + -> (b -> Signal a -> [b]) + -> b -> Signal a -> Signal b +scanlDF _ _ _ NullS = NullS +scanlDF fs ns state xs = (unitS state) + +-+ scanlDF fs ns state' xs' + where + xs' = if matchedRule < 0 then + NullS + else + consumeDF rule xs + matchedRule = matchStDF fs state xs + rule = snd (fs !! matchedRule) + state' = if matchedRule < 0 then + error "No rule matches the pattern!" + else + (ns state xs) !! matchedRule + +-- | The process constructor @mooreDF@ implements a Moore finite state machine in the ForSyDe methodology. It takes a set of firing rules, a set of corresponding next state functions and a set of output functions as argument. A firing rule is a tuple. The first value is a pattern for the state, the second value corresponds to an input pattern. When a pattern matches, the process fires, the corresponding next state and output functions are executed, and the tokens matching the pattern are consumed. +mooreDF :: (Eq a, Eq b) => [(FiringToken b,[FiringToken a])] + -> (b -> Signal a -> [b]) -> (b -> [c]) + -> b -> Signal a -> Signal c +mooreDF _ _ _ _ NullS = NullS +mooreDF fs ns o state xs = output +-+ mooreDF fs ns o state' xs' + where + xs' = if matchedRule < 0 then + NullS + else + consumeDF rule xs + matchedRule = matchStDF fs state xs + rule = snd (fs !! matchedRule) + output = signal (o state) + state' = if matchedRule < 0 then + error "No rule matches the pattern!" + else + (ns state xs) !! matchedRule + + +-- | The process constructor @mealyDF@ implements the most general state machine in the ForSyDe methodology. It takes a set of firing rules, a set of corresponding next state functions and a set of output functions as argument. A firing rule is a tuple. The first value is a pattern for the state, the second value corresponds to an input pattern. When a pattern matches, the process fires, the corresponding next state and output functions are executed, and the tokens matching the pattern are consumed. +mealyDF :: (Eq a, Eq b) => [(FiringToken b,[FiringToken a])] + -> (b -> Signal a -> [b]) -> (b -> Signal a -> [[c]]) + -> b -> Signal a -> Signal c +mealyDF _ _ _ _ NullS = NullS +mealyDF fs ns o state xs = output +-+ mealyDF fs ns o state' xs' + where + xs' = if matchedRule < 0 then + NullS + else + consumeDF rule xs + matchedRule = matchStDF fs state xs + rule = snd (fs !! matchedRule) + output = signal ((o state xs) !! matchedRule) + state' = if matchedRule < 0 then + error "No rule matches the pattern!" + else + (ns state xs) !! matchedRule + + +------------------------------------------------------------------------ +-- +-- SUPPORTING FUNCTIONS +-- +------------------------------------------------------------------------ + +-- The function 'prefixDF' takes a pattern and a signal and returns +-- 'True', if the pattern is a prefix from the signal. +prefixDF :: Eq a => [FiringToken a] -> Signal a -> Bool +prefixDF [] _ = True +prefixDF _ NullS = False +prefixDF (Wild:ps) (_:-xs) = prefixDF ps xs +prefixDF ((Value p):ps) (x:-xs) = if p == x then + prefixDF ps xs + else + False + +-- The function 'consumeDF' takes a pattern and a signal and consumes +-- the pattern from the signal. The functions 'consume2DF' and +-- 'consume3DF' work in the same way as 'consumeDF', but with two and +-- three input signals. +consumeDF :: Eq a => [FiringToken a] + -> Signal a -> Signal a +consumeDF _ NullS = NullS +consumeDF [] xs = xs +consumeDF (Wild:ts) (_:-xs) = consumeDF ts xs +consumeDF (Value t:ts) (x:-xs) = if t == x then + consumeDF ts xs + else + error "Tokens not correct" + +consume2DF :: (Eq a, Eq b) => + ([FiringToken a], [FiringToken b]) + -> Signal a -> Signal b -> (Signal a, Signal b) +consume2DF (px, py) xs ys = (consumeDF px xs, + consumeDF py ys) + +consume3DF :: (Eq a, Eq b, Eq c) => + ([FiringToken a], [FiringToken b], [FiringToken c]) + -> Signal a -> Signal b -> Signal c + -> (Signal a,Signal b,Signal c) +consume3DF (px, py, pz) xs ys zs = (consumeDF px xs, + consumeDF py ys, + consumeDF pz zs) + +-- The function 'matchDF' checks, which firing rule, starting from 0, is +-- matched by the input signal. If no firing rule matches, the output is +-- '-1'. The functions 'maptch2S' and 'match3DF' work in the same way +-- for two and three inputs. +matchDF :: (Num a, Eq b) => + [[FiringToken b]] -> Signal b -> a +matchDF rs xs = matchDF' 0 rs xs + where matchDF' _ [] _ = -1 + matchDF' n (r:rs) xs = if prefixDF r xs then + n + else + matchDF' (n+1) rs xs + +match2DF :: (Num a, Eq b, Eq c) => + [([FiringToken b], [FiringToken c])] + -> Signal b -> Signal c -> a +match2DF rs xs ys = match2DF' 0 rs xs ys + where match2DF' _ [] _ _ = -1 + match2DF' n ((rx, ry):rs) xs ys + = if prefixDF rx xs && + prefixDF ry ys + then + n + else + match2DF' (n+1) rs xs ys + +match3DF :: (Num a, Eq b, Eq c, Eq d) => + [([FiringToken b], [FiringToken d], [FiringToken c])] + -> Signal b -> Signal d -> Signal c -> a +match3DF rs xs ys zs = match3DF' 0 rs xs ys zs + where match3DF' _ [] _ _ _ = -1 + match3DF' n ((rx, ry, rz):rs) xs ys zs + = if prefixDF rx xs && + prefixDF ry ys && + prefixDF rz zs + then + n + else + match3DF' (n+1) rs xs ys zs + +-- The function 'matchStDF' works in the same way as 'matchDF', but it looks on patterns that include the state. +matchStDF :: (Num a, Eq b, Eq c) => + [(FiringToken c,[FiringToken b])] + -> c -> Signal b -> a +matchStDF rs state xs = matchStDF' 0 rs state xs + where matchStDF' _ [] _ _ = -1 + matchStDF' n (r:rs) state xs + = if prefixDF (snd r) xs && + matchState (fst r) state + then + n + else + matchStDF' (n+1) rs state xs + +matchState :: Eq a => FiringToken a -> a -> Bool +matchState Wild _ = True +matchState (Value v) x = x == v + + + +------------------------------------------------------------------------ +-- +-- CODE FOR TESTING +-- +------------------------------------------------------------------------ + + +selectRules = [ ([Wild], [], [Value True]), + ([], [Wild], [Value False]) ] + + +selectOutput xs ys _ = [ [headS xs], [headS ys] ] + +selectDF :: Eq a => Signal a -> Signal a + -> Signal Bool -> Signal a +selectDF = zipWith3DF selectRules selectOutput + + + +s1 = signal [1,2,3,4,5,6] +s2 = signal [7,8,9,10,11,12] +s3 = signal [True, True, False, False, True, True] + +rs xs = mealyDF firingRule nextState output initState xs + where firingRule = [(Wild, [Wild])] + nextState state xs = [(state + headS xs)] + output state _ = [[state]] + initState = 0 + +rs2 = mealyDF fs ns o init + where init = [0,0,0,0,0] + fs = [(Wild, ([Wild, Wild]))] + ns state xs = [drop 2 state ++ fromSignal (takeS 2 xs)] + o state _ = [[(sum state)]] + + + + + + + + + diff --git a/src/ForSyDe/Shallow/MoCLib.hs b/src/ForSyDe/Shallow/MoCLib.hs --- a/src/ForSyDe/Shallow/MoCLib.hs +++ b/src/ForSyDe/Shallow/MoCLib.hs @@ -27,6 +27,7 @@ module ForSyDe.Shallow.StochasticLib, module ForSyDe.Shallow.CTLib, module ForSyDe.Shallow.UntimedLib, + module ForSyDe.Shallow.DataflowLib, module ForSyDe.Shallow.DomainInterfaces ) where @@ -36,3 +37,4 @@ import ForSyDe.Shallow.UntimedLib import ForSyDe.Shallow.DomainInterfaces import ForSyDe.Shallow.SynchronousProcessLib +import ForSyDe.Shallow.DataflowLib diff --git a/src/ForSyDe/System/SysDef.hs b/src/ForSyDe/System/SysDef.hs --- a/src/ForSyDe/System/SysDef.hs +++ b/src/ForSyDe/System/SysDef.hs @@ -31,7 +31,6 @@ import ForSyDe.System.SysFun (checkSysFType, SysFun(..)) import Data.Maybe (isJust, fromJust) -import Control.Monad.Error import Control.Monad.ST import Control.Monad.State import Data.Typeable diff --git a/src/ForSyDe/System/SysFun.hs b/src/ForSyDe/System/SysFun.hs --- a/src/ForSyDe/System/SysFun.hs +++ b/src/ForSyDe/System/SysFun.hs @@ -30,7 +30,6 @@ import Language.Haskell.TH.TypeLib import Data.Dynamic -import Control.Monad (when, liftM3) import Text.Regex.Posix ((=~)) import qualified Language.Haskell.TH as TH (Exp) import Language.Haskell.TH @@ -222,7 +221,7 @@ where accumApp accumT vName = accumT `appT` (conT ''Signal `appT` varT vName) -- Create the ProcType context - procTypeCxt = map (\vName -> conT ''ProcType `appT` varT vName) outNames + procTypeCxt = map (\vName -> return $ ClassP ''ProcType [VarT vName]) outNames -- Finally return the instance declaration sysFunIns = instanceD (cxt procTypeCxt) diff --git a/src/Language/Haskell/TH/Lift.hs b/src/Language/Haskell/TH/Lift.hs --- a/src/Language/Haskell/TH/Lift.hs +++ b/src/Language/Haskell/TH/Lift.hs @@ -19,9 +19,9 @@ module Language.Haskell.TH.Lift (deriveLift1, deriveLift) where import GHC.Exts -import Data.PackedString import Language.Haskell.TH import Language.Haskell.TH.Syntax +import Language.Haskell.TH.Syntax.Internals import Control.Monad (liftM) modName :: String @@ -59,10 +59,13 @@ case i of TyConI (DataD dcxt _ vs cons _) -> let ctxt = liftM (++ dcxt) $ - cxt [conT ''Lift `appT` varT v | v <- vs] - typ = foldl appT (conT n) $ map varT vs + cxt [return $ ClassP ''Lift [VarT v'] | v' <- vs'] + typ = foldl appT (conT n) $ map varT vs' fun = funD 'lift (map doCons cons) + vs' = map (\(PlainTV v) -> v) 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 @@ -81,8 +84,17 @@ instance Lift Name where lift (Name occName nameFlavour) = [| Name occName nameFlavour |] -instance Lift PackedString where - lift ps = [| packString $(lift $ unpackPS ps) |] +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 |] diff --git a/src/Language/Haskell/TH/LiftInstances.hs b/src/Language/Haskell/TH/LiftInstances.hs --- a/src/Language/Haskell/TH/LiftInstances.hs +++ b/src/Language/Haskell/TH/LiftInstances.hs @@ -43,9 +43,14 @@ Dec, Exp(LitE), Q, - Lift(..)) + Lift(..), + Pred, + TyVarBndr, + Kind, + FamFlavour, + Pragma, + InlineSpec) -import Control.Monad (mapM) import Data.Ratio (Ratio) import Data.Int (Int8, Int16, Int32, Int64) @@ -67,8 +72,14 @@ ''Clause, ''Type, ''Dec, - ''Exp]) - + ''Exp, + ''Pred, + ''TyVarBndr, + ''Kind, + ''FamFlavour, + ''Pragma, + ''InlineSpec]) + instance Lift Int64 where lift x = return (LitE (IntegerL (fromIntegral x))) diff --git a/src/Language/Haskell/TH/TypeLib.hs b/src/Language/Haskell/TH/TypeLib.hs --- a/src/Language/Haskell/TH/TypeLib.hs +++ b/src/Language/Haskell/TH/TypeLib.hs @@ -33,15 +33,14 @@ where import Data.Dynamic -import Data.Typeable -import Language.Haskell.TH (Type(..), Cxt, Name, pprint, mkName) +import Language.Haskell.TH (Type(..), Cxt, TyVarBndr(..), pprint, mkName) import Text.Regex.Posix ((=~)) import Data.Maybe(isJust) -- Due to type translations import GHC.Exts (RealWorld) import Data.Word (Word, Word8, Word16, Word32, Word64) -import Data.Int (Int, Int8, Int16, Int32, Int64) +import Data.Int (Int8, Int16, Int32, Int64) import System.IO (Handle) import Data.IORef (IORef) import Foreign (Ptr, FunPtr, StablePtr, ForeignPtr) @@ -68,15 +67,15 @@ -- where @a@ and @b@ are the the context variables and -- @(Show a, Show b)@ are the context constraints data Context = Context - [Name] -- Variable names - Cxt -- Constraints (the context itself) + [TyVarBndr] -- Variable names + Cxt -- Constraints (the context itself) instance Show Context where -- FIXME: this is really ugly, refactor and improve its look - showsPrec _ (Context n cxt) = - showVars n . showConstraints cxt - where showVars n = showForall (not (null n)) (showVars' n) - showVars' (n:ns) = shows n . showChar ' ' . showVars' ns + 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) . @@ -89,8 +88,8 @@ else s -- | 'Context' constructor -mkContext :: [Name] -> Cxt -> Context -mkContext n c = Context n c +mkContext :: [TyVarBndr] -> Cxt -> Context +mkContext tvb c = Context tvb c -- | Empty context for monomorphic types monoContext :: Context @@ -102,8 +101,8 @@ isPoly _ = True -- | Returns the variable names related to a context -contextVarNames :: Context -> [Name] -contextVarNames (Context n _) = n +contextVarNames :: Context -> [TyVarBndr] +contextVarNames (Context tvb _) = tvb -- | Returns the context constraints contextConstraints :: Context -> Cxt @@ -111,7 +110,7 @@ -- | Builds a 'ForallT' type out of a context and a type mkForallT :: Context -> Type -> Type -mkForallT (Context n cxt) t = ForallT n cxt t +mkForallT (Context tvb cxt) t = ForallT tvb cxt t -------------------------------- -- Functions to observe a 'Type'