signals (empty) → 0.0.0.1
raw patch · 19 files changed
+2594/−0 lines, 19 filesdep +arraydep +basedep +constraintssetup-changed
Dependencies added: array, base, constraints, containers, data-reify, exception-mtl, exception-transformers, language-c-quote, mainland-pretty, mtl, operational
Files
- Backend/C.hs +275/−0
- Backend/C/Monad.hs +178/−0
- Backend/Compiler/Compiler.hs +453/−0
- Backend/Compiler/Cycles.hs +85/−0
- Backend/Compiler/Linker.hs +133/−0
- Backend/Compiler/Sorter.hs +74/−0
- Backend/Ex.hs +62/−0
- Backend/Knot.hs +31/−0
- Backend/Struct.hs +25/−0
- Core.hs +189/−0
- Examples/Simple/Expr.hs +263/−0
- Examples/Simple/Filters.hs +163/−0
- Frontend/Signal.hs +319/−0
- Frontend/SignalObsv.hs +149/−0
- Frontend/Stream.hs +87/−0
- Interpretation.hs +51/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- signals.cabal +25/−0
+ Backend/C.hs view
@@ -0,0 +1,275 @@+{-# 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 view
@@ -0,0 +1,178 @@+{-# 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 view
@@ -0,0 +1,453 @@+{-# 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 view
@@ -0,0 +1,85 @@+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 view
@@ -0,0 +1,133 @@+{-# 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 view
@@ -0,0 +1,74 @@+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 view
@@ -0,0 +1,62 @@+{-# 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 view
@@ -0,0 +1,31 @@+{-# 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 view
@@ -0,0 +1,25 @@+{-# 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 view
@@ -0,0 +1,189 @@+{-# 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 view
@@ -0,0 +1,263 @@+{-# 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 view
@@ -0,0 +1,163 @@+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 view
@@ -0,0 +1,319 @@+{-# 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 view
@@ -0,0 +1,149 @@+{-# 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 view
@@ -0,0 +1,87 @@+{-# 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 view
@@ -0,0 +1,51 @@+{-# 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
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Markus Aronsson++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Markus Aronsson nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ signals.cabal view
@@ -0,0 +1,25 @@+-- 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+license: BSD3+license-file: LICENSE+author: Markus Aronsson+maintainer: mararon@chalmers.se+-- copyright: +category: Language+build-type: Simple+-- extra-source-files: +cabal-version: >=1.10++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+ -- 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