signals 0.0.0.1 → 0.2.0.1
raw patch · 30 files changed
+1602/−2549 lines, 30 filesdep +hashabledep +imperative-edsl-vhdldep +language-vhdldep −data-reifydep −language-c-quotedep −mainland-prettydep ~basedep ~exception-mtldep ~exception-transformers
Dependencies added: hashable, imperative-edsl-vhdl, language-vhdl, monad-control, observable-sharing, operational-alacarte, pretty
Dependencies removed: data-reify, language-c-quote, mainland-pretty, operational
Dependency ranges changed: base, exception-mtl, exception-transformers, mtl
Files
- Backend/C.hs +0/−275
- Backend/C/Monad.hs +0/−178
- Backend/Compiler/Compiler.hs +0/−453
- Backend/Compiler/Cycles.hs +0/−85
- Backend/Compiler/Linker.hs +0/−133
- Backend/Compiler/Sorter.hs +0/−74
- Backend/Ex.hs +0/−62
- Backend/Knot.hs +0/−31
- Backend/Struct.hs +0/−25
- Core.hs +0/−189
- Examples/Simple/Expr.hs +0/−263
- Examples/Simple/Filters.hs +0/−163
- Frontend/Signal.hs +0/−319
- Frontend/SignalObsv.hs +0/−149
- Frontend/Stream.hs +0/−87
- Interpretation.hs +0/−51
- signals.cabal +59/−12
- src/Signal.hs +9/−0
- src/Signal/Compiler.hs +321/−0
- src/Signal/Compiler/Channels.hs +159/−0
- src/Signal/Compiler/Cycles.hs +143/−0
- src/Signal/Compiler/Interface.hs +14/−0
- src/Signal/Compiler/Knot.hs +31/−0
- src/Signal/Compiler/Linker.hs +138/−0
- src/Signal/Compiler/Linker/Names.hs +53/−0
- src/Signal/Compiler/Sorter.hs +138/−0
- src/Signal/Core.hs +294/−0
- src/Signal/Core/Reify.hs +154/−0
- src/Signal/Core/Stream.hs +42/−0
- src/Signal/Core/Witness.hs +47/−0
− Backend/C.hs
@@ -1,275 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE UndecidableInstances #-}--module Backend.C where--import Control.Applicative-import Control.Monad.State-import Control.Monad.Exception-import Control.Monad.Operational-import Data.Typeable-import Data.IORef-import Data.Array.IO.Safe-import qualified System.IO as IO-import qualified Text.Printf as Printf--import Language.C.Quote.C-import qualified Language.C.Syntax as C-import qualified Data.Set as Set--import Text.PrettyPrint.Mainland--import Core-import Interpretation--import Backend.C.Monad-import Examples.Simple.Expr------------------------------------------------------------------------------------- * Compilation of Commands-----------------------------------------------------------------------------------compile :: CompCMD cmd => Program cmd a -> C a-compile = interpretWithMonad compCMD------------------------------------------------------------------------------------instance CompCMD (CMD Expr)- where- compCMD = compCMD'--compCMD' :: CMD Expr a -> C a---- ^ File handling-compCMD' (Open path) = do- addInclude "<stdio.h>"- addInclude "<stdlib.h>"- sym <- gensym "v"- addLocal [cdecl| typename FILE * $id:sym; |]- addStm [cstm| $id:sym = fopen($id:path', "r+"); |]- return $ HandleComp sym- where path' = show path-compCMD' (Close (HandleComp h)) = do- addStm [cstm| fclose($id:h); |]-compCMD' (Put (HandleComp h) exp) = do- v <- compExp exp- addStm [cstm| fprintf($id:h, "%f ", $v); |]-compCMD' (Get (HandleComp h)) = do- sym <- gensym "v"- addLocal [cdecl| float $id:sym; |]- addStm [cstm| fscanf($id:h, "%f", &$id:sym); |]- return $ varExp sym-compCMD' (Eof (HandleComp h)) = do- addInclude "<stdbool.h>"- sym <- gensym "v"- addLocal [cdecl| int $id:sym; |]- addStm [cstm| $id:sym = feof($id:h); |]- return $ varExp sym---- ^ Mutable refrences-compCMD' cmd@(InitRef) = do- let t = compTypeRep (typeOfP3 cmd)- sym <- gensym "r"- addLocal [cdecl| $ty:t $id:sym; |]- return $ RefComp sym-compCMD' cmd@(NewRef exp) = do- let t = compTypeRep (typeOfP3 cmd)- sym <- gensym "r"- v <- compExp exp- addLocal [cdecl| $ty:t $id:sym; |]- addStm [cstm| $id:sym = $v; |]- return $ RefComp sym-compCMD' cmd@(GetRef (RefComp ref)) = do- let t = compTypeRep (typeOfP2 cmd)- sym <- gensym "r"- addLocal [cdecl| $ty:t $id:sym; |]- addStm [cstm| $id:sym = $id:ref; |]- return $ varExp sym-compCMD' (SetRef (RefComp ref) exp) = do- v <- compExp exp- addStm [cstm| $id:ref = $v; |]---- ^ Mutable arrays-compCMD' (NewArr size init) = do- addInclude "<string.h>"- sym <- gensym "a"- v <- compExp size- i <- compExp init -- todo: use this with memset- addLocal [cdecl| float $id:sym[ $v ]; |] -- todo: get real type- addStm [cstm| memset($id:sym, $i, sizeof( $id:sym )); |]- return $ ArrComp sym-compCMD' (GetArr expi (ArrComp arr)) = do- sym <- gensym "a"- i <- compExp expi- addLocal [cdecl| float $id:sym; |] -- todo: get real type- addStm [cstm| $id:sym = $id:arr[ $i ]; |]- return $ varExp sym-compCMD' (SetArr expi expv (ArrComp arr)) = do- v <- compExp expv- i <- compExp expi- addStm [cstm| $id:arr[ $i ] = $v; |]---- ^ Unsafe-compCMD' (UnsafeGetRef (RefComp ref)) =- return $ varExp ref-compCMD' (UnsafeGetArr expi (ArrComp arr)) =- undefined---- ^ Control structures-compCMD' (If b t f) = do- b' <- compExp b :: C C.Exp- ct <- inNewBlock_ $ compile t- cf <- inNewBlock_ $ compile f- case null cf of- True -> addStm [cstm| if ($(b')) {$items:ct} |]- False -> addStm [cstm| if ($(b')) {$items:ct} else {$items:cf} |]- return ()-compCMD' (While b t) = do- b' <- compile b :: C (Expr Bool)- b'' <- compExp b' :: C C.Exp- ct <- inNewBlock_ $ compile t- addStm [cstm| while ($(b'')) {$items:ct} |]- return ()- -- todo: the b program should be re-executed at the end of each iteration-compCMD' Break = addStm [cstm| break; |]-compCMD' GetTime = do- addInclude "<sys/time.h>"- addInclude "<sys/resource.h>"- addGlobal getTimeDef- sym <- gensym "t"- addLocal [cdecl| double $id:sym; |]- addStm [cstm| $id:sym = get_time(); |]- return $ varExp sym-compCMD' (Printf format a) = do- addInclude "<stdio.h>"- let format' = show format- a' <- compExp a- addStm [cstm| printf($id:format', $exp:a'); |]------------------------------------------------------------------------------------- ** Helpers--compTypeRep :: TypeRep -> C.Type-compTypeRep trep = case show trep of- "Bool" -> [cty| int |]- "Int" -> [cty| int |] -- todo: should only use fix-width Haskell ints- "Float" -> [cty| float |]- x -> error x--typeOfP1 :: forall proxy a. Typeable a => proxy a -> TypeRep-typeOfP1 _ = typeOf (undefined :: a)--typeOfP2 :: forall proxy1 proxy2 a. Typeable a => proxy1 (proxy2 a) -> TypeRep-typeOfP2 p = typeOf (undefined :: a)--typeOfP3 :: forall proxy1 proxy2 proxy3 a. Typeable a => proxy1 (proxy2 (proxy3 a)) -> TypeRep-typeOfP3 p = typeOf (undefined :: a)--getTimeDef :: C.Definition-getTimeDef = [cedecl|-// From http://stackoverflow.com/questions/2349776/how-can-i-benchmark-c-code-easily-double get_time()-{- struct timeval t;- struct timezone tzp;- gettimeofday(&t, &tzp);- return t.tv_sec + t.tv_usec*1e-6;-}-|]------------------------------------------------------------------------------------- * Compilation of constructs-----------------------------------------------------------------------------------instance CompCMD cmd => CompCMD (Construct cmd)- where- compCMD = compConstruct- -compConstruct :: CompCMD cmd => Construct cmd a -> C a-compConstruct (Function fun body) = inFunction fun $ compile body------------------------------------------------------------------------------------- ** Run Functions--cgen :: CompCMD cmd => Program cmd a -> IO Doc-cgen = cgen' Flags--cgen' :: CompCMD cmd => Flags -> Program cmd a -> IO Doc-cgen' flags ma = do- (_,cenv) <- runC (compile ma) (defaultCEnv flags)- return $ ppr $ cenvToCUnit cenv--genMain :: CompCMD cmd => Program cmd a -> IO Doc-genMain prog = do- (_,cenv) <- runC main (defaultCEnv Flags)- return $ ppr $ cenvToCUnit cenv- where- main = do- (params,items) <- inNewFunction $ compile prog >> addStm [cstm| return 0; |]- addGlobal [cedecl| int main($params:params){ $items:items }|]------------------------------------------------------------------------------------- * Evaluation of programs-----------------------------------------------------------------------------------runProgram :: ( EvalExp exp- , LitPred exp Bool- , LitPred exp Float)- => Program (CMD exp) a- -> IO a-runProgram = interpretWithMonad runCMD------------------------------------------------------------------------------------readWord :: IO.Handle -> IO String-readWord h = do- eof <- IO.hIsEOF h- if eof- then return ""- else do- c <- IO.hGetChar h- cs <- readWord h- return (c:cs)------------------------------------------------------------------------------------runCMD :: (EvalExp exp, LitPred exp Bool, LitPred exp Float) => CMD exp a -> IO a-runCMD (Open path) = fmap HandleEval $ IO.openFile path IO.ReadWriteMode-runCMD (Close (HandleEval h)) = IO.hClose h-runCMD (Put (HandleEval h) a) = IO.hPrint h (evalExp a)-runCMD (Get (HandleEval h)) = do- w <- readWord h- case reads w of- [(f,"")] -> return $ litExp f- _ -> error "runCMD: Get: no parse"-runCMD (Eof (HandleEval h)) = fmap litExp $ IO.hIsEOF h--runCMD (InitRef) = fmap RefEval $ newIORef undefined-runCMD (NewRef a) = fmap RefEval $ newIORef a-runCMD (GetRef (RefEval r)) = readIORef r-runCMD (SetRef (RefEval r) a) = writeIORef r a--runCMD (NewArr i a) = fmap ArrEval $ newArray (0, fromIntegral (evalExp i) - 1) a-runCMD (GetArr i (ArrEval arr)) = readArray arr (fromIntegral (evalExp i))-runCMD (SetArr i a (ArrEval arr)) = writeArray arr (fromIntegral (evalExp i)) a--runCMD (UnsafeGetRef (RefEval r)) = readIORef r--runCMD (If c t f)- | evalExp c = runProgram t- | otherwise = runProgram f-runCMD (While cond body) = do- cond' <- runProgram cond- if evalExp cond'- then runProgram body >> runCMD (While cond body)- else return ()-runCMD Break = error "runCMD: Break not implemented"--runCMD (Printf format a) = Printf.printf format (show $ evalExp a)
− Backend/C/Monad.hs
@@ -1,178 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--module Backend.C.Monad where--import Control.Applicative-import Control.Monad.State-import Control.Monad.Exception-import Control.Monad.Exception.Instances-import Data.List--import Language.C.Quote.C-import qualified Language.C.Syntax as C-import qualified Data.Set as Set--import Text.PrettyPrint.Mainland--data Flags = Flags--data CEnv = CEnv- { _flags :: Flags-- , _unique :: !Integer-- , _includes :: Set.Set String- , _typedefs :: [C.Definition]- , _prototypes :: [C.Definition]- , _globals :: [C.Definition]-- , _params :: [C.Param]- , _locals :: [C.InitGroup]- , _stms :: [C.Stm]- , _finalStms :: [C.Stm]-- }--defaultCEnv :: Flags -> CEnv-defaultCEnv flags = CEnv- { _flags = flags- , _unique = 0- , _includes = Set.empty- , _typedefs = []- , _prototypes = []- , _globals = []- , _params = []- , _locals = []- , _stms = []- , _finalStms = []- }--newtype C a = C { unC :: StateT CEnv (ExceptionT IO) a }- deriving (Functor, Applicative, Monad, MonadException, MonadIO, MonadState CEnv)--runC :: C a -> CEnv -> IO (a, CEnv)-runC m s = runExceptionT (runStateT (unC m) s) >>= liftException--fastDefEq :: C.Definition -> C.Definition -> Bool-fastDefEq (C.FuncDef (C.OldFunc _ i _ _ _ _ _) _) (C.FuncDef (C.OldFunc _ j _ _ _ _ _) _) = i==j-fastDefEq _ _ = False---- | Extract a compilation unit from the 'CEnv' state-cenvToCUnit :: CEnv -> [C.Definition]-cenvToCUnit env =- [cunit|$edecls:includes- $edecls:typedefs- $edecls:prototypes- $edecls:globals|]- where- includes = map toInclude (Set.toList (_includes env))- where- toInclude :: String -> C.Definition- toInclude inc = [cedecl|$esc:("#include " ++ inc)|]- typedefs = reverse $ _typedefs env- prototypes = reverse $ nubBy fastDefEq $ _prototypes env- globals = reverse $ nubBy fastDefEq $ _globals env--gensym :: String -> C String-gensym s = do- u <- gets _unique- modify $ \s -> s { _unique = u + 1 }- return $ s ++ show u--addInclude :: String -> C ()-addInclude inc = modify $ \s ->- s { _includes = Set.insert inc (_includes s) }--addTypedef :: C.Definition -> C ()-addTypedef def = modify $ \s ->- s { _typedefs = def : _typedefs s }--addPrototype :: C.Definition -> C ()-addPrototype def = modify $ \s ->- s { _prototypes = def : _prototypes s }--addGlobal :: C.Definition -> C ()-addGlobal def = modify $ \s ->- s { _globals = def : _globals s }--addParam :: C.Param -> C ()-addParam param = modify $ \s ->- s { _params = param : _params s }--addLocal :: C.InitGroup -> C ()-addLocal def = modify $ \s ->- s { _locals = def : _locals s }--addStm :: C.Stm -> C ()-addStm stm = modify $ \s ->- s { _stms = stm : _stms s }--addFinalStm :: C.Stm -> C ()-addFinalStm stm = modify $ \s ->- s { _finalStms = stm : _finalStms s }--inBlock :: C a -> C a-inBlock act = do- (a, items) <- inNewBlock act- addStm [cstm|{ $items:items }|]- return a--inNewBlock :: C a -> C (a, [C.BlockItem])-inNewBlock act = do- oldLocals <- gets _locals- oldStms <- gets _stms- oldFinalStms <- gets _finalStms- modify $ \s -> s { _locals = [], _stms = [], _finalStms = [] }- x <- act- locals <- reverse <$> gets _locals- stms <- reverse <$> gets _stms- finalstms <- reverse <$> gets _finalStms- modify $ \s -> s { _locals = oldLocals- , _stms = oldStms- , _finalStms = oldFinalStms- }- return (x, map C.BlockDecl locals ++- map C.BlockStm stms ++- map C.BlockStm finalstms- )--inNewBlock_ :: C () -> C [C.BlockItem]-inNewBlock_ act = snd <$> inNewBlock act--inNewFunction :: C () -> C ([C.Param],[C.BlockItem])-inNewFunction comp = do- oldParams <- gets _params- modify $ \s -> s { _params = [] }- items <- inNewBlock_ comp- params <- gets _params- modify $ \s -> s { _params = oldParams }- return (reverse params, items)--inFunction :: String -> C () -> C ()-inFunction fun act = do- (params,items) <- inNewFunction act- addPrototype [cedecl| void $id:fun($params:params);|]- addGlobal [cedecl| void $id:fun($params:params){ $items:items }|]--collectDefinitions :: C a -> C (a, [C.Definition])-collectDefinitions act = do- oldIncludes <- gets _includes- oldTypedefs <- gets _typedefs- oldPrototypes <- gets _prototypes- oldGlobals <- gets _globals- modify $ \s -> s { _includes = Set.empty- , _typedefs = []- , _prototypes = []- , _globals = []- }- a <- act- s' <- get- modify $ \s -> s { _includes = oldIncludes `Set.union` _includes s'- , _typedefs = oldTypedefs ++ _typedefs s'- , _prototypes = oldPrototypes ++ _prototypes s'- , _globals = oldGlobals ++ _globals s'- }- return (a, cenvToCUnit s')
− Backend/Compiler/Compiler.hs
@@ -1,453 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeOperators #-}--module Backend.Compiler.Compiler (- compiler- , inspect_compiler- )-where--import Core (CMD, EEq(..))-import qualified Core as C--import Frontend.Stream (Stream, Str)-import qualified Frontend.Stream as Str--import Frontend.Signal (Signal, Sig, Struct(..), TStruct(..), Empty)-import qualified Frontend.Signal as S--import Frontend.SignalObsv (TSignal(..), Node, edges)--import Backend.Ex-import Backend.Compiler.Cycles-import Backend.Compiler.Linker-import Backend.Compiler.Sorter--import Control.Monad.Reader-import Control.Monad.State hiding (State)-import Control.Monad.Operational--import Data.Typeable-import Data.Reify (Unique, Graph(..), reifyGraph)-import Data.Maybe (fromJust)-import Data.List (sortBy, mapAccumR)-import Data.Traversable (traverse)-import Data.Function (on)--import Data.Map (Map, (!))-import qualified Data.Map as M--import Prelude hiding (reads)------------------------------------------------------------------------------------- *------------------------------------------------------------------------------------- | Shorthand for programs using 'CMD' as their instruction set-type Prog exp = Program (CMD exp)------------------------------------------------------------------------------------compiler :: ( Typeable exp, Typeable a, Typeable b- , EEq exp Int, Num (exp Int), Integral (exp Int)- )- => (Sig exp a -> Sig exp b)- -> IO (Str exp a -> Str exp b)-compiler f =- do (Graph nodes root) <- reifyGraph f-- let links = linker nodes- order = sorter root nodes- cycle = cycles root nodes-- return $ case cycle of- True -> error "found cycle in graph"- False -> compiler' nodes links order False------------------------------------------------------------------------------------- * Channels------------------------------------------------------------------------------------- | Binary trees over references-data RStruct exp a- where- RLeaf :: Typeable a => C.Ref (exp a) -> RStruct exp (Empty (exp a))- RPair :: RStruct exp a -> RStruct exp b -> RStruct exp (a, b)---- | Untyped binary trees over references-type REx exp = Ex (RStruct exp)---- | ...-data Channel symbol exp = C {- _ch_in :: Map symbol (REx exp)- , _ch_out :: Map symbol (REx exp)- }------------------------------------------------------------------------------------- hacky solution for now---- |-initChannels :: (Ord s, Read s, Typeable e) => Resolution s e -> Prog e (Channel s e)-initChannels res = do- outs <- M.traverseWithKey (const makeChannel) $ _output res- return $ C {- _ch_in = M.map (copyChannel outs) $ _input res- , _ch_out = outs- }---- |-makeChannel :: TEx e -> Prog e (REx e)-makeChannel (Ex s) = makes s >>= return . Ex- where- makes :: TStruct e a -> Prog e (RStruct e a)- makes (TLeaf _) = C.initRef >>= return . RLeaf- makes (TPair r l) = do- r' <- makes r- l' <- makes l- return $ RPair r' l'---- |-copyChannel :: forall e s. (Ord s, Read s, Typeable e) => Map s (REx e) -> TEx e -> REx e-copyChannel m (Ex s) = Ex $ copys s- where- copys :: TStruct e a -> RStruct e a- copys (TLeaf i) = case m ! read i of (Ex (RLeaf r)) -> case gcast r of Just x -> RLeaf x- copys (TPair l r) = RPair (copys l) (copys r)------------------------------------------------------------------------------------- * Compiler------------------------------------------------------------------------------------- | ...-data Enviroment symbol exp = Env- { _links :: Resolution symbol exp- , _channels :: Channel symbol exp - , _firsts :: Map symbol (Ex (C.Ref :*: exp)) -- merge with _channels- , _buffers :: Map symbol (Ex (Buffer exp))- , _inputs :: Ex (Prog exp :*: exp)---, ...- }---- | -type Type exp = ReaderT (Enviroment Unique exp) (Prog exp)------------------------------------------------------------------------------------reads :: RStruct exp a -> Prog exp (Struct exp a)-reads (RLeaf r) = C.unsafeGetRef r >>= return . Leaf-reads (RPair l r) = do- l' <- reads l- r' <- reads r- return $ Pair l' r'--writes :: Struct exp a -> RStruct exp a -> Prog exp ()-writes (Leaf s) (RLeaf r) = C.setRef r s-writes (Pair l r) (RPair u v) = writes l u >> writes r v-------------------------------------------------------------------------------------- | Read-read_in :: Typeable a => Unique -> TStruct exp a -> Type exp (Struct exp a)-read_in u _ =- do (Ex ch) <- asks ((! u) . _ch_in . _channels)- case gcast ch of- Just s -> lift $ reads s- Nothing -> error "hepa: type error"---- | Read -read_out :: Typeable a => Unique -> TStruct exp a -> Type exp (Struct exp a)-read_out u _ =- do (Ex ch) <- asks ((! u) . _ch_out . _channels)- case gcast ch of- Just s -> lift $ reads s- Nothing -> error "bepa: type error"---- | Write-write_out :: Typeable a => Unique -> Struct exp a -> Type exp ()-write_out u s =- do (Ex ch) <- asks ((! u) . _ch_out . _channels)- case gcast ch of- Just r -> lift $ writes s r- Nothing -> error "depa: type error"------------------------------------------------------------------------------------read_buffer :: (Typeable a, Num (exp Int)) => Unique -> Type exp (exp a)-read_buffer u =- do (Ex buff) <- asks ((! u) . _buffers)- case gcast buff of- Just b -> lift $ getBuff b- Nothing -> error "apa: type error"--write_buffer :: forall exp. Typeable exp => Unique -> Type exp ()-write_buffer u =- do (Ex (buff :: Buffer exp a)) <- asks ((! u) . _buffers)- (Leaf e) <- read_out u (undefined :: TStruct exp (Empty (exp a)))- lift $ putBuff buff e-------------------------------------------------------------------------------------- | ...-compile :: (Typeable exp, Num (exp Int)) => (Unique, Node exp) -> Type exp ()-compile (i, TVar t@(TLeaf _)) =- do input <- asks (apa t . _inputs)- value <- lift $ liftProgram input- write_out i (Leaf value)- where- apa :: Typeable e => TStruct exp (Empty (exp e)) -> Ex (f :*: g) -> f (g e)- apa _ = unwrap--compile (i, TConst c) =- do value <- lift $ liftProgram $ Str.run c- write_out i (Leaf value)--compile (i, TLift (f :: Stream exp (exp a) -> Stream exp (exp b)) _) =- do let t = undefined :: TStruct exp (Empty (exp a))- (Leaf input) <- read_in i t- value <- lift $ liftProgram $ Str.run $ f $ Str.repeat input- write_out i (Leaf value)---- I could remove the extra variable (value), todo...-compile (i, TDelay (e :: exp a) _) =- do first <- asks (unwrap . (! i) . _firsts) :: Type exp (C.Ref (exp a))- output <- lift $ C.unsafeGetRef first- write_out i (Leaf output)-{-- do let t = undefined :: TStruct exp (Empty (exp a))- (Leaf input) <- read_in i t- first <- asks (unwrap . (! i) . _firsts) :: Type exp (C.Ref (exp a))- value <- lift $ liftProgram $- do output <- C.unsafeGetRef first- C.setRef first input- return output- write_out i (Leaf value)--}-compile (i, TBuff (_ :: proxy (exp a)) u) =- do value <- read_buffer u :: Type exp (exp a)- write_out i (Leaf value)--compile (i, TMap ti to f _) =- do input <- read_in i ti- value <- return $ f input- write_out i value- -compile _ = return ()-------------------------------------------------------------------------------------- | ...-compiler' :: forall exp a b.- ( Typeable exp, Typeable a, Typeable b- , EEq exp Int, Num (exp Int), Integral (exp Int)- )- => [(Unique, Node exp)]- -> Resolution Unique exp- -> Map Unique Order- -> Bool- -> (Stream exp (exp a) -> Stream exp (exp b))-compiler' nodes links order opt input = Str.stream $- do (nodes', buffers) <- if opt then opt_delay_chains nodes else return (nodes, M.empty)- env <- init (Str.run input) buffers- return $- do let t = undefined :: TStruct exp (Empty (exp b))- delays = [ d | d@(_, TDelay {}) <- nodes]- sorted = sort nodes'- last = final sorted- keys = M.keys buffers- - (Leaf value) <- flip runReaderT env $- do mapM_ compile sorted- forM_ keys write_buffer- forM_ delays update_delay- read_out last t-- return value-- where- -- Create initial eviroment- init :: Prog exp (exp a) -> Map Unique (Ex (Buffer exp)) -> Prog exp (Enviroment Unique exp)- init i b =- do let delays = M.fromList [ d | d@(_, TDelay {}) <- nodes]- fnodes = map fst $ filterNOP nodes- flinks = Resolution {- _output = M.filterWithKey (\k _ -> k `elem` fnodes) $ _output links- , _input = M.filterWithKey (\k _ -> k `elem` fnodes) $ _input links- }- firsts <- M.traverseWithKey (const $ init_delay) delays- channels <- initChannels flinks- return $ Env {- _links = links- , _channels = channels- , _firsts = firsts- , _buffers = b- , _inputs = wrap i- }-- -- ...- init_delay :: Node exp -> Prog exp (Ex (C.Ref :*: exp))- init_delay (TDelay d _) = C.newRef d >>= return . wrap-- -- ...- update_delay :: (Unique, Node exp) -> Type exp ()- update_delay (i, TDelay (e :: exp x) _) =- do first <- asks (unwrap . (! i) . _firsts) :: Type exp (C.Ref (exp a))- (Leaf input) <- read_in i (undefined :: TStruct exp (Empty (exp a)))- lift $ liftProgram $ C.setRef first input-- -- Sort graph nodes by the given ordering- sort :: [(Unique, Node exp)] -> [(Unique, Node exp)]- sort = fmap (fmap snd) . sortBy (compare `on` (fst . snd))- . M.toList . M.intersectionWith (,) order- . M.fromList-- -- Find final reference to read output from- final :: [(Unique, Node exp)] -> Unique- final = fst . last . filterNOP-- -- Filter unused nodes- filterNOP :: [(Unique, Node exp)] -> [(Unique, Node exp)]- filterNOP = filter (not . nop . snd)- where nop (TLambda {}) = True- nop (TZip {}) = True- nop (TFst {}) = True- nop (TSnd {}) = True- nop _ = False------------------------------------------------------------------------------------- * Buffers-----------------------------------------------------------------------------------data Buffer exp a = Buffer- { getBuff :: Program (CMD exp) (exp a)- , putBuff :: exp a -> Program (CMD exp) ()- }--newBuff :: forall exp a. (EEq exp Int, Num (exp Int), Integral (exp Int))- => exp Int -> exp a -> Prog exp (Buffer exp a)-newBuff size init =- do arr <- C.newArr size init- ir <- C.newRef (0 :: exp Int)-- let get = do i <- C.unsafeGetRef ir- C.iff (i ==: 0)- (C.setRef ir size)- (C.setRef ir (i - 1))- C.getArr i arr- - let put a = do i <- C.unsafeGetRef ir- C.setArr i a arr- C.iff (i ==: size)- (C.setRef ir 0)- (C.setRef ir (i + 1))-- return $ Buffer get put-------------------------------------------------------------------------------------- | For each node in the given list, it finds any chain of delays associated--- with the node and returns a mapping over each chained node and its chain-find_chains :: [(Unique, Node e)] -> Map Unique [(Unique, Node e)]-find_chains nodes = - let delays = M.foldrWithKey (\k n -> M.insert (head $ edges n) (k, n)) M.empty- $ M.fromList [ d | d@(i, TDelay {}) <- nodes ]- heads = M.foldr (M.delete . fst) delays delays- in M.filter ((>1) . length) $ M.map (flip chain delays) heads- where- chain v@(i, _) m = v : maybe [] (flip chain m) (M.lookup i m)---- | -buffer_chains :: forall e. (EEq e Int, Integral (e Int), Num (e Int))- => Map Unique [(Unique, Node e)] -- original chains- -> Prog e ( Map Unique [(Unique, Node e)] -- updated chains- , Map Unique (Ex (Buffer e)) -- buffers- )-buffer_chains chains = - do let values = M.map (map val) chains- chains' = M.mapWithKey (map . acc) chains-- -- Since newBuff fills the entire array with the same value,- -- we only use the first value of the delay chains.- -- This should be fixed!- buffers <- traverse (\x@((Ex v):_) ->- do buff <- newBuff (fromIntegral $ length x) v- return (Ex buff)- )- values- - return (chains', buffers)- where- val (i, TDelay v _) = Ex v- acc k (i, TDelay v _) = (i, TBuff (apa v) k)- where apa :: exp a -> Proxy (exp a)- apa _ = Proxy::Proxy (exp a)---- | Replaces all original nodes with the updated chain versions-replace_chains :: [(Unique, Node e)] -> Map Unique [(Unique, Node e)] -> [(Unique, Node e)]-replace_chains nodes = M.toList . M.foldr (flip $ foldr $ uncurry M.insert) (M.fromList nodes)-------------------------------------------------------------------------------------- | ...------ We assume that:--- * Each delay chains values are of the same type--- * ...-opt_delay_chains :: (EEq e Int, Num (e Int), Integral (e Int))- => [(Unique, Node e)]- -> Prog e ( [(Unique, Node e)]- , Map Unique (Ex (Buffer e))- )-opt_delay_chains nodes =- do (chains, buffers) <- buffer_chains $ find_chains nodes- return (replace_chains nodes chains, buffers)------------------------------------------------------------------------------------- * Testing-----------------------------------------------------------------------------------inspect_compiler :: ( Typeable exp, Typeable a, Typeable b- , EEq exp Int, Num (exp Int), Integral (exp Int)- )- => (Sig exp a -> Sig exp b)- -> IO (Str exp a -> Str exp b)-inspect_compiler f =- do (Graph nodes root) <- reifyGraph f-- let links = linker nodes- order = sorter root nodes- cycle = cycles root nodes- - putStrLn "=================================================="- putStrLn "= Inspecting Compiler"- putStrLn "=================================================="- putStrLn "- Nodes"- putStrLn "--------------------------------------------------"- putStrLn $ show nodes- putStrLn "--------------------------------------------------"- putStrLn "- Order"- putStrLn "--------------------------------------------------"- putStrLn $ show order- putStrLn "--------------------------------------------------"- putStrLn "- Input Links"- putStrLn "--------------------------------------------------"- putStrLn $ show $ _input links- putStrLn "--------------------------------------------------"- putStrLn "- Output Links"- putStrLn "--------------------------------------------------"- putStrLn $ show $ _output links- putStrLn "--------------------------------------------------"-- return $ \input -> case cycle of- True -> error "found cycle in graph"- False -> compiler' nodes links order True input----------------------------------------------------------------------------------- -m !? i = case M.lookup i m of- Just x -> x- Nothing -> error $ "Can't find key " ++ show i ++- " in map: \n" ++ show m
− Backend/Compiler/Cycles.hs
@@ -1,85 +0,0 @@-module Backend.Compiler.Cycles (- cycles- )-where--import Frontend.SignalObsv (TSignal(..), Node, edges)--import Control.Monad.State-import Data.Reify (Graph(..), Unique, reifyGraph)--import Data.Map (Map, (!))-import qualified Data.Map as M--import Prelude hiding (pred, cycle)------------------------------------------------------------------------------------- * Cycles------------------------------------------------------------------------------------- | A node can have three different states during cycle checking--- * Visited, no cycles detected in node or children--- * Visiting, node is being checked for cycles--- * Unvisited, node has not yet been checked for cycles-data Status = Visited | Visiting | Unvisited deriving Eq---- | A node's predecessor-type Predecessor = Unique-------------------------------------------------------------------------------------- | Updates the status for a node-mark :: Unique -> Status -> State (Map Unique (Status, p, n)) ()-mark u s = modify $ flip M.adjust u $ \(_, p, n) -> (s, p, n)---- | Updates the predecessor for a node-pred :: Unique -> Predecessor -> State (Map Unique (s, Predecessor, n)) ()-pred u p = modify $ flip M.adjust u $ \(s, _, n) -> (s, p, n)---- | Gets the status of a node-status :: Unique -> State (Map Unique (Status, p, n)) Status-status u = get >>= return . (\(s, _, _) -> s) . (! u)---- | Gets the predecessor of a node-predecessor :: Unique -> State (Map Unique (s, Predecessor, n)) Predecessor-predecessor u = get >>= return . (\(_, p, _) -> p) . (! u)---- | Gets the adjacent nodes of a node-adjacent :: Unique -> State (Map Unique (s, p, Node e)) [Unique]-adjacent u = get >>= return . (\(_, _, n) -> edges' n) . (! u)- where- -- simply ignore delay edges, this will make the algorithm fail only when- -- bad cycles are detected- edges' (TDelay {}) = []- edges' x = edges x-------------------------------------------------------------------------------------- | ...-cycle :: Unique -> State (Map Unique (Status, Predecessor, Node e)) Bool-cycle u =- do mark u Visiting- ns <- adjacent u- bs <- forM ns $ \n ->- do p <- predecessor n- s <- status n- case s of- Unvisited -> pred n u >> cycle n - Visiting | p /= u -> return False- _ -> return True- mark u Visited- return $ and bs----------------------------------------------------------------------------------- --- | Checks if there are cycles in the given graph, returns true if there are-cycles :: Unique -> [(Unique, Node e)] -> Bool-cycles root nodes = go root init- where- init = M.fromList $ map (fmap ((,,) Unvisited 0)) nodes- go u s =- let (b, m) = runState (cycle u) s- n = M.filter (\(s, _, _) -> s == Unvisited) m- in case M.null n of- True -> not b- False -> go (fst $ M.findMin n) m
− Backend/Compiler/Linker.hs
@@ -1,133 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Backend.Compiler.Linker (- Resolution(..)- , TEx- , linker- )-where--import Frontend.Stream (Stream)-import Frontend.Signal (TStruct(..), Struct, Empty, tpair, tleft, tright, tleaf)-import Frontend.SignalObsv (TSignal(..), Node)--import Backend.Knot-import Backend.Ex--import Control.Monad.Reader-import Control.Monad.Writer-import Control.Monad.Identity--import Data.Map (Map, (!))-import qualified Data.Map as M--import Data.Reify (Unique, Graph(..), reifyGraph)-import Data.Typeable------------------------------------------------------------------------------------- * Linking------------------------------------------------------------------------------------- | Untyped binary tree over reference names-type TEx exp = Ex (TStruct exp)---- | ... I assume each index yeilds a tree with the expected type-data Resolution symbol exp = Resolution- { _output :: Map symbol (TEx exp)- , _input :: Map symbol (TEx exp)- }---- | Constraints over symbol to input/output tree-data Constraint symbol exp- = In (symbol, TEx exp)- | Out (symbol, TEx exp)-------------------------------------------------------------------------------------- | Attempts to fetch resolved value of index-resolve :: (MonadReader (Resolution i exp) m, Ord i, Typeable a) => i -> TStruct exp a -> m (TStruct exp a)-resolve i _ =- do ex <- asks ((! i) . _output)- return $ case ex of- Ex t -> case gcast t of- Nothing -> error "resolve: type error"- Just o -> o---- | Mark tree with index-mark :: String -> TStruct exp a -> TStruct exp a-mark s (TLeaf _) = TLeaf (s)-mark s (TPair l r) = TPair (mark (s ++ "_l") l) (mark (s ++ "_r") r)---- | Adds an output constraint-constrain :: (MonadWriter [Constraint i exp] m, Typeable a) => i -> TStruct exp a -> m ()-constrain i t = tell [Out (i, Ex t)]---- | Adds an input constraint-introduce :: (MonadWriter [Constraint i exp] m, Typeable a) => i -> TStruct exp a -> m ()-introduce i t = tell [In (i, Ex t)]-------------------------------------------------------------------------------------- | Given a signal node, link creates constraints modeling its relation to others-link :: forall m i exp. (Monad m, Ord i, Show i)- => (i, TSignal exp i)- -> Knot (Resolution i exp)- (Constraint i exp) m- ()--link (i, TLambda l r) =- do return ()--link (i, TVar t) =- do constrain i $ mark (show i) t--link (i, TConst (c :: Stream exp (exp a))) =- do constrain i (tleaf (show i) :: TStruct exp (Empty (exp a))) --link (i, TLift (f :: Stream exp (exp a) -> Stream exp (exp b)) s) =- do let t = undefined :: TStruct exp (Empty (exp a))- t' <- resolve s t- introduce i t'- constrain i (tleaf (show i) :: TStruct exp (Empty (exp b)))--link (i, TDelay (e :: exp a) s) =- do let t = undefined :: TStruct exp (Empty (exp a))- t' <- resolve s t- introduce i t'- constrain i (tleaf (show i) :: TStruct exp (Empty (exp a)))--link (i, TMap ti to f s) =- do t' <- resolve s ti- introduce i t'- constrain i $ mark (show i) to--link (i, TZip tl tr l r) =- do tl' <- resolve l tl- tr' <- resolve r tr- constrain i $ tpair tl' tr'--link (i, TFst t l) =- do t' <- resolve l t- constrain i $ tleft t'--link (i, TSnd t r) =- do t' <- resolve r t- constrain i $ tright t'-------------------------------------------------------------------------------------- | ...-linker :: [(Unique, Node exp)] -> Resolution Unique exp-linker = snd . runIdentity . tie solve . sequence . fmap link---- | ...-solve :: Solver (Resolution Unique exp) (Constraint Unique exp)-solve constraints =- let inputs = [ i | In i <- constraints]- outputs = [ o | Out o <- constraints]- in Resolution- { _output = M.fromList outputs- , _input = M.fromList inputs- }
− Backend/Compiler/Sorter.hs
@@ -1,74 +0,0 @@-module Backend.Compiler.Sorter (- Order- , sorter- )-where--import Frontend.SignalObsv (TSignal(..), Node, edges)--import Control.Arrow-import Control.Monad.State--import Data.Reify (Graph(..), Unique, reifyGraph)--import Data.Map (Map, (!))-import qualified Data.Map as M------------------------------------------------------------------------------------- * Sorter------------------------------------------------------------------------------------- | During the sorting process a node can either be sorted or unvisited -data Status = Visited | Unvisited---- | The ordering assigned to a node after being sorted-type Order = Int-------------------------------------------------------------------------------------- | Returns a new and unique ordering-new :: State (Int, m) Order-new = do (i, m) <- get- put (i + 1, m)- return i---- | Updates the order of a node-tag :: Unique -> Order -> State (i, Map Unique (s, Order, n)) ()-tag u o = modify $ second $ flip M.adjust u $ \(s, _, n) -> (s, o, n)---- | Updates the status of a node-mark :: Unique -> Status -> State (i, Map Unique (Status, o, n)) ()-mark u s = modify $ second $ flip M.adjust u $ \(_, o, n) -> (s, o, n)---- | Gets the status of a node-status :: Unique -> State (i, Map Unique (Status, o, n)) Status-status u = get >>= return . (\(s, _, _) -> s) . (! u) . snd---- | Gets the adjacent nodes of an node-adjacent :: Unique -> State (i, Map Unique (s, o, Node e)) [Unique]-adjacent u = get >>= return . edges . (\(_, _, n) -> n) . (! u) . snd-------------------------------------------------------------------------------------- | Standard depth-first ordering of a graph------ I wonder if this would look nicer when using knots intsead..-sort :: Unique -> State (Int, Map Unique (Status, Order, Node e)) ()-sort u =- do mark u Visited- ns <- adjacent u- forM_ ns $ \n ->- do s <- status n- case s of- Visited -> return ()- Unvisited -> sort n- o <- new- tag u o-------------------------------------------------------------------------------------- | Given a root and a set of graph nodes, a topological ordering is produced-sorter :: Unique -> [(Unique, Node e)] -> Map Unique Order-sorter root nodes = M.map (\(_, o, _) -> o) $ snd $ execState (sort root) init- where- init = (1, M.fromList $ map (fmap ((,,) Unvisited 0)) nodes)
− Backend/Ex.hs
@@ -1,62 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE TypeOperators #-}------------------------------------------ Testing-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE OverlappingInstances #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE AllowAmbiguousTypes #-}-------------------------------------------module Backend.Ex where--import Data.Typeable-import Data.Proxy------------------------------------------ Testing-import Frontend.Signal (TStruct(..))------------------------------------------------------------------------------------------------------------------------------ * Existential types------------------------------------------------------------------------------------- | Existential types over containers-data Ex c- where- Ex :: Typeable a => c a -> Ex c---- | Wrapper type for nested containers-newtype (f :*: g) e = T (f (g e))------------------------------------------------------------------------------------- ** Instances--instance Show (Ex c) where show _ = "Ex"------------------------------------------------------------------------------------- ** Helper functinons for generalized existential types---- | Hides the inner argument, wrapping the types-wrap :: Typeable e => f (g e) -> Ex (f :*: g)-wrap = Ex . T---- | Retreives the inner type, uses type casting-unwrap :: Typeable e => Ex (f :*: g) -> f (g e)-unwrap (Ex t) = case gcast t of- Just (T x) -> x- Nothing -> error "unwrap: type error"------------------------------------------------------------------------------------- * Testing-----------------------------------------------------------------------------------instance Show (Ex (TStruct e))- where- show (Ex s) = showTS s--showTS :: TStruct e a -> String-showTS (TLeaf c) = show c-showTS (TPair l r) = "(" ++ showTS l ++ "," ++ showTS r ++ ")"
− Backend/Knot.hs
@@ -1,31 +0,0 @@-{-# LANGUAGE RecursiveDo #-}--module Backend.Knot (- Knot- , Solver- , tie- )-where--import Control.Monad.Reader-import Control.Monad.Writer-import Control.Monad.Fix------------------------------------------------------------------------------------- * Knot Monad------------------------------------------------------------------------------------- | Knot monad transformer-type Knot resolution constraint m = ReaderT resolution (WriterT [constraint] m)---- | Resolve linking constraints-type Solver resolution constraint = [constraint] -> resolution-------------------------------------------------------------------------------------- | Tie the knot using @solve@ to resolve any constraints-tie :: MonadFix m => Solver resolution constraint -> Knot resolution constraint m a -> m (a, resolution)-tie solve knot =- mdo (a, constraints) <- runWriterT $ runReaderT knot solution- let solution = solve constraints- return (a, solution)
− Backend/Struct.hs
@@ -1,25 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE DeriveDataTypeable #-}--module Backend.Struct where--import Data.Typeable------------------------------------------------------------------------------------- *-----------------------------------------------------------------------------------data Empty a deriving Typeable--data Struct exp a- where- Leaf :: Typeable a => exp a -> Struct exp (Empty (exp a))- Node :: Struct exp a- -> Struct exp b- -> Struct exp (a, b)- deriving- Typeable------------------------------------------------------------------------------------- **-
− Core.hs
@@ -1,189 +0,0 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Core where--import Interpretation--import Control.Monad.Operational-import Data.Constraint-import Data.Dynamic-import Data.Typeable-import Data.IORef-import Data.Array.IO.Safe-import qualified System.IO as IO------------------------------------------------------------------------------------- * Commands------------------------------------------------------------------------------------- | Imperative commands-data CMD exp a- where- -- ^ File management (IOHandler in Haskell)- Open :: FilePath -> CMD exp Handle- Close :: Handle -> CMD exp ()- Put :: Handle -> exp Float -> CMD exp ()- Get :: Handle -> CMD exp (exp Float)- Eof :: Handle -> CMD exp (exp Bool)-- -- ^ Mutable references (IORef in Haskell)- InitRef :: Typeable a => CMD exp (Ref (exp a))- NewRef :: Typeable a => exp a -> CMD exp (Ref (exp a))- GetRef :: Typeable a => Ref (exp a) -> CMD exp (exp a)- SetRef :: Ref (exp a) -> exp a -> CMD exp ()-- -- ^ Mutable arrays (IOArray in Haskell)- NewArr :: Integral n => exp n -> exp a -> CMD exp (Arr (exp a))- GetArr :: Integral n => exp n -> Arr (exp a) -> CMD exp (exp a)- SetArr :: Integral n => exp n -> exp a -> Arr (exp a) -> CMD exp ()-- -- no new var. is assigned.- UnsafeGetRef :: Ref (exp a) -> CMD exp (exp a)- UnsafeGetArr :: Integral n => exp n -> Arr (exp a) -> CMD exp (exp a)-- -- ^ Control structures | Todo: Move to seperate data class- If :: exp Bool- -> Program (CMD exp) ()- -> Program (CMD exp) ()- -> CMD exp ()- While :: Program (CMD exp) (exp Bool)- -> Program (CMD exp) ()- -> CMD exp ()- Break :: CMD exp ()-- -- ^ Misc.- Printf :: Show a => String -> exp a -> CMD exp ()- GetTime :: CMD exp (exp Double)---- |-data Handle- = HandleComp String- | HandleEval IO.Handle- deriving Typeable---- |-data Ref a- = RefComp String- | RefEval (IORef a)- deriving Typeable---- |-data Arr a- = ArrComp String- | ArrEval (IOArray Int a)- deriving Typeable------------------------------------------------------------------------------------- ** User Interface------------------------------------------------------------------------------------- *** File Handling--open :: FilePath -> ProgramT (CMD exp) m Handle-open = singleton . Open--close :: Handle -> ProgramT (CMD exp) m ()-close = singleton . Close--fput :: Handle -> exp Float -> ProgramT (CMD exp) m ()-fput p = singleton . Put p--fget :: Handle -> ProgramT (CMD exp) m (exp Float)-fget = singleton . Get--feof :: Handle -> ProgramT (CMD exp) m (exp Bool)-feof = singleton . Eof------------------------------------------------------------------------------------- *** Variables--initRef :: Typeable a => ProgramT (CMD exp) m (Ref (exp a))-initRef = singleton InitRef--newRef :: Typeable a => exp a -> ProgramT (CMD exp) m (Ref (exp a))-newRef e = singleton (NewRef e)--getRef :: Typeable a => Ref (exp a) -> ProgramT (CMD exp) m (exp a)-getRef r = singleton (GetRef r)--setRef :: Ref (exp a) -> exp a -> ProgramT (CMD exp) m ()-setRef r = singleton . SetRef r------------------------------------------------------------------------------------- *** Arrays--newArr :: Integral n => exp n -> exp a -> ProgramT (CMD exp) m (Arr (exp a))-newArr n = singleton . NewArr n--getArr :: Integral n => exp n -> Arr (exp a) -> ProgramT (CMD exp) m (exp a)-getArr n = singleton . GetArr n--setArr :: Integral n => exp n -> exp a -> Arr (exp a) -> ProgramT (CMD exp) m ()-setArr n a = singleton . SetArr n a--------------------------------------------- Unsafe---- | Like 'getRef' but assumes that the reference will not be modified later--- in the program-unsafeGetRef :: Ref (exp a) -> ProgramT (CMD exp) m (exp a)-unsafeGetRef = singleton . UnsafeGetRef- -- TODO: It would be possible to make a conservative analysis to find out if- -- uses of `unsafeGetRef` are safe. Even better, the compiler could- -- automatically treat `getRef` as `unsafeGetRef` whenever possible.--unsafeGetArr :: Integral n => exp n -> Arr (exp a) -> ProgramT (CMD exp) m (exp a)-unsafeGetArr i = singleton . UnsafeGetArr i------------------------------------------------------------------------------------- **--iff :: exp Bool- -> Program (CMD exp) ()- -> Program (CMD exp) ()- -> Program (CMD exp) ()-iff b t f = singleton $ If b t f--while :: Program (CMD exp) (exp Bool)- -> Program (CMD exp) ()- -> Program (CMD exp) ()-while b t = singleton $ While b t--break :: Program (CMD exp) ()-break = singleton Break--printf :: Show a => String -> exp a -> Program (CMD exp) ()-printf format = singleton . Printf format--getTime :: Program (CMD exp) (exp Double)-getTime = singleton GetTime------------------------------------------------------------------------------------- * Constructs------------------------------------------------------------------------------------- |-data Construct cmd a- where- Function :: String -> Program cmd () -> Construct cmd ()------------------------------------------------------------------------------------- ** User Interface--mkFunction :: String -> Program cmd () -> Program (Construct cmd) ()-mkFunction fun body = singleton $ Function fun body------------------------------------------------------------------------------------- *-----------------------------------------------------------------------------------class EEq exp a- where- (==:) :: exp a -> exp a -> exp Bool- (/=:) :: exp a -> exp a -> exp Bool
− Examples/Simple/Expr.hs
@@ -1,263 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}--module Examples.Simple.Expr where--import Core (EEq(..))-import Interpretation--import Backend.C.Monad--import Language.C.Quote.C-import qualified Language.C.Syntax as C-import Data.Typeable (Typeable)------------------------------------------------------------------------------------- * Expressions------------------------------------------------------------------------------------- |-data Expr a- where- Val :: Show a => a -> Expr a- Var :: VarId -> Expr a-- -- ^ Math. operations- Add :: Num a => Expr a -> Expr a -> Expr a- Sub :: Num a => Expr a -> Expr a -> Expr a- Mul :: Num a => Expr a -> Expr a -> Expr a- Div :: Fractional a => Expr a -> Expr a -> Expr a- Exp :: Floating a => Expr a -> Expr a -> Expr a- Sin :: Floating a => Expr a -> Expr a- Mod :: Integral a => Expr a -> Expr a -> Expr a- I2N :: (Integral a, Num b) => Expr a -> Expr b-- -- ^ Bool. operations- Not :: Expr Bool -> Expr Bool- And :: Expr Bool -> Expr Bool -> Expr Bool- Or :: Expr Bool -> Expr Bool -> Expr Bool-- Eq :: Eq a => Expr a -> Expr a -> Expr Bool- LEq :: Ord a => Expr a -> Expr a -> Expr Bool- deriving Typeable---- | Variable indetifiers-type VarId = String------------------------------------------------------------------------------------- ** Instances--instance (Show a, Eq a) => Eq (Expr a) -- bad- where- a == b = todo- a /= b = todo--instance (Show a, Ord a) => Ord (Expr a) -- bad- where- a <= b = todo--instance (Show a, Real a) => Real (Expr a) -- bad- where- toRational = todo--instance (Show a, Enum a) => Enum (Expr a) -- bad- where- toEnum = todo; fromEnum = todo;--instance (Show a, Integral a) => Integral (Expr a)- where- mod = Mod-- quotRem = todo; toInteger = todo;--instance (Show a, Num a, Eq a) => Num (Expr a)- where- fromInteger = Val . fromInteger- Val a + Val b = Val (a+b)- Val 0 + b = b- a + Val 0 = a- a + b = Add a b- Val a - Val b = Val (a-b)- Val 0 - b = b- a - Val 0 = a- a - b = Sub a b- Val a * Val b = Val (a*b)- Val 0 * b = Val 0- a * Val 0 = Val 0- Val 1 * b = b- a * Val 1 = a- a * b = Mul a b-- signum = todo; abs = todo;--instance (Show a, Fractional a, Eq a) => Fractional (Expr a)- where- fromRational = Val . fromRational- Val a / Val b = Val (a/b)- a / b = Div a b-- recip = todo;--instance (Show a, Floating a, Eq a) => Floating (Expr a)- where- pi = Val pi- sin = Sin- Val a ** Val b = Val (a**b)- a ** b = Exp a b-- exp = todo; sqrt = todo; log = todo;- tan = todo; cos = todo; asin = todo;- atan = todo; acos = todo; sinh = todo;- tanh = todo; cosh = todo; asinh = todo;- atanh = todo; acosh = todo; logBase = todo;--i2n :: (Integral a, Num b) => Expr a -> Expr b-i2n = I2N--todo = error "todo in expr" -- I'll add these later------------------------------------------------------------------------------------- **--instance Eq a => EEq Expr a- where- (==:) = eq- (/=:) = neq------------------------------------------------------------------------------------- *-----------------------------------------------------------------------------------tru :: Expr Bool-tru = Val True--fls :: Expr Bool-fls = Val False--eq :: Eq a => Expr a -> Expr a -> Expr Bool-eq = Eq--neq :: Eq a => Expr a -> Expr a -> Expr Bool-neq a b = Not $ a `eq` b--leq :: Ord a => Expr a -> Expr a -> Expr Bool-leq = LEq--lt :: Ord a => Expr a -> Expr a -> Expr Bool-lt l r = (LEq l r) `And` (Not $ Eq r l)--gt :: Ord a => Expr a -> Expr a -> Expr Bool-gt = flip lt------------------------------------------------------------------------------------- * Evaluation-----------------------------------------------------------------------------------instance EvalExp Expr- where- type LitPred Expr = Show-- litExp = Val- evalExp = evalExpr'---- |-evalExpr' :: Expr a -> a-evalExpr' (Val a) = a-evalExpr' (Var _) = error "cannot eval var"---- ^ Math. ops.-evalExpr' (Add a b) = evalExpr' a + evalExpr' b-evalExpr' (Sub a b) = evalExpr' a - evalExpr' b-evalExpr' (Mul a b) = evalExpr' a * evalExpr' b-evalExpr' (Div a b) = evalExpr' a / evalExpr' b-evalExpr' (Mod a b) = evalExpr' a `mod` evalExpr' b-evalExpr' (Sin a) = sin $ evalExpr' a-evalExpr' (I2N a) = fromInteger $ fromIntegral $ evalExpr' a---- ^ Bool. ops.-evalExpr' (Not a) = not $ evalExpr' a-evalExpr' (And a b) = evalExpr' a && evalExpr' b-evalExpr' (Or a b) = evalExpr' a || evalExpr' b-evalExpr' (Eq a b) = evalExpr' a == evalExpr' b-evalExpr' (LEq a b) = evalExpr' a <= evalExpr' b------------------------------------------------------------------------------------- * Compilation of Expressions-----------------------------------------------------------------------------------class Any a-instance Any a--instance CompExp Expr- where- type VarPred Expr = Any- varExp = Var- compExp = compExp'---- |-compExp' :: Expr a -> C C.Exp-compExp' (Var v) = return [cexp| $id:v |]-compExp' (Val v) = case show v of- "True" -> addInclude "<stdbool.h>" >> return [cexp| true |]- "False" -> addInclude "<stdbool.h>" >> return [cexp| false |]- v' -> return [cexp| $id:v' |]---- ^ Math. ops.-compExp' (Add a b) = do- a' <- compExp' a- b' <- compExp' b- return [cexp| $a' + $b' |]-compExp' (Sub a b) = do- a' <- compExp' a- b' <- compExp' b- return [cexp| $a' - $b' |]-compExp' (Mul a b) = do- a' <- compExp' a- b' <- compExp' b- return [cexp| $a' * $b' |]-compExp' (Div a b) = do- a' <- compExp' a- b' <- compExp' b- return [cexp| $a' / $b' |]-compExp' (Exp a b) = do- a' <- compExp' a- b' <- compExp' b- return [cexp| $a' ^ $b' |]-compExp' (Sin a) = do- a' <- compExp' a- return [cexp| sin( $a' ) |]-compExp' (Mod a b) = do- a' <- compExp' a- b' <- compExp' b- return [cexp| $a' % $b'|]-compExp' (I2N a) = do- a' <- compExp' a- return [cexp| $a' |]---- ^ Bool. ops.-compExp' (Not a) = do- a' <- compExp' a- return [cexp| ! $a' |]-compExp' (And a b) = do- a' <- compExp' a- b' <- compExp' b- return [cexp| ($a' && $b') |]-compExp' (Or a b) = do- a' <- compExp' a- b' <- compExp' b- return [cexp| ($a' || $b') |]-compExp' (Eq a b) = do- a' <- compExp' a- b' <- compExp' b- return [cexp| $a' == $b' |]-compExp' (LEq a b) = do- a' <- compExp' a- b' <- compExp' b- return [cexp| $a' <= $b' |]--
− Examples/Simple/Filters.hs
@@ -1,163 +0,0 @@-module Examples.Simple.Filters where--import Prelude hiding (break)--import Core-import Interpretation--import Examples.Simple.Expr-import Frontend.Signal (Sig)-import Frontend.Stream (Str, Stream(..))-import Backend.Compiler.Compiler-import qualified Frontend.Signal as S-import qualified Frontend.Stream as Str-import qualified Backend.C as B--import Control.Monad-import Control.Monad.Operational (Program)-import Text.PrettyPrint.Mainland-import Data.IORef-import Data.Array.IO.Safe-import qualified System.IO as IO-import qualified Text.Printf as Printf------------------------------------------------------------------------------------- * Misc Types-----------------------------------------------------------------------------------type E = Expr--type S = Sig E--type P = Program (CMD E)-------------------------------------------------------------------------------------- | classical for loop-for :: E Int -> E Int -> (E Int -> P ()) -> P ()-for lo hi body = do- ir <- newRef lo- while- (do i <- unsafeGetRef ir; return (leq i hi))- (do i <- unsafeGetRef ir- a <- body i- setRef ir (i+1)- return a- )- -- unsafeGetRef is fine because writing to the reference is the last thing- -- that happens in each iteration------------------------------------------------------------------------------------- * FIR Filter Example-----------------------------------------------------------------------------------fir :: [E Float] -> S Float -> S Float-fir as = sums . muls as . delays ds- where ds = replicate (length as) 0--sums :: [S Float] -> S Float-sums = foldr1 (+)--muls :: [E Float] -> [S Float] -> [S Float]-muls as = zipWith (*) (map S.repeat as)--delays :: [E Float] -> S Float -> [S Float]-delays as s = scanl (flip S.delay) s as------------------------------------------------------------------------------------- * IIR Filter Examples-----------------------------------------------------------------------------------iir :: [E Float] -> [E Float] -> S Float -> S Float-iir (a:as) bs s = o- where- u = fir bs s- l = fir as $ S.delay 0 o- o = (1 / S.repeat a) * (u - l)------------------------------------------------------------------------------------- * FFT Filter Examples------------------------------------------------------------------------------------- todo------------------------------------------------------------------------------------- * Testing of filters------------------------------------------------------------------------------------- for eval you will need to make sure there is an input file, called "input",--- to read from. Its a standard file of numbers seperated by a space.--test_fir = comp (fir [1,2,3])-eval_fir = eval (fir [1,2,3])--test_iir = comp (iir [1,2] [3,4]) -- crashes! why?!..-eval_iir = eval (iir [1,2] [3,4])------------------------------------------------------------------------------------crash = test (fir [1,2,3,4])-------------------------------------------------------------------------------------- |-eval :: (S Float -> S Float) -> IO ()-eval = connect_io >=> B.runProgram---- | ...-comp :: (S Float -> S Float) -> IO Doc-comp = connect_io >=> B.cgen . mkFunction "main"---- |-test :: (S Float -> S Float) -> IO Doc-test = inspect_io >=> B.cgen . mkFunction "test"------------------------------------------------------------------------------------connect_io :: (S Float -> S Float) -> IO (P ())-connect_io s = do- prg <- compiler s- return $ do- inp <- open "input"- outp <- open "output"-- let (Stream init) = prg $ Str.stream $ return $ do- i <- fget inp- isEOF <- feof inp- iff isEOF break (return ())- -- Apparently EOF can only be detected after one has tried to read past the end- return i-- let setty = fput outp- getty <- init- while (return $ litExp True)- (do v <- getty- setty v)-- close inp- close outp------------------------------------------------------------------------------------inspect_io :: (S Float -> S Float) -> IO (P ())-inspect_io s = do- prg <- inspect_compiler s- return $ do- inp <- open "input"- outp <- open "output"-- let (Stream init) = prg $ Str.stream $ return $ do- i <- fget inp- isEOF <- feof inp- iff isEOF break (return ())- -- Apparently EOF can only be detected after one has tried to read past the end- return i-- let setty = fput outp- getty <- init- while (return $ litExp True)- (do v <- getty- setty v)-- close inp- close outp
− Frontend/Signal.hs
@@ -1,319 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}--module Frontend.Signal where--import Interpretation--import Frontend.Stream (Stream, Str)-import qualified Frontend.Stream as S--import Data.Dynamic-import Data.Typeable--import Prelude ( ($), (.), id- , Num, (+), (-), (*), fromInteger- , Fractional, (/), fromRational- , Floating, (**), pi, sin- , Eq, Show, String)-import qualified Prelude as P------------------------------------------------------------------------------------- *------------------------------------------------------------------------------------- | ...-data Signal exp a- where- -- ^ lifts consant streams into signals- Const :: Typeable a => Stream exp (exp a) -> Signal exp (Empty (exp a))-- -- ^ lifts stream transformers into signal transformers, possibly state-full- Lift :: (Typeable a, Typeable b)- => (Stream exp (exp a) -> Stream exp (exp b))- -> (Signal exp (Empty (exp a)) -> Signal exp (Empty (exp b)))-- -- ^ maps a function over nested tuples to a function over signals- Map :: ( Typeable a, Typeable b- , StructT a, StructT b- , DomainT a ~ exp- , DomainT b ~ DomainT a)- => (Struct exp a -> Struct exp b) -> Signal exp a -> Signal exp b-- -- ^ joins together two nodes- Zip :: ( Typeable a, Typeable b- , StructT a, StructT b- , DomainT a ~ exp- , DomainT b ~ DomainT a)- => Signal exp a -> Signal exp b -> Signal exp (a, b)-- -- ^ breaks apart a signal of pairs, returning the first- Fst :: ( Typeable a, Typeable b- , StructT a, StructT b- , DomainT a ~ exp- , DomainT b ~ DomainT a)- => Signal exp (a, b) -> Signal exp a-- -- ^ breaks apart a signal of pairs, returning the second- Snd :: ( Typeable a, Typeable b- , StructT a, StructT b- , DomainT a ~ exp- , DomainT b ~ DomainT a)- => Signal exp (a, b) -> Signal exp b-- -- ^ prepends a value to the input signal- Delay :: Typeable a- => exp a -> Signal exp (Empty (exp a)) -> Signal exp (Empty (exp a))-- -- ^ dummy argument used in observable sharing- SVar :: (Typeable a, StructT a, DomainT a ~ exp)- => Dynamic -> Signal exp a-- deriving (Typeable)---- | Signals with values ranging over the expression language-newtype Sig exp a = Sig {unSig :: Signal exp (Empty (exp a))}------------------------------------------------------------------------------------- ** Instances--instance (Typeable exp, Typeable a, Num (exp a), Eq (exp a), Show a) => Num (Sig exp a)- where- fromInteger = repeat . fromInteger- (+) = zipWith (+)- (*) = zipWith (*)- (-) = zipWith (-)-- abs = todo; signum = todo;--instance (Typeable exp, Typeable a, Fractional (exp a), Eq (exp a), Show a) => Fractional (Sig exp a)- where- fromRational = repeat . fromRational- (/) = zipWith (/)-- recip = todo;--instance (Typeable exp, Typeable a, Floating (exp a), Eq (exp a), Show a) => Floating (Sig exp a)- where- pi = repeat pi- sin = map sin- (**) = zipWith (**)-- exp = todo; sqrt = todo; log = todo;- tan = todo; cos = todo; asin = todo;- atan = todo; acos = todo; sinh = todo;- tanh = todo; cosh = todo; asinh = todo;- atanh = todo; acosh = todo; logBase = todo;--todo = P.error "unsupported operation"------------------------------------------------------------------------------------- ** "Smart" constructors--constS :: (Typeable a) => Str exp a -> Sig exp a-constS = Sig . Const--liftS :: (Typeable a, Typeable b)- => (Str exp a -> Str exp b) -> Sig exp a -> Sig exp b-liftS f = Sig . Lift f . unSig--mapS :: ( Typeable a, Typeable b- , StructT a, StructT b- , DomainT a ~ exp- , DomainT b ~ DomainT a)- => (Struct exp a -> Struct exp b) -> Signal exp a -> Signal exp b-mapS = Map------------------------------------------------------------------------------------- ** User Interface--repeat :: (Typeable a) => exp a -> Sig exp a-repeat = constS . S.repeat--map :: (Typeable a, Typeable b) => (exp a -> exp b) -> Sig exp a -> Sig exp b-map f = liftS $ S.map f--delay :: (Typeable a) => exp a -> Sig exp a -> Sig exp a-delay e = Sig . Delay e . unSig--zipWith :: (Typeable exp, Typeable a, Typeable b, Typeable c)- => (exp a -> exp b -> exp c)- -> Sig exp a -> Sig exp b -> Sig exp c-zipWith f = P.curry $ lift $ P.uncurry f------------------------------------------------------------------------------------- * Generalised lifting of Signals------------------------------------------------------------------------------------- | 0-tuple value-data Empty a deriving Typeable---- | Representation of nested tuples as a binary tree-data Struct exp a- where- Leaf :: Typeable a => exp a -> Struct exp (Empty (exp a))- Pair :: Struct exp a -> Struct exp b -> Struct exp (a, b)- deriving- Typeable---- | Similar to `Struct`, with id's at the leafs-data TStruct exp a- where- TLeaf :: Typeable a => String -> TStruct exp (Empty (exp a))- TPair :: TStruct exp a -> TStruct exp b -> TStruct exp (a, b)- deriving- Typeable------------------------------------------------------------------------------------tpair :: TStruct exp a -> TStruct exp b -> TStruct exp (a, b)-tpair l r = TPair l r--tleaf :: Typeable a => String -> TStruct exp (Empty (exp a))-tleaf s = TLeaf s--tleft :: TStruct exp (a, b) -> TStruct exp a-tleft ~t = case t of (TPair l _) -> l--tright :: TStruct exp (a, b) -> TStruct exp b-tright ~t = case t of (TPair _ r) -> r--tid :: TStruct exp (Empty (exp a)) -> String-tid ~t = case t of (TLeaf i) -> i------------------------------------------------------------------------------------- ** Conversion between signals and tuples---- | ...-class StructS a- where- type Internal a :: *- type Domain a :: * -> *-- fromS :: a -> Signal (Domain a) (Internal a)- toS :: Signal (Domain a) (Internal a) -> a--instance StructS (Signal exp (Empty (exp a)))- where- type Internal (Signal exp (Empty (exp a))) = Empty (exp a)- type Domain (Signal exp (Empty (exp a))) = exp-- fromS = id- toS = id--instance StructS (Sig exp a)- where- type Internal (Sig exp a) = Empty (exp a)- type Domain (Sig exp a) = exp-- fromS = unSig- toS = Sig--instance ( StructS a, StructT (Internal a), Typeable (Internal a)- , StructS b, StructT (Internal b), Typeable (Internal b)- , Domain a ~ Domain b- , DomainT (Internal a) ~ DomainT (Internal b)- , DomainT (Internal a) ~ Domain a- ) =>- StructS (a, b)- where- type Internal (a, b) = (Internal a, Internal b)- type Domain (a, b) = Domain a-- fromS (a, b) = Zip (fromS a) (fromS b)- toS p = (toS (Fst p), toS (Snd p))------------------------------------------------------------------------------------- ** Conversion between signals and empty structs (used to remove structs later on)--class StructT a- where- type DomainT a :: * -> *-- rep :: c (DomainT a) a -> TStruct (DomainT a) a--instance Typeable a => StructT (Empty (exp a))- where- type DomainT (Empty (exp a)) = exp-- rep _ = TLeaf ""--instance ( StructT a, Typeable a- , StructT b, Typeable b- , DomainT a ~ DomainT b) =>- StructT (a, b)- where- type DomainT (a, b) = DomainT a-- rep p = TPair (rep $ left p) (rep $ right p)- where- left :: c (DomainT a) (a, b) -> c (DomainT a) a- left = P.undefined-- right :: c (DomainT b) (a, b) -> c (DomainT b) b- right = P.undefined------------------------------------------------------------------------------------- ** Conversion between struct's and tuples---- | ...-class StructE a- where- type Normal a :: *- type DomainE a :: * -> *-- fromE :: Struct (DomainE a) a -> Normal a- toE :: Normal a -> Struct (DomainE a) a--instance Typeable a => StructE (Empty (exp a))- where- type Normal (Empty (exp a)) = exp a- type DomainE (Empty (exp a)) = exp-- fromE (Leaf a) = a- toE a = Leaf a--instance ( StructE a- , StructE b- , DomainE a ~ DomainE b- ) =>- StructE (a, b)- where- type Normal (a, b) = (Normal a, Normal b)- type DomainE (a, b) = DomainE a-- fromE (Pair a b) = (fromE a, fromE b)- toE (a, b) = Pair (toE a) (toE b)------------------------------------------------------------------------------------- ** Lifting operator---- | ...-lift- :: ( -- ...- StructT (Internal s1) , StructT (Internal s2)- , DomainT (Internal s1) ~ Domain s2- , DomainT (Internal s2) ~ Domain s2-- -- we must be able to do the signal \ tuple transformations- , StructS s1 , StructS s2- , StructE (Internal s1), StructE (Internal s2)-- -- the `exp` type of the signals and tuples should be the same- , Domain s1 ~ Domain s2- , DomainE (Internal s1) ~ Domain s1- , DomainE (Internal s2) ~ Domain s2-- -- requires typeable since we make use of `Zip` to transform signals- , Typeable (Internal s1), Typeable (Internal s2)- )- => (Normal (Internal s1) -> Normal (Internal s2)) -> s1 -> s2-lift f = toS . mapS (toE . f . fromE) . fromS
− Frontend/SignalObsv.hs
@@ -1,149 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}--module Frontend.SignalObsv where--import Interpretation--import Frontend.Signal (Signal(..), Sig(..), StructT(..), Empty, Struct, TStruct)-import Frontend.Stream (Stream(..), Str(..))--import Control.Applicative hiding (Const)-import Data.Dynamic-import Data.Proxy-import Data.Reify-import Data.Typeable------------------------------------------------------------------------------------- * Graph representation of Signals-----------------------------------------------------------------------------------data TSignal exp r- where- -- ^ Signal functions- TLambda :: r -> r -> TSignal exp r-- TVar :: (Typeable a, Typeable exp)- => TStruct exp a- -> TSignal exp r-- -- ^ Signal- TConst :: (Typeable a, Typeable exp)- => Stream exp (exp a) -> TSignal exp r-- TLift :: (Typeable a, Typeable b, Typeable exp)- => (Stream exp (exp a) -> Stream exp (exp b))- -> r -> TSignal exp r-- TMap :: (Typeable a, Typeable b, Typeable exp)- => TStruct exp a -> TStruct exp b- -> (Struct exp a -> Struct exp b)- -> r -> TSignal exp r-- TZip :: (Typeable a, Typeable b)- => TStruct exp a- -> TStruct exp b- -> r -> r -> TSignal exp r-- TFst :: (Typeable a, Typeable b)- => TStruct exp (a, b)- -> r -> TSignal exp r-- TSnd :: (Typeable a, Typeable b)- => TStruct exp (a, b)- -> r -> TSignal exp r-- TDelay :: (Typeable a, Typeable exp) => exp a -> r -> TSignal exp r-- -- ^ Buffers- TBuff :: (Typeable a, Typeable exp)- => proxy (exp a)- -> r -> TSignal exp r-- deriving (Typeable)--type Node e = TSignal e Unique------------------------------------------------------------------------------------- ** Helper functions--edges :: TSignal e a -> [a]-edges node =- case node of- TLambda x y -> [x, y]- TVar _ -> []- TConst _ -> []- TLift _ x -> [x]- TMap _ _ _ x -> [x]- TZip _ _ x y -> [x, y]- TFst _ x -> [x]- TSnd _ x -> [x]- TDelay _ x -> [x]------------------------------------------------------------------------------------- ** MuRef instances for signals--instance (Typeable exp) => MuRef (Signal exp a)- where- type DeRef (Signal exp a) = TSignal exp-- mapDeRef f node = case node of- (Const sf) -> pure $ TConst sf- (Lift sf s) -> TLift sf <$> f s- (Map sf s) -> TMap (rep s) (rep (undefined :: Struct exp a)) sf <$> f s- (Zip s u) -> TZip (rep s) (rep u) <$> f s <*> f u- (Fst s) -> TFst (rep s) <$> f s- (Snd s) -> TSnd (rep s) <$> f s- (Delay a s) -> TDelay a <$> f s- (SVar _) -> pure $ TVar (rep (undefined :: Struct exp a))--instance ( Typeable a, Typeable b, Typeable exp- , StructT a, DomainT a ~ exp- ) =>- MuRef (Signal exp a -> Signal exp b)- where- type DeRef (Signal exp a -> Signal exp b) = TSignal exp-- mapDeRef f sf =- let (v, sg) = let a = SVar (toDyn sf) in (a, sf a)- in TLambda <$> f v <*> f sg------------------------------------------------------------------------------------- ** MuRef instances for sig--instance (Typeable exp) => MuRef (Sig exp a)- where- type DeRef (Sig exp a) = TSignal exp-- mapDeRef f node = mapDeRef f (unSig node)--instance (Typeable a, Typeable b, Typeable exp) =>- MuRef (Sig exp a -> Sig exp b)- where- type DeRef (Sig exp a -> Sig exp b) = TSignal exp-- mapDeRef f sf = mapDeRef f (unSig . sf . Sig)------------------------------------------------------------------------------------- * Testing-----------------------------------------------------------------------------------instance Show a => Show (TSignal exp a) where- show node = case node of- (TLambda i b) -> "lam. " ++ show i ++ " " ++ show b- (TVar _) -> "var. "- (TConst _) -> "const. "- (TLift _ s) -> "lift. " ++ show s- (TMap _ _ _ s) -> "map. " ++ show s- (TZip _ _ s u) -> "zip. " ++ show s ++ " " ++ show u- (TFst _ s) -> "fst. " ++ show s- (TSnd _ s) -> "snd. " ++ show s- (TDelay _ s) -> "delay. " ++ show s- (TBuff _ r) -> "dbuff ." ++ show r
− Frontend/Stream.hs
@@ -1,87 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE ConstraintKinds #-}--module Frontend.Stream where--import Core (CMD, newRef, getRef, setRef)--import Control.Applicative-import Control.Monad-import Control.Monad.Operational--import Data.Typeable (Typeable)--import Prelude (($))-import qualified Prelude as P------------------------------------------------------------------------------------- * Streams------------------------------------------------------------------------------------- | ...-data Stream exp a- where- Stream :: Program (CMD exp) (Program (CMD exp) a) -> Stream exp a---- | ...-type Str exp a = Stream exp (exp a)------------------------------------------------------------------------------------- ** Instances--deriving instance Typeable Stream------------------------------------------------------------------------------------- * User Interface---------------------------------------------------------------------------------------------------------------------------------------------------------------------- ** constructors---- | creates a stream from a program-stream :: Program (CMD exp) (Program (CMD exp) (exp a)) -> Str exp a-stream = Stream------------------------------------------------------------------------------------- ** Combinatorial functions---- | creates and infinite stream by repeating @a@-repeat :: exp a -> Str exp a-repeat a = Stream $ return $ return a---- | point-wise transform each value produced with @f@-map :: (exp a -> exp b) -> Str exp a -> Str exp b-map f (Stream init) = Stream $ fmap (fmap f) init---- | joined two streams using @f@ to merge produced elements-zipWith :: (exp a -> exp b -> exp c)- -> Str exp a -> Str exp b -> Str exp c-zipWith f (Stream init1) (Stream init2) = Stream $ do- next1 <- init1- next2 <- init2- return $ do- a <- next1- b <- next2- return $ f a b------------------------------------------------------------------------------------- ** Sequential functions---- | preappend @a@ to input stream-delay :: Typeable a => exp a -> Str exp a -> Str exp a-delay a (Stream init) = Stream $ do- next <- init- r <- newRef a- return $ do- o <- getRef r- v <- next- setRef r v- return o------------------------------------------------------------------------------------- ** Run Functions--run :: Stream exp a -> Program (CMD exp) a-run (Stream init) = join init
− Interpretation.hs
@@ -1,51 +0,0 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE MultiParamTypeClasses #-}--module Interpretation where--import Data.Constraint--import Backend.C.Monad (C)-import Language.C.Syntax (Exp)------------------------------------------------------------------------------------- * Evaluation------------------------------------------------------------------------------------- | General interface for evaluating expressions-class EvalExp exp- where- -- | Predicate for literals- type LitPred exp :: * -> Constraint-- -- | Literal expressions- litExp :: LitPred exp a => a -> exp a-- -- | Evaluation of (closed) expressions- evalExp :: exp a -> a------------------------------------------------------------------------------------ * Compilation------------------------------------------------------------------------------------ | General interface for compiling expressions-class CompExp exp- where- -- | Predicate for variables- type VarPred exp :: * -> Constraint-- -- | Variable expressions- varExp :: VarPred exp a => String -> exp a-- -- | Compilation of expressions- compExp :: exp a -> C Exp------------------------------------------------------------------------------------- **---- | General interface for compiling constructs-class CompCMD cmd- where- -- | Compilation of constructs- compCMD :: cmd a -> C a
signals.cabal view
@@ -1,11 +1,12 @@--- Initial signals.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/- name: signals-version: 0.0.0.1-synopsis: Stream Processing for Embedded Domain Specific Languages--- description: -homepage: https://github.com/markus-git/signals+version: 0.2.0.1+synopsis: Synchronous signal processing for DSLs.+description: A library for expressing digital signal processing algorithms using a deeply+ embedded domain-specific language. The library supports definitions in functional+ programming style, reducing the gap between the mathematical description of+ streaming algorithms and their implementation. The deep embedding makes it possible+ to generate efficient VHDL code without any overhead associated with the+ high-level programming model. license: BSD3 license-file: LICENSE author: Markus Aronsson@@ -16,10 +17,56 @@ -- extra-source-files: cabal-version: >=1.10 +source-repository head+ type: git+ location: git://github.com/markus-git/signals.git+ library- exposed-modules: Core, Interpretation, Frontend.SignalObsv, Frontend.Stream, Frontend.Signal, Examples.Simple.Filters, Examples.Simple.Expr, Backend.Ex, Backend.Knot, Backend.C, Backend.Struct, Backend.Compiler.Sorter, Backend.Compiler.Cycles, Backend.Compiler.Compiler, Backend.Compiler.Linker, Backend.C.Monad+ exposed-modules:+ Signal,+ Signal.Compiler,+ Signal.Compiler.Interface,+ Signal.Compiler.Cycles,+ Signal.Compiler.Sorter,+ Signal.Compiler.Linker,+ Signal.Compiler.Linker.Names,+ Signal.Compiler.Channels,+ Signal.Compiler.Knot,+ Signal.Core,+ Signal.Core.Stream,+ Signal.Core.Witness,+ Signal.Core.Reify+ -- other-modules: - other-extensions: ConstraintKinds, FlexibleContexts, FlexibleInstances, GADTs, MultiParamTypeClasses, DeriveDataTypeable, ScopedTypeVariables, TypeFamilies, UndecidableInstances, StandaloneDeriving, KindSignatures, QuasiQuotes, TypeOperators, OverlappingInstances, AllowAmbiguousTypes, RecursiveDo, Rank2Types, BangPatterns, GeneralizedNewtypeDeriving- build-depends: base >=4.7 && <4.8, operational >=0.2 && <0.3, constraints >=0.4 && <0.5, array >=0.5 && <0.6, language-c-quote >=0.10 && <0.11, data-reify >=0.6 && <0.7, mainland-pretty >=0.2 && <0.3, mtl >=2.1 && <2.2, exception-transformers >=0.3 && <0.4, containers >=0.5 && <0.6, exception-mtl >=0.3 && <0.4- -- hs-source-dirs: - default-language: Haskell2010+ other-extensions:+ GADTs,+ KindSignatures,+ Rank2Types,+ TypeOperators,+ ScopedTypeVariables,+ TypeFamilies,+ FlexibleInstances,+ FlexibleContexts+ + build-depends:+ base >=4.7 && <5,+ constraints >=0.4 && <0.5,+ array >=0.5 && <0.6,+ mtl >=2.2 && <2.3,+ containers >=0.5 && <0.6,+ pretty,+ language-vhdl >= 0.1.1.0,+ operational-alacarte >= 0.1.1,+ imperative-edsl-vhdl >= 0.1.1.3,+ observable-sharing >= 0.2.2.1,+ hashable >= 1.2,+ -- greater versions break + monad-control < 1.0, + exception-transformers >= 0.3.0.4 && < 0.5,+ exception-mtl >= 0.3.0.5 && < 0.5+ + hs-source-dirs:+ .,src+ + default-language:+ Haskell2010
+ src/Signal.hs view
@@ -0,0 +1,9 @@+module Signal+ ( module Signal.Sig+ , module Signal.Str+ , module Signal.Compiler+ ) where++import Signal.Core as Signal.Sig hiding (Symbol, S, U, Wit, Witness)+import Signal.Core.Stream as Signal.Str hiding (map, repeat)+import Signal.Compiler
+ src/Signal/Compiler.hs view
@@ -0,0 +1,321 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Signal.Compiler (compiler, compile) where++import Signal.Core (S(..), Symbol(..), Sig, E(..))+import Signal.Core.Stream+import Signal.Core.Reify+import Signal.Core.Witness++import Signal.Compiler.Interface+import Signal.Compiler.Cycles+import Signal.Compiler.Sorter+import Signal.Compiler.Linker+import Signal.Compiler.Channels++import Control.Arrow (first)+import Control.Monad.Identity (Identity)+import Control.Monad.Reader (ReaderT)+import Control.Monad.State (State)+import Control.Monad.Operational.Higher+import qualified Control.Monad.Identity as CMI+import qualified Control.Monad.Reader as CMR+import qualified Control.Monad.State as CMS++import Data.Either (partitionEithers)+import Data.Maybe (fromJust)+import Data.Typeable+import Data.IntMap (IntMap)+import Data.Ref+import Data.Ref.Map (Name, Map)+import qualified Data.IntMap as IMap+import qualified Data.Ref.Map as RMap++import Language.VHDL (Identifier)+import Language.Embedded.VHDL ( Kind+ , Mode+ , PredicateExp+ , CompileExp+ , SequentialCMD+ , ConcurrentCMD+ , HeaderCMD)+import qualified Language.VHDL as VHDL+import qualified Language.Embedded.VHDL as HDL++import Prelude hiding (read, Left, Right)+import qualified Prelude as P++--------------------------------------------------------------------------------+-- * Compilation+--------------------------------------------------------------------------------++-- | Monad used for compilation+type Gen i = ReaderT (Channels i) (Program i)++read :: forall i a. CompileExp (IExp i) => Ident i a -> E i a+read (Ident i _ _) = dist (witness :: Wit i a) i+ where+ dist :: Wit i x -> Identifiers (S Symbol i x) -> E i x+ dist (WE) (Identified i) = HDL.varE i+ dist (WP l r) (u, v) = (dist l u, dist r v)++write :: forall i a. (SequentialCMD (IExp i) :<: i) => Ident i a -> E i a -> Gen i ()+write (Ident i kind _) = dist (witness :: Wit i a) i+ where+ dist :: Wit i x -> Identifiers (S Symbol i x) -> E i x -> Gen i ()+ dist (WE) (Identified i) exp = CMS.lift $ case kind of+ HDL.Variable -> i HDL.==: exp+ HDL.Signal -> i HDL.<== exp+ dist (WP l r) (u, v) (x, y) = dist l u x >> dist r v y++--------------------------------------------------------------------------------+-- **++comp'+ :: forall i.+ ( Compile (IExp i)+ , CompileExp (IExp i)+ , SequentialCMD (IExp i) :<: i+ , ConcurrentCMD (IExp i) :<: i+ , HeaderCMD (IExp i) :<: i)+ => Ordered i+ -> Gen i ()+comp' (Ordered (Key name)) =+ do env <- CMR.asks (RMap.lookup name)+ case env of+ Nothing -> return ()+ Just (Channel node out) -> case node of+ Repeat c -> do+ declare out Nothing+ write out c+ Map f s -> do+ declare out Nothing+ write out (f $ read s)+ Delay d s -> do+ declare (swap out) (Just d)+ declare (global $ out) (Nothing)+ write (swap out) (read s)+ Mux s cs -> do+ declare out Nothing+ env <- CMR.ask+ let (l, r) = first (fmap literal) $ unzip cs+ choices = fmap (run env . write out . read) r+ CMS.lift $ HDL.switch (read s) (zip l choices) (Nothing)+ Var d -> do+ declare out Nothing+ where+ declare :: forall a. Ident i a -> Maybe (E i a) -> Gen i ()+ declare (Ident i k s) me = dist (witness :: Wit i a) i me+ where+ dist :: Wit i x -> Identifiers (S Symbol i x) -> Maybe (E i x) -> Gen i ()+ dist (WE) (Identified i) me = decl i me+ dist (WP l r) (u, v) me = dist l u (fmap fst me) >> dist r v (fmap snd me)+ + decl :: PredicateExp (IExp i) x => Identifier -> Maybe (IExp i x) -> Gen i ()+ decl ident exp = decl' ident k s exp++ global :: Ident i (Identity a) -> Ident i (Identity a)+ global (Ident is k _) = (Ident is k Global)++ run :: Channels i -> Gen i x -> Program i x+ run = flip CMR.runReaderT++decl' + :: ( PredicateExp (IExp i) a+ , SequentialCMD (IExp i) :<: i+ , ConcurrentCMD (IExp i) :<: i+ , HeaderCMD (IExp i) :<: i)+ => Identifier+ -> Kind+ -> Scope+ -> Maybe (IExp i a)+ -> Gen i ()+decl' ident kind scope exp = CMS.lift $ case kind of+ HDL.Variable -> case scope of+ Header -> void $ HDL.signalPort ident HDL.In exp+ Local -> HDL.variableL ident exp+ HDL.Signal -> case scope of+ Header -> void $ HDL.signalPort ident HDL.Out exp+ Global -> HDL.signalG ident exp++--------------------------------------------------------------------------------++-- | Swap a delay's identifier back from its `opposite` to the original+swap :: Ident i (Identity a) -> Ident i (Identity a)+swap (Ident (Identified i) k s) =+ (Ident (Identified (opposite i)) k s)++--------------------------------------------------------------------------------+-- **++type Order i = [Ordered i]++compile'+ :: forall i a.+ ( Compile (IExp i)+ , CompileExp (IExp i)+ , PredicateExp (IExp i) Bool+ , SequentialCMD (IExp i) :<: i+ , ConcurrentCMD (IExp i) :<: i+ , HeaderCMD (IExp i) :<: i)+ => Key i (Identity a) -- root+ -> Channels i -- nodes+ -> Order i -- ordering+ -> Str i a -- output+compile' out channels order = Stream $ inArchitecture "arch" $+ do let inp@(delays, nodes) = split channels order+ clk <- HDL.clock+ run $ do+ inProcess "combinatorial" (sens inp) $+ do mapM_ comp' nodes+ mapM_ comp' delays+ unless (null delays) $+ inProcess "sequential" [clk] $+ when (rising clk) $+ mapM_ update delays+ exit out+ where+ run :: Gen i x -> Program i (Program i x)+ run = return . flip CMR.runReaderT (markRoot out channels)++ sens :: (Order i, Order i) -> [Identifier]+ sens (delays, nodes) =+ inputs channels nodes ++ concatMap ids delays+ where+ ids :: Ordered i -> [Identifier]+ ids (Ordered (Key name)) = case RMap.lookup name channels of+ Just (Channel (Delay {}) i) -> collect i++ when :: IExp i Bool -> Gen i () -> Gen i ()+ when exp = CMR.mapReaderT (HDL.when exp)++ update :: Ordered i -> Gen i ()+ update (Ordered (Key name)) = do+ (Channel (Delay {}) ident) <- CMR.asks (fromJust . RMap.lookup name)+ write ident (read (swap ident))++ exit :: Key i (Identity a) -> Gen i (IExp i a)+ exit (Key name) = do+ (Channel _ ident) <- CMR.asks (fromJust . RMap.lookup name)+ return $ read ident++ -- *** this is very hacky, as it assumes `IExp i` to be `HDL.Exp`+ rising :: CompileExp (IExp i) => Identifier -> IExp i Bool+ rising (VHDL.Ident i) = HDL.varE $ VHDL.Ident $ "rising_edge(" ++ i ++ ")"++--------------------------------------------------------------------------------++-- *** I don't like how it needs to lookup every ordered name+split :: Channels i -> Order i -> (Order i, Order i)+split c = partitionEithers . fmap sort+ where+ sort :: Ordered i -> Either (Ordered i) (Ordered i)+ sort ord@(Ordered (Key name)) = case RMap.lookup name c of+ Just (Channel (Delay {}) _) -> P.Left ord+ _ -> P.Right ord++inputs :: Channels i -> Order i -> [Identifier]+inputs c = concatMap vars+ where+ vars :: Ordered i -> [Identifier]+ vars ord@(Ordered (Key name)) = case RMap.lookup name c of+ Just (Channel (Var {}) i) -> collect i+ _ -> []++-- *** This could easily be improved by not using lists internally+collect :: forall i a. Ident i a -> [Identifier]+collect (Ident is _ _) = dist (witness :: Wit i a) is+ where+ dist :: Wit i x -> Identifiers (S Symbol i x) -> [Identifier]+ dist (WE) (Identified i) = [i]+ dist (WP l r) (u, v) = dist l u ++ dist r v++-- | Mark a key as root, giving it a signal kind and marking it as a port+markRoot :: Key i a -> Channels i -> Channels i+markRoot (Key name) = RMap.adjust update name+ where+ update :: Channel i a -> Channel i a+ update c = case c of+ Channel node (Ident i _ _) -> Channel node (Ident i HDL.Signal Header)++--------------------------------------------------------------------------------++inProcess :: (ConcurrentCMD (IExp i) :<: i) => String -> [Identifier] -> Gen i () -> Gen i ()+inProcess name = CMR.mapReaderT . HDL.process name++inArchitecture :: (HeaderCMD (IExp i) :<: i) => String -> Program i (Program i a) -> Program i (Program i a)+inArchitecture name = fmap (HDL.architecture name)++--------------------------------------------------------------------------------+-- **++-- | Compile signal functions into stream functions+compiler+ :: ( Compile (IExp i)+ , CompileExp (IExp i)+ , PredicateExp (IExp i) Bool+ , PredicateExp (IExp i) a+ , SequentialCMD (IExp i) :<: i+ , ConcurrentCMD (IExp i) :<: i+ , HeaderCMD (IExp i) :<: i+ , Typeable a+ , Typeable b+ , Typeable i)+ => (Sig i a -> Sig i b) -> IO (Str i a -> Str i b)+compiler f =+ do (root, nodes) <- freify f+ let order = sorter root nodes+ cycle = cycles root nodes+ links = linker order nodes+ return $ case cycle of+ True -> error "signal compiler: found cycle"+ False ->+ let filtered = RMap.filter useful links+ channels = fromLinks filtered+ in const $ compile' root channels order++--------------------------------------------------------------------------------+-- | Compile signals into streams++compile+ :: ( Compile (IExp i)+ , CompileExp (IExp i)+ , PredicateExp (IExp i) Bool+ , PredicateExp (IExp i) a+ , SequentialCMD (IExp i) :<: i+ , ConcurrentCMD (IExp i) :<: i+ , HeaderCMD (IExp i) :<: i+ , Typeable a)+ => Sig i a -> IO (Str i a)+compile f =+ do (root, nodes) <- reify f+ let order = sorter root nodes+ cycle = cycles root nodes+ links = linker order nodes+ return $ case cycle of+ True -> error "signal compiler: found cycle"+ False ->+ let filtered = RMap.filter useful links+ channels = fromLinks filtered+ in compile' root channels order++--------------------------------------------------------------------------------++-- | Usefulness refers to whether we should generate code for the node or not+useful :: Linked i a -> Bool+useful (Linked node _) =+ case node of+ Var {} -> True+ Repeat {} -> True+ Map {} -> True+ Delay {} -> True+ Mux {} -> True+ _ -> False++--------------------------------------------------------------------------------
+ src/Signal/Compiler/Channels.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Signal.Compiler.Channels+ ( Identified(..)+ , Identifiers+ , Kind+ , Scope (..)+ , Ident (..)+ , Channel (..)+ , Channels(..)++ , fromLinks+ , opposite+ )+ where++import Signal.Core (S(..), Symbol)+import Signal.Core.Witness++import Signal.Compiler.Linker++import Control.Arrow (second)+import Control.Monad+import Control.Monad.Identity (Identity)+import Control.Monad.State (State)+import Control.Monad.Reader (Reader)+import qualified Control.Monad.Identity as CMI+import qualified Control.Monad.State as CMS+import qualified Control.Monad.Reader as CMR++import Data.Maybe (fromJust)+import Data.Typeable+import Data.Hashable+import Data.Ref+import Data.Ref.Map (Map, Entry, Name)+import qualified Data.Ref.Map as RMap+import qualified Data.IntMap as IMap++import Language.VHDL (Identifier)+import Language.Embedded.VHDL (Kind)+import qualified Language.VHDL as VHDL+import qualified Language.Embedded.VHDL as HDL++import Prelude hiding (Left, Right)++--------------------------------------------------------------------------------+-- * Compiler constructs+--------------------------------------------------------------------------------+-- I'm fairly certain that a number of these transformations (i.e,+-- keys -> links -> ...) can be done in a signle traversal. They are kept+-- seperate for now since I keep changing the implementation.++-- | Physical name representing a wire+data Identified a where+ Identified :: Identifier -> Identified (S sym i a)++-- | Distributed identifiers+type Identifiers a = Distributed Identified a++--------------------------------------------------------------------------------+-- ** Nodes with Identifiers as keys++-- | Different kinds of scopes available+data Scope = Header | Global | Local++-- | Ident represents a wire with a set of names, kind and scope+data Ident (i :: (* -> *) -> * -> *) (a :: *) where+ Ident :: Witness i a => Identifiers (S Symbol i a) -> Kind -> Scope -> Ident i a++-- | A channel is a linked node where names have been reified as well.+data Channel (i :: (* -> *) -> * -> *) (a :: *) where+ Channel :: S Ident i a -> Ident i a -> Channel i (S Symbol i a)++-- | Short-hand for a mapping over channels+type Channels i = Map (Channel i)++--------------------------------------------------------------------------------+-- ** Channel construction++type Mapping = IMap.IntMap Identifier++type Rm = Reader Mapping++-- *** I make use of an ugly hack: a port variable is really a port input signal+-- This is due `declare` further down not taking a mode as input.+fromLinks :: Links i -> Channels i+fromLinks links = RMap.hmap (translate (fromList links)) links+ where+ translate :: Mapping -> Linked i a -> Channel i a+ translate m (Linked node link) =+ let out@(Ident i k s) = identify link+ in case node of+ Var d -> Channel (Var d) (Ident i k Header)+ Repeat c -> Channel (Repeat c) (out)+ Map f s -> Channel (Map f $ identify s) (out)+ Delay d s -> Channel (Delay d $ identify s) (Ident i HDL.Signal Global)+ Mux s cs -> + let inp = identify s+ inps = fmap (second identify) cs+ in Channel (Mux inp inps) out+ where+ identify :: forall i a. Link i a -> Ident i a+ identify (Link names) = Ident (dist (witness :: Wit i a) names) HDL.Variable Local+ where+ dist :: Wit i x -> Names (S Symbol i x) -> Identifiers (S Symbol i x)+ dist (WE) (Named name) = Identified $ fromJust $ IMap.lookup (hash name) m+ dist (WP l r) (u, v) = (dist l u, dist r v)++--------------------------------------------------------------------------------++-- | Short-hand for state used in `fromList`+type Sm = State (Int, Mapping)++-- | Generates a mapping from name to identifier for each entry+fromList :: Links i -> Mapping+fromList ls = snd $ CMS.execState (mapM_ add $ RMap.elems ls) (0, IMap.empty)+ where+ add :: forall i. Entry (Linked i) -> Sm (){-+ add (RMap.Entry _ (Linked (Delay {}) (Link name :: Link i (Identity a))))+ = next name >>= insert name . opposite-}+ add (RMap.Entry _ (Linked _ (Link names :: Link i a)))+ = dist (witness :: Wit i a) names+ where+ dist :: Wit i x -> Names (S Symbol i x) -> Sm ()+ dist (WE) (name) = next name >>= insert name+ dist (WP l r) (u, v) = dist l u >> dist r v++-- | Generate a unique identifier+next :: Names (S Symbol i (Identity x)) -> Sm Identifier+next (Named name) = do+ (i, m) <- CMS.get+ CMS.put (i + 1, m)+ return $ VHDL.Ident ('v' : show i)++-- | ...+insert :: Names (S Symbol i (Identity x)) -> Identifier -> Sm ()+insert (Named name) i = CMS.modify (second (IMap.insert (hash name) i))++-- | Every delay has an `opposite` which is used in the combinatorial process+opposite :: Identifier -> Identifier+opposite (VHDL.Ident i) = VHDL.Ident $ i ++ "_in"++--------------------------------------------------------------------------------++-- | Usefulness refers to whether we should generate code for the node or not+useful :: RMap.Entry (Linked i) -> Bool+useful (RMap.Entry name (Linked node link)) =+ case node of+ Var {} -> True+ Repeat {} -> True+ Map {} -> True+ Delay {} -> True+ Mux {} -> True+ _ -> False++--------------------------------------------------------------------------------
+ src/Signal/Compiler/Cycles.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Signal.Compiler.Cycles (cycles) where++import Signal.Core+import Signal.Core.Reify++import Control.Monad.State+import Control.Monad.Writer+import Data.Ref+import Data.Ref.Map (Map, Name)+import qualified Data.Ref.Map as M++import Prelude hiding (Left, Right, pred)++import System.Mem.StableName (eqStableName, hashStableName) -- !++--------------------------------------------------------------------------------+-- * +--------------------------------------------------------------------------------++-- | ...+data Hide f where+ Hide :: f a -> Hide f++--------------------------------------------------------------------------------++-- | A node can have three different states during cycle checking+-- * Visited, no cycles detected in node or children+-- * Visiting, node is being checked for cycles+-- * Unvisited, node has not yet been checked for cycles+data Status = Visited | Visiting | Unvisited deriving Eq++data Tagged i a = Tagged Status Predecessor (Node i a)++-- | A node's predecessor+data Predecessor = Predecessor (Hide Name) | None++-- | Cycle-checking monad+type M i = WriterT [Hide (Key i)] (State (Map (Tagged i)))++--------------------------------------------------------------------------------+-- **++untag :: Tagged i a -> Node i a+untag (Tagged _ _ n) = n++(=/=) :: Predecessor -> Predecessor -> Bool+(=/=) (Predecessor (Hide n1)) (Predecessor (Hide n2)) = n1 `eqStableName` n2+(=/=) _ _ = False++-- | Sets the status of a tagged node+is :: Name a -> Status -> M i ()+is r s = modify $ flip M.adjust r $ \(Tagged _ p n) -> Tagged s p n++-- | Sets the predecessor of a tagged node+before :: Name a -> Predecessor -> M i ()+before r p = modify $ flip M.adjust r $ \(Tagged s _ n) -> Tagged s p n++-- | Gets the status of a tagged node+status :: Name a -> M i Status+status r = do+ s <- get+ return $ case M.lookup r s of+ Nothing -> error $ "Sorter.status: lookup failed"+ ++ "\n\t i: " ++ show (hashStableName r)+ Just (Tagged s _ _) -> s++-- | Gets the predecessor of a tagged node+predecessor :: Name a -> M i Predecessor+predecessor r =+ do s <- get+ return $ case M.lookup r s of+ Nothing -> error "Sorter.predecessor: lookup failed"+ Just (Tagged _ p _) -> p++node :: Name (S Symbol i a) -> M i (S Key i a)+node r =+ do s <- get+ return $ case M.lookup r s of+ Nothing -> error "Sorter.node: lookup failed"+ Just (Tagged _ _ (Node n)) -> n++--------------------------------------------------------------------------------+-- *+--------------------------------------------------------------------------------++-- ! Remove unsafe, It's not really needed.+cycle' :: Key i a -> M i Bool+cycle' key@(Key r) =+ do r `is` Visiting+ n <- node r+ b <- case n of+ (Var _) -> return False+ (Repeat _) -> return False+ (Map _ s) -> check s+ (Join l r) -> (&&) <$> check l <*> check r+ (Left l) -> check l+ (Right r) -> check r+ (Delay _ s) -> tell [Hide s] >> return False+ (Mux s c) -> (&&) <$> check s <*> (and <$> mapM (check . snd) c)+ r `is` Visited+ return b+ where+ check :: Key i a -> M i Bool+ check key@(Key r') =+ do let q = Predecessor (Hide r)+ p <- predecessor r'+ s <- status r'+ case s of+ Unvisited -> r' `before` q >> cycle' key+ Visiting | p =/= q -> return False+ _ -> return True+ +--------------------------------------------------------------------------------++-- | Checks if the given signal contains cycles+cycles :: Key i a -> Nodes i -> Bool+cycles key nodes = flip evalState (init nodes) $ go key+ where+ init :: Nodes i -> Map (Tagged i)+ init = M.hmap $ \node -> Tagged Unvisited None node+ + go :: Key i a -> State (Map (Tagged i)) Bool+ go node =+ do (b, w) <- runWriterT $ cycle' node+ (bs) <- mapM add w+ return $ and (b : bs)+ where+ add :: Hide (Key i) -> State (Map (Tagged i)) Bool+ add (Hide key@(Key n)) =+ do s <- get+ case M.lookup n s of+ Nothing -> error "Cycles.cyles.add: lookup failed"+ Just (Tagged _ _ (Node (Delay _ k))) ->+ go k++--------------------------------------------------------------------------------+
+ src/Signal/Compiler/Interface.hs view
@@ -0,0 +1,14 @@+module Signal.Compiler.Interface where++import Language.Embedded.VHDL.Interface++--------------------------------------------------------------------------------+-- *+--------------------------------------------------------------------------------++-- | General interface for compiling+class CompileExp exp => Compile exp+ where+ literal :: PredicateExp exp a => a -> exp a++--------------------------------------------------------------------------------
+ src/Signal/Compiler/Knot.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE RecursiveDo #-}++module Signal.Compiler.Knot (+ Knot+ , Solver+ , tie+ )+where++import Control.Monad.Reader+import Control.Monad.Writer+import Control.Monad.Fix++--------------------------------------------------------------------------------+-- * Knot Monad+--------------------------------------------------------------------------------++-- | Knot monad transformer+type Knot resolution constraint m = ReaderT resolution (WriterT [constraint] m)++-- | Resolve linking constraints+type Solver resolution constraint = [constraint] -> resolution++-- | Tie the knot using @solve@ to resolve any constraints+tie :: MonadFix m => Solver resolution constraint -> Knot resolution constraint m a -> m (a, resolution)+tie solve knot =+ mdo (a, constraints) <- runWriterT $ runReaderT knot solution+ let solution = solve constraints+ return (a, solution)++--------------------------------------------------------------------------------
+ src/Signal/Compiler/Linker.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Signal.Compiler.Linker (+ Link (..)+ , Linked(..)+ , Links + , linker++ -- ^ re-export of naming constructs+ , module Signal.Compiler.Linker.Names+ )+ where++import Signal.Core+import Signal.Core.Reify+import Signal.Core.Witness+import Signal.Compiler.Knot+import Signal.Compiler.Sorter+import Signal.Compiler.Linker.Names+import Control.Monad.Reader+import Control.Monad.Writer+import Control.Monad.State+import Control.Monad.Identity+import Data.Hashable+import Data.Ref+import Data.Ref.Map (Map, Name)+import qualified Data.Ref.Map as M++import Unsafe.Coerce++import Prelude hiding (Left, Right, Ordering)++--------------------------------------------------------------------------------+-- * Linking Types+--------------------------------------------------------------------------------+-- Once we have names for every wire (Names), we can substitute the old+-- group names++-- | Nodes where recursive calls to other nodes have been replaced with names+data Link (i :: (* -> *) -> * -> *) (a :: *) where+ Link :: Witness i a => Names (S Symbol i a) -> Link i a++-- | Container for linked nodes and the names of their own output+data Linked (i :: (* -> *) -> * -> *) (a :: *) where+ Linked :: S Link i a -> Link i a -> Linked i (S Symbol i a)++-- | Short-hand for a mapping over links+type Links i = Map (Linked i)++--------------------------------------------------------------------------------+-- ** We will however need to hide their types as they vary between nodes++-- | A single constructor with a hidden type parameter+data Hide f where+ Hide :: f a -> Hide f++-- | A pair of constructors applied to the same type parameter+data Pair f g a where+ Pair :: f a -> g a -> Pair f g a++-- | Two hidden constructors+type Item i = Hide (Pair Name (Linked i))++--------------------------------------------------------------------------------+-- ** Linking monad++type Resolution i = Links i++type Constraint i = Item i++type M i = Knot (Resolution i) (Constraint i) (State (Nodes i))++--------------------------------------------------------------------------------+-- some helper functions++-- | Find the named node+node :: Name (S Symbol i a) -> M i (Node i (S Symbol i a))+node name = gets (M.! name)++-- | Find the indexed key+resolve :: Key i a -> M i (Link i a)+resolve (Key name) = asks ((\(Linked _ l) -> l) . (M.! name))++-- | Tell a new output item+output :: Item i -> M i ()+output i = tell [i]++--------------------------------------------------------------------------------+-- * Linker+--------------------------------------------------------------------------------++-- | Resolves inputs and constrains the output of each node+link' :: Ordered i -> M i ()+link' (Ordered (Key sym)) =+ do (Node n) <- node sym+ case n of+ (Var d) ->+ do constrain (Var d) (name sym)+ (Repeat c) ->+ do constrain (Repeat c) (name sym)+ (Map f s) ->+ do inp <- resolve s+ constrain (Map f inp) (name sym)+ (Join l r) ->+ do inp_l <- resolve l+ inp_r <- resolve r+ constrain (Join inp_l inp_r) (reify inp_l, reify inp_r)+ (Delay c s) ->+ do inp <- resolve s+ constrain (Delay c inp) (name sym)+ (Mux s choices) ->+ do inp <- resolve s+ inps <- forM choices $ \(c, s) ->+ do s' <- resolve s+ return (c, s')+ constrain (Mux inp inps) (name sym)+ where+ reify ~(Link n) = n+ constrain n l = output $ Hide $ Pair sym $ Linked n $ Link l++--------------------------------------------------------------------------------++-- | Link together ordered nodes, results in a mapping over their connections+linker :: [Ordered i] -> Nodes i -> Links i+linker order nodes = snd . flip evalState nodes . tie solve $ forM_ order link'+ where+ solve :: Solver (Resolution i) (Constraint i)+ solve = foldr ins M.empty++ ins :: Item i -> Links i -> Links i+ ins (Hide (Pair n l)) = M.insert (Data.Ref.Ref n undefined) l++--------------------------------------------------------------------------------
+ src/Signal/Compiler/Linker/Names.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Signal.Compiler.Linker.Names where++import Signal.Core (S)+import Signal.Core.Witness++import Control.Monad.Identity+import Data.Hashable+import Data.Ref.Map (Name)++--------------------------------------------------------------------------------+-- * Distributing+--------------------------------------------------------------------------------++-- | ...+type family Distributed (node :: * -> *) a where+ Distributed node (S sym i (Identity a)) = node (S sym i (Identity a))+ Distributed node (S sym i (a, b)) = ( Distributed node (S sym i a)+ , Distributed node (S sym i b))++-- | ...+data Named a+ where+ Named :: Name (S sym i a) -> Named (S sym i a)+ Lefty :: Named (S sym i (a, b)) -> Named (S sym i a)+ Righty :: Named (S sym i (a, b)) -> Named (S sym i b)++instance Hashable (Named a)+ where+ hashWithSalt s (Named n) = s `hashWithSalt` n+ hashWithSalt s (Lefty l) = s `hashWithSalt` (0 :: Int) `hashWithSalt` l+ hashWithSalt s (Righty r) = s `hashWithSalt` (1 :: Int) `hashWithSalt` r++--------------------------------------------------------------------------------+-- ** Naming wires, i.e distributing one wire's name over its subwires++-- | Shorthand for distributed names+type Names a = Distributed Named a++-- | Takes a composite name and creates unique names for each part+name :: forall sym i a. Witness i a => Name (S sym i a) -> Names (S sym i a)+name n = go (witness :: Wit i a) (Named n)+ where+ go :: Wit i x -> Named (S sym i x) -> Names (S sym i x)+ go (WE) n = n+ go (WP l r) n = (go l (Lefty n), go r (Righty n))++--------------------------------------------------------------------------------
+ src/Signal/Compiler/Sorter.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Signal.Compiler.Sorter (+ Ordered(..)+ , sorter+ )+where++import Signal.Core hiding (lift)+import Signal.Core.Reify+import Signal.Core.Witness+ +import Control.Arrow+import Control.Monad.State+import Data.List (sortBy)+import Data.Function (on)+import Data.Typeable (Typeable)+import Data.Ref+import Data.Ref.Map (Map, Name)+import qualified Data.Ref.Map as M++import System.Mem.StableName (eqStableName)+import Unsafe.Coerce -- !++import Prelude hiding (Left, Right)++--------------------------------------------------------------------------------+-- * Sorting constructs+--------------------------------------------------------------------------------++-- | During the sorting process a node can either be sorted or unvisited +data Status = Visited | Unvisited deriving Eq++-- | The ordering assigned to a node after being sorted+type Order = Int++-- | Nodes tagged with extra bookeeping labels+data Tagged i a where+ Tagged :: Witness i a+ => Status+ -> Order+ -> Name (S Symbol i a)+ -> Node i (S Symbol i a)+ -> Tagged i (S Symbol i a)++--------------------------------------------------------------------------------+-- ** Sorting helpers++-- | Monad used during sorting+type M i = State (Order, Map (Tagged i))++-- | Returns a new and unique ordering+new :: M i Order+new = do+ (i, m) <- get+ put (i + 1, m)+ return i++-- | Updates the order and name-tag of a node+tag :: forall i a. Name (S Symbol i a) -> Order -> M i ()+tag r o = modify $ second $ M.adjust update r+ where+ update :: Tagged i (S Symbol i a) -> Tagged i (S Symbol i a)+ update (Tagged s _ _ n) = Tagged s o r n++-- | Marks a node as visited+visited :: Name (S Symbol i a) -> M i ()+visited r = modify $ second $ M.adjust update r+ where+ update :: Tagged i (S Symbol i a) -> Tagged i (S Symbol i a)+ update (Tagged _ o k n) = Tagged Visited o k n++-- | Gets the status of a node+status :: Name (S Symbol i a) -> M i Status+status r = gets $ (\(Tagged s _ _ _) -> s) . (M.! r) . snd++-- | Gets the node's constructor typ+node :: Name (S Symbol i a) -> M i (S Key i a)+node r = gets $ (\(Tagged _ _ k (Node n)) -> n) . (M.! r) . snd++--------------------------------------------------------------------------------+-- * Sorter+--------------------------------------------------------------------------------++-- | Sorting of individual nodes: mark as visited, follow children, tag with order.+sort' :: Name (S Symbol i a) -> M i ()+sort' r =+ do visited r+ n <- node r+ case n of+ (Var _) -> return ()+ (Repeat _) -> return ()+ (Map _ s) -> visit s+ (Join l r) -> visit l >> visit r+ (Left l) -> visit l+ (Right r) -> visit r+ (Delay _ s) -> visit s+ (Mux s c) -> visit s >> mapM_ (visit . snd) c+ o <- new+ r `tag` o+ where+ visit :: Key i a -> M i ()+ visit (Key k) =+ do s <- status k+ when (s /= Visited) (sort' k)++--------------------------------------------------------------------------------++-- | Ordered keys with a witness constraint for well-formedness+data Ordered i+ where+ Ordered :: Witness i a => Key i a -> Ordered i++-- | Comparing ordered keys is the same as comparing the keys+instance Eq (Ordered i) where+ Ordered (Key l) == Ordered (Key r) = l `eqStableName` r++-- | Given a root and a set of graph nodes, a topological ordering is produced+sorter :: Key i a -> Nodes i -> [Ordered i]+sorter (Key n) nodes = reduce $ snd $ flip execState (1, init nodes) $ sort' n+ where+ init :: Nodes i -> Map (Tagged i)+ init = M.hmap repack+ where+ repack :: forall i a. Node i a -> Tagged i a+ repack node@(Node (keys :: S Key i b)) = Tagged Unvisited 0 undefined node++ reduce :: Map (Tagged i) -> [Ordered i]+ reduce = fmap snd . sortBy (compare `on` fst) . fmap repack . M.elems+ where+ -- Haskell is strange sometimes...+ repack :: forall i. M.Entry (Tagged i) -> (Order, Ordered i)+ repack (M.Entry name (Tagged _ o k (Node _))) = (o, Ordered (Key k))++--------------------------------------------------------------------------------
+ src/Signal/Core.hs view
@@ -0,0 +1,294 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Signal.Core+ ( Sig (..)+ , Signal(..)+ , Symbol(..)+ , S (..)+ , E + , variable++ -- ^ ...+ , delay+ , mux+ , lift+ + -- ^ ...+ , mux2+ , lift0+ , lift1+ , lift2+ ) where++import Signal.Core.Witness++import Control.Monad.Operational.Higher hiding (join)+import Control.Monad.Identity hiding (join)+import Data.Bits+import Data.Typeable (Typeable)+import Data.Dynamic (Dynamic)+import Data.Ref+import Data.Unique++import Language.Embedded.VHDL.Interface++import Prelude hiding (Left, Right, map, repeat)+import qualified Prelude as P++--------------------------------------------------------------------------------+-- * Signals+--------------------------------------------------------------------------------++-- | ...+newtype Sig i a = Sig { runSig :: Signal i (Identity a) }++-- | ...+newtype Signal i a = Signal { runSignal :: Symbol i a }++-- | ...+newtype Symbol i a = Symbol (Ref (S Symbol i a))++-- | ...+data S sig i a+ where+ -- ^ Constant signals+ Repeat :: (Typeable a, PredicateExp (IExp i) a) => IExp i a -> S sig i (Identity a)++ -- ^ Signal transformers+ Map :: (Witness i a, Witness i b) => (E i a -> E i b) -> sig i a -> S sig i b++ -- ^ Wiring operators+ Join :: (Witness i a, Witness i b) => sig i a -> sig i b -> S sig i (a, b)+ Left :: (Witness i a, Witness i b) => sig i (a, b) -> S sig i a+ Right :: (Witness i a, Witness i b) => sig i (a, b) -> S sig i b++ -- ^ Registers+ Delay :: (Typeable a, PredicateExp (IExp i) a)+ => IExp i a+ -> sig i (Identity a)+ -> S sig i (Identity a)++ -- ^ Multiplexers+ Mux :: (Typeable a, PredicateExp (IExp i) a, Witness i b)+ => sig i (Identity a)+ -> [(a, sig i b)]+ -> S sig i b++ -- ^ Variable trick+ Var :: Witness i a => Dynamic -> S sig i a++-- | Type for nested tuples, stripping away all Identity+type family E i a+ where+ E i (Identity a) = IExp i a+ E i (a, b) = (E i a, E i b)++--------------------------------------------------------------------------------+-- ** Some `smart` constructions++signal :: S Symbol i a -> Signal i a+signal = Signal . symbol++symbol :: S Symbol i a -> Symbol i a+symbol = Symbol . ref++unsymbol :: Symbol i a -> S Symbol i a+unsymbol (Symbol s) = deref s++--------------------------------------------------------------------------------+-- internal++repeat :: (Typeable a, PredicateExp (IExp i) a) => IExp i a -> Signal i (Identity a)+repeat s = signal $ Repeat s++map :: (Witness i a, Witness i b) => (E i a -> E i b) -> Signal i a -> Signal i b+map f (Signal s) = signal $ Map f s++join :: (Witness i a, Witness i b) => Signal i a -> Signal i b -> Signal i (a, b)+join (Signal a) (Signal b) = signal $ Join a b++left :: (Witness i a, Witness i b) => Signal i (a, b) -> Signal i a+left (Signal s) = signal $ Left s++right :: (Witness i a, Witness i b) => Signal i (a, b) -> Signal i b+right (Signal s) = signal $ Right s++variable :: Witness i a => Dynamic -> Signal i a+variable = signal . Var ++--------------------------------------------------------------------------------+-- user++-- | Delay a signal by one instant, returning the given value in the first instant+delay :: (Typeable a, PredicateExp (IExp i) a) => IExp i a -> Sig i a -> Sig i a+delay e (Sig (Signal s)) = Sig . signal $ Delay e s++-- | Choose output signal according to a control signal+--+-- ^ List must be total, covering all cases+-- ^ ...+mux :: ( Typeable a, PredicateExp (IExp i) a+ , Typeable b, PredicateExp (IExp i) b)+ => Sig i a+ -> [(a, Sig i b)]+ -> Sig i b+mux (Sig (Signal s)) = Sig . signal . Mux s . fmap (fmap (runSignal . runSig))++--------------------------------------------------------------------------------+-- ** Properties of signals++instance Eq (Sig i a)+ where+ Sig (Signal (Symbol s1)) == Sig (Signal (Symbol s2)) = s1 == s2++instance (Bounded (IExp i a), Typeable a, PredicateExp (IExp i) a) => Bounded (Sig i a)+ where+ minBound = lift0 minBound+ maxBound = lift0 maxBound++instance (Ord (IExp i a), Typeable a, PredicateExp (IExp i) a) => Ord (Sig i a)+ where+ compare = error "compare is not suppored"+ max = lift2 max+ min = lift2 min++instance (Enum (IExp i a), Typeable a, PredicateExp (IExp i) a) => Enum (Sig i a) -- needed for integral+ where+ toEnum = error "toEnum not supported"+ fromEnum = error "fromEnum not supported"++instance (Bits (IExp i a), Typeable a, PredicateExp (IExp i) a) => Bits (Sig i a)+ where+ (.&.) = lift2 (.&.)+ (.|.) = lift2 (.|.)+ xor = lift2 xor+ complement = lift1 complement + shift s n = lift1 (flip shift n) s+ rotate s n = lift1 (flip rotate n) s+ bit = lift0 . bit+ testBit = error "testBit is not supported.. yet"+ bitSize = error "bitSize is not supported.. yet"+ bitSizeMaybe = error "bitSizeMaybe is not supported.. yet"+ isSigned = error "isSigned is not supported.. yet"+ popCount = error "popCound is not supported.. yet"+ +instance (Num (IExp i a), Typeable a, PredicateExp (IExp i) a) => Num (Sig i a)+ where+ (+) = lift2 (+)+ (-) = lift2 (-)+ (*) = lift2 (*)+ negate = lift1 negate+ abs = lift1 abs+ signum = lift1 signum+ fromInteger = lift0 . fromInteger++instance (Fractional (IExp i a), Typeable a, PredicateExp (IExp i) a) => Fractional (Sig i a)+ where+ (/) = lift2 (/)+ recip = lift1 recip+ fromRational = lift0 . fromRational++instance (Real (IExp i a), Typeable a, PredicateExp (IExp i) a) => Real (Sig i a)+ where+ toRational = error "toRational not supported"++instance (Integral (IExp i a), Typeable a, PredicateExp (IExp i) a) => Integral (Sig i a)+ where+ quot = lift2 quot+ rem = lift2 rem+ quotRem = curry $ lift p $ uncurry quotRem+ where p = undefined :: proxy i (Identity a, Identity a) (Identity a, Identity a)+ toInteger = error "toIntegral not supported"++--------------------------------------------------------------------------------+-- * Nested Signals+--------------------------------------------------------------------------------++-- | Type for nested tuples of signals+type family Packed (i :: (* -> *) -> * -> *) a :: *+type instance Packed i (Identity a) = Sig i a+type instance Packed i (a, b) = (Packed i a, Packed i b)++pack :: forall i a. Witness i a => Signal i a -> Packed i a+pack s = go (witness :: Wit i a) s+ where+ go :: Wit i x -> Signal i x -> Packed i x+ go (WE) s = Sig s+ go (WP u v) s = (,) (go u $ left s) (go v $ right s)++unpack :: forall i a. Witness i a => Packed i a -> Signal i a+unpack s = go (witness :: Wit i a) s+ where+ go :: Wit i x -> Packed i x -> Signal i x+ go (WE) (Sig s) = s+ go (WP u v) (l, r) = join (go u l) (go v r)++--------------------------------------------------------------------------------+-- ** General lifting operator++-- todo: I don't like the proxy, or the type family. Possible to find E^(-1)?+-- : can use injective type functions to get rid of proxy.+lift + :: forall proxy i a b. (Witness i a, Witness i b)+ => proxy i a b+ -> (E i a -> E i b)+ -> (Packed i a -> Packed i b)+lift _ f = pack . (map f :: Signal i a -> Signal i b) . unpack++--------------------------------------------------------------------------------+-- * Some common signal operations+--------------------------------------------------------------------------------++--------------------------------------------------------------------------------+-- ** Multiplexing++mux2+ :: ( Typeable a+ , PredicateExp (IExp i) a+ , PredicateExp (IExp i) Bool)+ => Sig i Bool+ -> (Sig i a, Sig i a)+ -> Sig i a+mux2 b (t, f) = mux b [(True, t), (False, f)]++--------------------------------------------------------------------------------+-- ** Lifting++lift0 :: (Typeable a, PredicateExp e a, e ~ IExp i) => e a -> Sig i a+lift0 = Sig . repeat++lift1+ :: forall i e a b.+ ( Typeable a, PredicateExp e a+ , Typeable b, PredicateExp e b+ , e ~ IExp i)+ => (e a -> e b)+ -> Sig i a+ -> Sig i b+lift1 f = lift p f+ where+ p = undefined :: proxy i (Identity a) (Identity b)++lift2+ :: forall i e a b c.+ ( Typeable a, PredicateExp e a+ , Typeable b, PredicateExp e b+ , Typeable c, PredicateExp e c+ , e ~ IExp i)+ => (e a -> e b -> e c)+ -> Sig i a+ -> Sig i b+ -> Sig i c+lift2 f = curry $ lift p $ uncurry f+ where+ p = undefined :: proxy i (Identity a, Identity b) (Identity c)++--------------------------------------------------------------------------------+-- the end.
+ src/Signal/Core/Reify.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Signal.Core.Reify+ ( Key (..)+ , Node(..)+ , Nodes + , reify+ , freify+ ) where++import Signal.Core hiding (lift)+import Signal.Core.Witness++import Control.Monad.Operational.Higher+import Control.Applicative ((<$>))+import Control.Arrow (first, second)+import Control.Monad+import Control.Monad.State+import Data.Functor.Identity+import Data.Typeable (Typeable)+import Data.Dynamic (Dynamic, toDyn)+import Data.Ref+import Data.Ref.Map (Map, Name)+import Language.Embedded.VHDL (PredicateExp)+import System.Mem.StableName++import qualified Signal.Core as S+import qualified Data.Ref.Map as M++import Prelude hiding (Left, Right, join)++--------------------------------------------------------------------------------+-- * Reification of Signals+--------------------------------------------------------------------------------++{--- | Index type for names+type Ix i a = Name (S Symbol i a)+-}+-- | Index keys of a reification mapping+data Key (i :: (* -> *) -> * -> *) (a :: *) where+ Key :: Name (S Symbol i a) -> Key i a++-- | Values of a reification mapping+data Node (i :: (* -> *) -> * -> *) (a :: *) where+ Node :: Witness i a => S Key i a -> Node i (S Symbol i a)++-- | Short-hand for a node mapping+type Nodes i = Map (Node i)++--------------------------------------------------------------------------------+-- ** Reification functions++-- | Reification of a signal into a mapping over its nodes and root key+reify :: Sig i a -> IO (Key i (Identity a), Nodes i)+reify (Sig (Signal sym)) =+ second fst <$> runStateT (reify' sym) (M.empty, M.empty)++-- | Reification of a signal function into a mapping over its nodes, root key and input key+freify+ :: ( PredicateExp (IExp i) a+ , Typeable i+ , Typeable a+ , Typeable b)+ => (Sig i a -> Sig i b)+ -> IO (Key i (Identity b), Nodes i)+freify f =+ do let (_, graph) = let a = Sig (S.variable (toDyn f)) in (a, f a)+ reify graph++--------------------------------------------------------------------------------+-- ** ...++-- | ...+type Reify i = StateT (Nodes i, Map Name) IO++-- | Reification of a symbol tree+reify' :: forall i a. Symbol i a -> Reify i (Key i a)+reify' (Symbol ref@(Ref k node)) =+ do name <- lookupName ref+ case name of+ Just old@(Key k') -> return old+ Nothing -> do+ insertName ref+ case node of+ (S.Var dyn) -> insertNode ref (Node (S.Var dyn))+ (S.Repeat str) -> insertNode ref (Node (S.Repeat str))+ (S.Map f sig) ->+ do key <- reify' sig+ insertNode ref (Node (S.Map f key))+ (S.Join l r) ->+ do lkey <- reify' l+ rkey <- reify' r+ insertNode ref (Node (S.Join lkey rkey))+ (S.Left l) ->+ do lkey <- reify' l+ insertNode ref (Node (S.Left lkey))+ (S.Right r) ->+ do rkey <- reify' r+ insertNode ref (Node (S.Right rkey))+ (S.Delay v sig) ->+ do key <- reify' sig+ insertNode ref (Node (S.Delay v key))+ (S.Mux sig choices) ->+ do key <- reify' sig+ keys <- forM choices $ \(c, s) ->+ do s' <- reify' s+ return (c, s')+ insertNode ref (Node (S.Mux key keys))++--------------------------------------------------------------------------------++-- | Insert a signal node under the given reference name+insertNode :: Ref (S Symbol i a) -> Node i (S Symbol i a) -> Reify i (Key i a)+insertNode ref@(Ref name _) node = modify (first $ M.insert ref node) >> return (Key name)++-- | Insert a reference name+insertName :: Ref (S Symbol i a) -> Reify i ()+insertName ref@(Ref name _) = modify $ second $ M.insert ref name++-- | Tries to find a reference name+lookupName :: Ref (S Symbol i a) -> Reify i (Maybe (Key i a))+lookupName ref@(Ref name _) = do+ node <- gets (M.lookup name . snd)+ return $ case node of+ Nothing -> Nothing+ Just old -> Just (Key old)++--------------------------------------------------------------------------------+-- *+--------------------------------------------------------------------------------++debug :: (Key i (Identity a), Nodes i) -> IO ()+debug ((Key name), nodes) =+ do let entries = M.elems nodes+ putStrLn "========== Debug =========="+ putStrLn $ "Input key: " ++ show (hashStableName name)+ forM_ entries (putStrLn . apa)+ putStrLn "==========================="+ where+ apa :: M.Entry (Node i) -> String+ apa (M.Entry n (Node s)) = "Node (" ++ show (hashStableName n) ++ ") : " ++ print s+ + print :: S sym i a -> String+ print node = case node of+ Repeat {} -> "repeat"+ Map {} -> "map"+ Join {} -> "join"+ Left {} -> "left"+ Right {} -> "right"+ Delay {} -> "delay"+ Mux {} -> "mux"+ Var {} -> "var"
+ src/Signal/Core/Stream.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}++module Signal.Core.Stream where++import Control.Monad.Operational.Higher++import Control.Applicative+import Control.Monad+import Prelude ((.), ($))++--------------------------------------------------------------------------------+-- * Streams+--------------------------------------------------------------------------------++-- | Imperative model of co-iterative streams+data Stream (instr :: (* -> *) -> * -> *) (a :: *)+ where+ Stream :: Program instr (Program instr a) -> Stream instr a+ +-- | `Shorthand` for streams which produce values of type `exp a`+type Str instr a = Stream instr (IExp instr a)++--------------------------------------------------------------------------------+-- **++-- | ...+repeat :: (e ~ IExp instr) => e a -> Str instr a+repeat = Stream . return . return++-- | ...+map :: (e ~ IExp instr) => (e a -> e b) -> Str instr a -> Str instr b+map f (Stream s) = Stream $ fmap (fmap f) s++--------------------------------------------------------------------------------+-- **++-- | Run stream to produce transition action+run :: Stream instr a -> Program instr a+run (Stream init) = join init++--------------------------------------------------------------------------------
+ src/Signal/Core/Witness.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}++module Signal.Core.Witness where++import Control.Monad.Operational.Higher hiding (join)+import Control.Monad.Identity (Identity)+import Data.Typeable (Typeable)+import Language.Embedded.VHDL (PredicateExp)++--------------------------------------------------------------------------------+-- * Witness+--------------------------------------------------------------------------------++-- | A witness for the correct construction (as a nested tuple) of some type+data Wit (i :: (* -> *) -> * -> *) a+ where+ WE :: (Typeable a, PredicateExp (IExp i) a) => Wit i (Identity a)+ + WP :: (Witness i a, Witness i b)+ => Wit i a+ -> Wit i b+ -> Wit i (a, b)++--------------------------------------------------------------------------------+-- ** ...++-- | Class of things for which we can produce a correctness witness+class Typeable a => Witness i a+ where+ witness :: Typeable a => Wit i a++-- | Single value case+instance (Typeable a, PredicateExp (IExp i) a) => Witness i (Identity a)+ where+ witness = WE++-- | Nested tuple case+instance (Witness i a, Witness i b) => Witness i (a, b)+ where+ witness = WP (witness :: Wit i a) (witness :: Wit i b)++--------------------------------------------------------------------------------