diff --git a/Backend/C.hs b/Backend/C.hs deleted file mode 100644 --- a/Backend/C.hs +++ /dev/null @@ -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 "" - addInclude "" - 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 "" - 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 "" - 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 "" - addInclude "" - 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 "" - 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) diff --git a/Backend/C/Monad.hs b/Backend/C/Monad.hs deleted file mode 100644 --- a/Backend/C/Monad.hs +++ /dev/null @@ -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') diff --git a/Backend/Compiler/Compiler.hs b/Backend/Compiler/Compiler.hs deleted file mode 100644 --- a/Backend/Compiler/Compiler.hs +++ /dev/null @@ -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 diff --git a/Backend/Compiler/Cycles.hs b/Backend/Compiler/Cycles.hs deleted file mode 100644 --- a/Backend/Compiler/Cycles.hs +++ /dev/null @@ -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 diff --git a/Backend/Compiler/Linker.hs b/Backend/Compiler/Linker.hs deleted file mode 100644 --- a/Backend/Compiler/Linker.hs +++ /dev/null @@ -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 - } diff --git a/Backend/Compiler/Sorter.hs b/Backend/Compiler/Sorter.hs deleted file mode 100644 --- a/Backend/Compiler/Sorter.hs +++ /dev/null @@ -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) diff --git a/Backend/Ex.hs b/Backend/Ex.hs deleted file mode 100644 --- a/Backend/Ex.hs +++ /dev/null @@ -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 ++ ")" diff --git a/Backend/Knot.hs b/Backend/Knot.hs deleted file mode 100644 --- a/Backend/Knot.hs +++ /dev/null @@ -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) diff --git a/Backend/Struct.hs b/Backend/Struct.hs deleted file mode 100644 --- a/Backend/Struct.hs +++ /dev/null @@ -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 - --------------------------------------------------------------------------------- --- ** - diff --git a/Core.hs b/Core.hs deleted file mode 100644 --- a/Core.hs +++ /dev/null @@ -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 diff --git a/Examples/Simple/Expr.hs b/Examples/Simple/Expr.hs deleted file mode 100644 --- a/Examples/Simple/Expr.hs +++ /dev/null @@ -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 "" >> return [cexp| true |] - "False" -> addInclude "" >> 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' |] - - diff --git a/Examples/Simple/Filters.hs b/Examples/Simple/Filters.hs deleted file mode 100644 --- a/Examples/Simple/Filters.hs +++ /dev/null @@ -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 diff --git a/Frontend/Signal.hs b/Frontend/Signal.hs deleted file mode 100644 --- a/Frontend/Signal.hs +++ /dev/null @@ -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 diff --git a/Frontend/SignalObsv.hs b/Frontend/SignalObsv.hs deleted file mode 100644 --- a/Frontend/SignalObsv.hs +++ /dev/null @@ -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 diff --git a/Frontend/Stream.hs b/Frontend/Stream.hs deleted file mode 100644 --- a/Frontend/Stream.hs +++ /dev/null @@ -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 diff --git a/Interpretation.hs b/Interpretation.hs deleted file mode 100644 --- a/Interpretation.hs +++ /dev/null @@ -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 diff --git a/signals.cabal b/signals.cabal --- a/signals.cabal +++ b/signals.cabal @@ -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 diff --git a/src/Signal.hs b/src/Signal.hs new file mode 100644 --- /dev/null +++ b/src/Signal.hs @@ -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 diff --git a/src/Signal/Compiler.hs b/src/Signal/Compiler.hs new file mode 100644 --- /dev/null +++ b/src/Signal/Compiler.hs @@ -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 + +-------------------------------------------------------------------------------- diff --git a/src/Signal/Compiler/Channels.hs b/src/Signal/Compiler/Channels.hs new file mode 100644 --- /dev/null +++ b/src/Signal/Compiler/Channels.hs @@ -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 + +-------------------------------------------------------------------------------- diff --git a/src/Signal/Compiler/Cycles.hs b/src/Signal/Compiler/Cycles.hs new file mode 100644 --- /dev/null +++ b/src/Signal/Compiler/Cycles.hs @@ -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 + +-------------------------------------------------------------------------------- + diff --git a/src/Signal/Compiler/Interface.hs b/src/Signal/Compiler/Interface.hs new file mode 100644 --- /dev/null +++ b/src/Signal/Compiler/Interface.hs @@ -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 + +-------------------------------------------------------------------------------- diff --git a/src/Signal/Compiler/Knot.hs b/src/Signal/Compiler/Knot.hs new file mode 100644 --- /dev/null +++ b/src/Signal/Compiler/Knot.hs @@ -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) + +-------------------------------------------------------------------------------- diff --git a/src/Signal/Compiler/Linker.hs b/src/Signal/Compiler/Linker.hs new file mode 100644 --- /dev/null +++ b/src/Signal/Compiler/Linker.hs @@ -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 + +-------------------------------------------------------------------------------- diff --git a/src/Signal/Compiler/Linker/Names.hs b/src/Signal/Compiler/Linker/Names.hs new file mode 100644 --- /dev/null +++ b/src/Signal/Compiler/Linker/Names.hs @@ -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)) + +-------------------------------------------------------------------------------- diff --git a/src/Signal/Compiler/Sorter.hs b/src/Signal/Compiler/Sorter.hs new file mode 100644 --- /dev/null +++ b/src/Signal/Compiler/Sorter.hs @@ -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)) + +-------------------------------------------------------------------------------- diff --git a/src/Signal/Core.hs b/src/Signal/Core.hs new file mode 100644 --- /dev/null +++ b/src/Signal/Core.hs @@ -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. diff --git a/src/Signal/Core/Reify.hs b/src/Signal/Core/Reify.hs new file mode 100644 --- /dev/null +++ b/src/Signal/Core/Reify.hs @@ -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" diff --git a/src/Signal/Core/Stream.hs b/src/Signal/Core/Stream.hs new file mode 100644 --- /dev/null +++ b/src/Signal/Core/Stream.hs @@ -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 + +-------------------------------------------------------------------------------- diff --git a/src/Signal/Core/Witness.hs b/src/Signal/Core/Witness.hs new file mode 100644 --- /dev/null +++ b/src/Signal/Core/Witness.hs @@ -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) + +--------------------------------------------------------------------------------