diff --git a/Backend/C.hs b/Backend/C.hs new file mode 100644 --- /dev/null +++ b/Backend/C.hs @@ -0,0 +1,275 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE UndecidableInstances #-} + +module Backend.C where + +import Control.Applicative +import Control.Monad.State +import Control.Monad.Exception +import Control.Monad.Operational +import Data.Typeable +import Data.IORef +import Data.Array.IO.Safe +import qualified System.IO as IO +import qualified Text.Printf as Printf + +import Language.C.Quote.C +import qualified Language.C.Syntax as C +import qualified Data.Set as Set + +import Text.PrettyPrint.Mainland + +import Core +import Interpretation + +import Backend.C.Monad +import Examples.Simple.Expr + +-------------------------------------------------------------------------------- +-- * Compilation of Commands +-------------------------------------------------------------------------------- + +compile :: CompCMD cmd => Program cmd a -> C a +compile = interpretWithMonad compCMD + +-------------------------------------------------------------------------------- + +instance CompCMD (CMD Expr) + where + compCMD = compCMD' + +compCMD' :: CMD Expr a -> C a + +-- ^ File handling +compCMD' (Open path) = do + addInclude "" + 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 new file mode 100644 --- /dev/null +++ b/Backend/C/Monad.hs @@ -0,0 +1,178 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Backend.C.Monad where + +import Control.Applicative +import Control.Monad.State +import Control.Monad.Exception +import Control.Monad.Exception.Instances +import Data.List + +import Language.C.Quote.C +import qualified Language.C.Syntax as C +import qualified Data.Set as Set + +import Text.PrettyPrint.Mainland + +data Flags = Flags + +data CEnv = CEnv + { _flags :: Flags + + , _unique :: !Integer + + , _includes :: Set.Set String + , _typedefs :: [C.Definition] + , _prototypes :: [C.Definition] + , _globals :: [C.Definition] + + , _params :: [C.Param] + , _locals :: [C.InitGroup] + , _stms :: [C.Stm] + , _finalStms :: [C.Stm] + + } + +defaultCEnv :: Flags -> CEnv +defaultCEnv flags = CEnv + { _flags = flags + , _unique = 0 + , _includes = Set.empty + , _typedefs = [] + , _prototypes = [] + , _globals = [] + , _params = [] + , _locals = [] + , _stms = [] + , _finalStms = [] + } + +newtype C a = C { unC :: StateT CEnv (ExceptionT IO) a } + deriving (Functor, Applicative, Monad, MonadException, MonadIO, MonadState CEnv) + +runC :: C a -> CEnv -> IO (a, CEnv) +runC m s = runExceptionT (runStateT (unC m) s) >>= liftException + +fastDefEq :: C.Definition -> C.Definition -> Bool +fastDefEq (C.FuncDef (C.OldFunc _ i _ _ _ _ _) _) (C.FuncDef (C.OldFunc _ j _ _ _ _ _) _) = i==j +fastDefEq _ _ = False + +-- | Extract a compilation unit from the 'CEnv' state +cenvToCUnit :: CEnv -> [C.Definition] +cenvToCUnit env = + [cunit|$edecls:includes + $edecls:typedefs + $edecls:prototypes + $edecls:globals|] + where + includes = map toInclude (Set.toList (_includes env)) + where + toInclude :: String -> C.Definition + toInclude inc = [cedecl|$esc:("#include " ++ inc)|] + typedefs = reverse $ _typedefs env + prototypes = reverse $ nubBy fastDefEq $ _prototypes env + globals = reverse $ nubBy fastDefEq $ _globals env + +gensym :: String -> C String +gensym s = do + u <- gets _unique + modify $ \s -> s { _unique = u + 1 } + return $ s ++ show u + +addInclude :: String -> C () +addInclude inc = modify $ \s -> + s { _includes = Set.insert inc (_includes s) } + +addTypedef :: C.Definition -> C () +addTypedef def = modify $ \s -> + s { _typedefs = def : _typedefs s } + +addPrototype :: C.Definition -> C () +addPrototype def = modify $ \s -> + s { _prototypes = def : _prototypes s } + +addGlobal :: C.Definition -> C () +addGlobal def = modify $ \s -> + s { _globals = def : _globals s } + +addParam :: C.Param -> C () +addParam param = modify $ \s -> + s { _params = param : _params s } + +addLocal :: C.InitGroup -> C () +addLocal def = modify $ \s -> + s { _locals = def : _locals s } + +addStm :: C.Stm -> C () +addStm stm = modify $ \s -> + s { _stms = stm : _stms s } + +addFinalStm :: C.Stm -> C () +addFinalStm stm = modify $ \s -> + s { _finalStms = stm : _finalStms s } + +inBlock :: C a -> C a +inBlock act = do + (a, items) <- inNewBlock act + addStm [cstm|{ $items:items }|] + return a + +inNewBlock :: C a -> C (a, [C.BlockItem]) +inNewBlock act = do + oldLocals <- gets _locals + oldStms <- gets _stms + oldFinalStms <- gets _finalStms + modify $ \s -> s { _locals = [], _stms = [], _finalStms = [] } + x <- act + locals <- reverse <$> gets _locals + stms <- reverse <$> gets _stms + finalstms <- reverse <$> gets _finalStms + modify $ \s -> s { _locals = oldLocals + , _stms = oldStms + , _finalStms = oldFinalStms + } + return (x, map C.BlockDecl locals ++ + map C.BlockStm stms ++ + map C.BlockStm finalstms + ) + +inNewBlock_ :: C () -> C [C.BlockItem] +inNewBlock_ act = snd <$> inNewBlock act + +inNewFunction :: C () -> C ([C.Param],[C.BlockItem]) +inNewFunction comp = do + oldParams <- gets _params + modify $ \s -> s { _params = [] } + items <- inNewBlock_ comp + params <- gets _params + modify $ \s -> s { _params = oldParams } + return (reverse params, items) + +inFunction :: String -> C () -> C () +inFunction fun act = do + (params,items) <- inNewFunction act + addPrototype [cedecl| void $id:fun($params:params);|] + addGlobal [cedecl| void $id:fun($params:params){ $items:items }|] + +collectDefinitions :: C a -> C (a, [C.Definition]) +collectDefinitions act = do + oldIncludes <- gets _includes + oldTypedefs <- gets _typedefs + oldPrototypes <- gets _prototypes + oldGlobals <- gets _globals + modify $ \s -> s { _includes = Set.empty + , _typedefs = [] + , _prototypes = [] + , _globals = [] + } + a <- act + s' <- get + modify $ \s -> s { _includes = oldIncludes `Set.union` _includes s' + , _typedefs = oldTypedefs ++ _typedefs s' + , _prototypes = oldPrototypes ++ _prototypes s' + , _globals = oldGlobals ++ _globals s' + } + return (a, cenvToCUnit s') diff --git a/Backend/Compiler/Compiler.hs b/Backend/Compiler/Compiler.hs new file mode 100644 --- /dev/null +++ b/Backend/Compiler/Compiler.hs @@ -0,0 +1,453 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeOperators #-} + +module Backend.Compiler.Compiler ( + compiler + , inspect_compiler + ) +where + +import Core (CMD, EEq(..)) +import qualified Core as C + +import Frontend.Stream (Stream, Str) +import qualified Frontend.Stream as Str + +import Frontend.Signal (Signal, Sig, Struct(..), TStruct(..), Empty) +import qualified Frontend.Signal as S + +import Frontend.SignalObsv (TSignal(..), Node, edges) + +import Backend.Ex +import Backend.Compiler.Cycles +import Backend.Compiler.Linker +import Backend.Compiler.Sorter + +import Control.Monad.Reader +import Control.Monad.State hiding (State) +import Control.Monad.Operational + +import Data.Typeable +import Data.Reify (Unique, Graph(..), reifyGraph) +import Data.Maybe (fromJust) +import Data.List (sortBy, mapAccumR) +import Data.Traversable (traverse) +import Data.Function (on) + +import Data.Map (Map, (!)) +import qualified Data.Map as M + +import Prelude hiding (reads) + +-------------------------------------------------------------------------------- +-- * +-------------------------------------------------------------------------------- + +-- | Shorthand for programs using 'CMD' as their instruction set +type Prog exp = Program (CMD exp) + +-------------------------------------------------------------------------------- + +compiler :: ( Typeable exp, Typeable a, Typeable b + , EEq exp Int, Num (exp Int), Integral (exp Int) + ) + => (Sig exp a -> Sig exp b) + -> IO (Str exp a -> Str exp b) +compiler f = + do (Graph nodes root) <- reifyGraph f + + let links = linker nodes + order = sorter root nodes + cycle = cycles root nodes + + return $ case cycle of + True -> error "found cycle in graph" + False -> compiler' nodes links order False + +-------------------------------------------------------------------------------- +-- * Channels +-------------------------------------------------------------------------------- + +-- | Binary trees over references +data RStruct exp a + where + RLeaf :: Typeable a => C.Ref (exp a) -> RStruct exp (Empty (exp a)) + RPair :: RStruct exp a -> RStruct exp b -> RStruct exp (a, b) + +-- | Untyped binary trees over references +type REx exp = Ex (RStruct exp) + +-- | ... +data Channel symbol exp = C { + _ch_in :: Map symbol (REx exp) + , _ch_out :: Map symbol (REx exp) + } + +-------------------------------------------------------------------------------- +-- hacky solution for now + +-- | +initChannels :: (Ord s, Read s, Typeable e) => Resolution s e -> Prog e (Channel s e) +initChannels res = do + outs <- M.traverseWithKey (const makeChannel) $ _output res + return $ C { + _ch_in = M.map (copyChannel outs) $ _input res + , _ch_out = outs + } + +-- | +makeChannel :: TEx e -> Prog e (REx e) +makeChannel (Ex s) = makes s >>= return . Ex + where + makes :: TStruct e a -> Prog e (RStruct e a) + makes (TLeaf _) = C.initRef >>= return . RLeaf + makes (TPair r l) = do + r' <- makes r + l' <- makes l + return $ RPair r' l' + +-- | +copyChannel :: forall e s. (Ord s, Read s, Typeable e) => Map s (REx e) -> TEx e -> REx e +copyChannel m (Ex s) = Ex $ copys s + where + copys :: TStruct e a -> RStruct e a + copys (TLeaf i) = case m ! read i of (Ex (RLeaf r)) -> case gcast r of Just x -> RLeaf x + copys (TPair l r) = RPair (copys l) (copys r) + +-------------------------------------------------------------------------------- +-- * Compiler +-------------------------------------------------------------------------------- + +-- | ... +data Enviroment symbol exp = Env + { _links :: Resolution symbol exp + , _channels :: Channel symbol exp + , _firsts :: Map symbol (Ex (C.Ref :*: exp)) -- merge with _channels + , _buffers :: Map symbol (Ex (Buffer exp)) + , _inputs :: Ex (Prog exp :*: exp) +--, ... + } + +-- | +type Type exp = ReaderT (Enviroment Unique exp) (Prog exp) + +-------------------------------------------------------------------------------- + +reads :: RStruct exp a -> Prog exp (Struct exp a) +reads (RLeaf r) = C.unsafeGetRef r >>= return . Leaf +reads (RPair l r) = do + l' <- reads l + r' <- reads r + return $ Pair l' r' + +writes :: Struct exp a -> RStruct exp a -> Prog exp () +writes (Leaf s) (RLeaf r) = C.setRef r s +writes (Pair l r) (RPair u v) = writes l u >> writes r v + +-------------------------------------------------------------------------------- + +-- | Read +read_in :: Typeable a => Unique -> TStruct exp a -> Type exp (Struct exp a) +read_in u _ = + do (Ex ch) <- asks ((! u) . _ch_in . _channels) + case gcast ch of + Just s -> lift $ reads s + Nothing -> error "hepa: type error" + +-- | Read +read_out :: Typeable a => Unique -> TStruct exp a -> Type exp (Struct exp a) +read_out u _ = + do (Ex ch) <- asks ((! u) . _ch_out . _channels) + case gcast ch of + Just s -> lift $ reads s + Nothing -> error "bepa: type error" + +-- | Write +write_out :: Typeable a => Unique -> Struct exp a -> Type exp () +write_out u s = + do (Ex ch) <- asks ((! u) . _ch_out . _channels) + case gcast ch of + Just r -> lift $ writes s r + Nothing -> error "depa: type error" + +-------------------------------------------------------------------------------- + +read_buffer :: (Typeable a, Num (exp Int)) => Unique -> Type exp (exp a) +read_buffer u = + do (Ex buff) <- asks ((! u) . _buffers) + case gcast buff of + Just b -> lift $ getBuff b + Nothing -> error "apa: type error" + +write_buffer :: forall exp. Typeable exp => Unique -> Type exp () +write_buffer u = + do (Ex (buff :: Buffer exp a)) <- asks ((! u) . _buffers) + (Leaf e) <- read_out u (undefined :: TStruct exp (Empty (exp a))) + lift $ putBuff buff e + +-------------------------------------------------------------------------------- + +-- | ... +compile :: (Typeable exp, Num (exp Int)) => (Unique, Node exp) -> Type exp () +compile (i, TVar t@(TLeaf _)) = + do input <- asks (apa t . _inputs) + value <- lift $ liftProgram input + write_out i (Leaf value) + where + apa :: Typeable e => TStruct exp (Empty (exp e)) -> Ex (f :*: g) -> f (g e) + apa _ = unwrap + +compile (i, TConst c) = + do value <- lift $ liftProgram $ Str.run c + write_out i (Leaf value) + +compile (i, TLift (f :: Stream exp (exp a) -> Stream exp (exp b)) _) = + do let t = undefined :: TStruct exp (Empty (exp a)) + (Leaf input) <- read_in i t + value <- lift $ liftProgram $ Str.run $ f $ Str.repeat input + write_out i (Leaf value) + +-- I could remove the extra variable (value), todo... +compile (i, TDelay (e :: exp a) _) = + do first <- asks (unwrap . (! i) . _firsts) :: Type exp (C.Ref (exp a)) + output <- lift $ C.unsafeGetRef first + write_out i (Leaf output) +{- + do let t = undefined :: TStruct exp (Empty (exp a)) + (Leaf input) <- read_in i t + first <- asks (unwrap . (! i) . _firsts) :: Type exp (C.Ref (exp a)) + value <- lift $ liftProgram $ + do output <- C.unsafeGetRef first + C.setRef first input + return output + write_out i (Leaf value) +-} +compile (i, TBuff (_ :: proxy (exp a)) u) = + do value <- read_buffer u :: Type exp (exp a) + write_out i (Leaf value) + +compile (i, TMap ti to f _) = + do input <- read_in i ti + value <- return $ f input + write_out i value + +compile _ = return () + +-------------------------------------------------------------------------------- + +-- | ... +compiler' :: forall exp a b. + ( Typeable exp, Typeable a, Typeable b + , EEq exp Int, Num (exp Int), Integral (exp Int) + ) + => [(Unique, Node exp)] + -> Resolution Unique exp + -> Map Unique Order + -> Bool + -> (Stream exp (exp a) -> Stream exp (exp b)) +compiler' nodes links order opt input = Str.stream $ + do (nodes', buffers) <- if opt then opt_delay_chains nodes else return (nodes, M.empty) + env <- init (Str.run input) buffers + return $ + do let t = undefined :: TStruct exp (Empty (exp b)) + delays = [ d | d@(_, TDelay {}) <- nodes] + sorted = sort nodes' + last = final sorted + keys = M.keys buffers + + (Leaf value) <- flip runReaderT env $ + do mapM_ compile sorted + forM_ keys write_buffer + forM_ delays update_delay + read_out last t + + return value + + where + -- Create initial eviroment + init :: Prog exp (exp a) -> Map Unique (Ex (Buffer exp)) -> Prog exp (Enviroment Unique exp) + init i b = + do let delays = M.fromList [ d | d@(_, TDelay {}) <- nodes] + fnodes = map fst $ filterNOP nodes + flinks = Resolution { + _output = M.filterWithKey (\k _ -> k `elem` fnodes) $ _output links + , _input = M.filterWithKey (\k _ -> k `elem` fnodes) $ _input links + } + firsts <- M.traverseWithKey (const $ init_delay) delays + channels <- initChannels flinks + return $ Env { + _links = links + , _channels = channels + , _firsts = firsts + , _buffers = b + , _inputs = wrap i + } + + -- ... + init_delay :: Node exp -> Prog exp (Ex (C.Ref :*: exp)) + init_delay (TDelay d _) = C.newRef d >>= return . wrap + + -- ... + update_delay :: (Unique, Node exp) -> Type exp () + update_delay (i, TDelay (e :: exp x) _) = + do first <- asks (unwrap . (! i) . _firsts) :: Type exp (C.Ref (exp a)) + (Leaf input) <- read_in i (undefined :: TStruct exp (Empty (exp a))) + lift $ liftProgram $ C.setRef first input + + -- Sort graph nodes by the given ordering + sort :: [(Unique, Node exp)] -> [(Unique, Node exp)] + sort = fmap (fmap snd) . sortBy (compare `on` (fst . snd)) + . M.toList . M.intersectionWith (,) order + . M.fromList + + -- Find final reference to read output from + final :: [(Unique, Node exp)] -> Unique + final = fst . last . filterNOP + + -- Filter unused nodes + filterNOP :: [(Unique, Node exp)] -> [(Unique, Node exp)] + filterNOP = filter (not . nop . snd) + where nop (TLambda {}) = True + nop (TZip {}) = True + nop (TFst {}) = True + nop (TSnd {}) = True + nop _ = False + +-------------------------------------------------------------------------------- +-- * Buffers +-------------------------------------------------------------------------------- + +data Buffer exp a = Buffer + { getBuff :: Program (CMD exp) (exp a) + , putBuff :: exp a -> Program (CMD exp) () + } + +newBuff :: forall exp a. (EEq exp Int, Num (exp Int), Integral (exp Int)) + => exp Int -> exp a -> Prog exp (Buffer exp a) +newBuff size init = + do arr <- C.newArr size init + ir <- C.newRef (0 :: exp Int) + + let get = do i <- C.unsafeGetRef ir + C.iff (i ==: 0) + (C.setRef ir size) + (C.setRef ir (i - 1)) + C.getArr i arr + + let put a = do i <- C.unsafeGetRef ir + C.setArr i a arr + C.iff (i ==: size) + (C.setRef ir 0) + (C.setRef ir (i + 1)) + + return $ Buffer get put + +-------------------------------------------------------------------------------- + +-- | For each node in the given list, it finds any chain of delays associated +-- with the node and returns a mapping over each chained node and its chain +find_chains :: [(Unique, Node e)] -> Map Unique [(Unique, Node e)] +find_chains nodes = + let delays = M.foldrWithKey (\k n -> M.insert (head $ edges n) (k, n)) M.empty + $ M.fromList [ d | d@(i, TDelay {}) <- nodes ] + heads = M.foldr (M.delete . fst) delays delays + in M.filter ((>1) . length) $ M.map (flip chain delays) heads + where + chain v@(i, _) m = v : maybe [] (flip chain m) (M.lookup i m) + +-- | +buffer_chains :: forall e. (EEq e Int, Integral (e Int), Num (e Int)) + => Map Unique [(Unique, Node e)] -- original chains + -> Prog e ( Map Unique [(Unique, Node e)] -- updated chains + , Map Unique (Ex (Buffer e)) -- buffers + ) +buffer_chains chains = + do let values = M.map (map val) chains + chains' = M.mapWithKey (map . acc) chains + + -- Since newBuff fills the entire array with the same value, + -- we only use the first value of the delay chains. + -- This should be fixed! + buffers <- traverse (\x@((Ex v):_) -> + do buff <- newBuff (fromIntegral $ length x) v + return (Ex buff) + ) + values + + return (chains', buffers) + where + val (i, TDelay v _) = Ex v + acc k (i, TDelay v _) = (i, TBuff (apa v) k) + where apa :: exp a -> Proxy (exp a) + apa _ = Proxy::Proxy (exp a) + +-- | Replaces all original nodes with the updated chain versions +replace_chains :: [(Unique, Node e)] -> Map Unique [(Unique, Node e)] -> [(Unique, Node e)] +replace_chains nodes = M.toList . M.foldr (flip $ foldr $ uncurry M.insert) (M.fromList nodes) + +-------------------------------------------------------------------------------- + +-- | ... +-- +-- We assume that: +-- * Each delay chains values are of the same type +-- * ... +opt_delay_chains :: (EEq e Int, Num (e Int), Integral (e Int)) + => [(Unique, Node e)] + -> Prog e ( [(Unique, Node e)] + , Map Unique (Ex (Buffer e)) + ) +opt_delay_chains nodes = + do (chains, buffers) <- buffer_chains $ find_chains nodes + return (replace_chains nodes chains, buffers) + +-------------------------------------------------------------------------------- +-- * Testing +-------------------------------------------------------------------------------- + +inspect_compiler :: ( Typeable exp, Typeable a, Typeable b + , EEq exp Int, Num (exp Int), Integral (exp Int) + ) + => (Sig exp a -> Sig exp b) + -> IO (Str exp a -> Str exp b) +inspect_compiler f = + do (Graph nodes root) <- reifyGraph f + + let links = linker nodes + order = sorter root nodes + cycle = cycles root nodes + + putStrLn "==================================================" + putStrLn "= Inspecting Compiler" + putStrLn "==================================================" + putStrLn "- Nodes" + putStrLn "--------------------------------------------------" + putStrLn $ show nodes + putStrLn "--------------------------------------------------" + putStrLn "- Order" + putStrLn "--------------------------------------------------" + putStrLn $ show order + putStrLn "--------------------------------------------------" + putStrLn "- Input Links" + putStrLn "--------------------------------------------------" + putStrLn $ show $ _input links + putStrLn "--------------------------------------------------" + putStrLn "- Output Links" + putStrLn "--------------------------------------------------" + putStrLn $ show $ _output links + putStrLn "--------------------------------------------------" + + return $ \input -> case cycle of + True -> error "found cycle in graph" + False -> compiler' nodes links order True input + +-------------------------------------------------------------------------------- + +m !? i = case M.lookup i m of + Just x -> x + Nothing -> error $ "Can't find key " ++ show i ++ + " in map: \n" ++ show m diff --git a/Backend/Compiler/Cycles.hs b/Backend/Compiler/Cycles.hs new file mode 100644 --- /dev/null +++ b/Backend/Compiler/Cycles.hs @@ -0,0 +1,85 @@ +module Backend.Compiler.Cycles ( + cycles + ) +where + +import Frontend.SignalObsv (TSignal(..), Node, edges) + +import Control.Monad.State +import Data.Reify (Graph(..), Unique, reifyGraph) + +import Data.Map (Map, (!)) +import qualified Data.Map as M + +import Prelude hiding (pred, cycle) + +-------------------------------------------------------------------------------- +-- * Cycles +-------------------------------------------------------------------------------- + +-- | A node can have three different states during cycle checking +-- * Visited, no cycles detected in node or children +-- * Visiting, node is being checked for cycles +-- * Unvisited, node has not yet been checked for cycles +data Status = Visited | Visiting | Unvisited deriving Eq + +-- | A node's predecessor +type Predecessor = Unique + +-------------------------------------------------------------------------------- + +-- | Updates the status for a node +mark :: Unique -> Status -> State (Map Unique (Status, p, n)) () +mark u s = modify $ flip M.adjust u $ \(_, p, n) -> (s, p, n) + +-- | Updates the predecessor for a node +pred :: Unique -> Predecessor -> State (Map Unique (s, Predecessor, n)) () +pred u p = modify $ flip M.adjust u $ \(s, _, n) -> (s, p, n) + +-- | Gets the status of a node +status :: Unique -> State (Map Unique (Status, p, n)) Status +status u = get >>= return . (\(s, _, _) -> s) . (! u) + +-- | Gets the predecessor of a node +predecessor :: Unique -> State (Map Unique (s, Predecessor, n)) Predecessor +predecessor u = get >>= return . (\(_, p, _) -> p) . (! u) + +-- | Gets the adjacent nodes of a node +adjacent :: Unique -> State (Map Unique (s, p, Node e)) [Unique] +adjacent u = get >>= return . (\(_, _, n) -> edges' n) . (! u) + where + -- simply ignore delay edges, this will make the algorithm fail only when + -- bad cycles are detected + edges' (TDelay {}) = [] + edges' x = edges x + +-------------------------------------------------------------------------------- + +-- | ... +cycle :: Unique -> State (Map Unique (Status, Predecessor, Node e)) Bool +cycle u = + do mark u Visiting + ns <- adjacent u + bs <- forM ns $ \n -> + do p <- predecessor n + s <- status n + case s of + Unvisited -> pred n u >> cycle n + Visiting | p /= u -> return False + _ -> return True + mark u Visited + return $ and bs + +-------------------------------------------------------------------------------- + +-- | Checks if there are cycles in the given graph, returns true if there are +cycles :: Unique -> [(Unique, Node e)] -> Bool +cycles root nodes = go root init + where + init = M.fromList $ map (fmap ((,,) Unvisited 0)) nodes + go u s = + let (b, m) = runState (cycle u) s + n = M.filter (\(s, _, _) -> s == Unvisited) m + in case M.null n of + True -> not b + False -> go (fst $ M.findMin n) m diff --git a/Backend/Compiler/Linker.hs b/Backend/Compiler/Linker.hs new file mode 100644 --- /dev/null +++ b/Backend/Compiler/Linker.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Backend.Compiler.Linker ( + Resolution(..) + , TEx + , linker + ) +where + +import Frontend.Stream (Stream) +import Frontend.Signal (TStruct(..), Struct, Empty, tpair, tleft, tright, tleaf) +import Frontend.SignalObsv (TSignal(..), Node) + +import Backend.Knot +import Backend.Ex + +import Control.Monad.Reader +import Control.Monad.Writer +import Control.Monad.Identity + +import Data.Map (Map, (!)) +import qualified Data.Map as M + +import Data.Reify (Unique, Graph(..), reifyGraph) +import Data.Typeable + +-------------------------------------------------------------------------------- +-- * Linking +-------------------------------------------------------------------------------- + +-- | Untyped binary tree over reference names +type TEx exp = Ex (TStruct exp) + +-- | ... I assume each index yeilds a tree with the expected type +data Resolution symbol exp = Resolution + { _output :: Map symbol (TEx exp) + , _input :: Map symbol (TEx exp) + } + +-- | Constraints over symbol to input/output tree +data Constraint symbol exp + = In (symbol, TEx exp) + | Out (symbol, TEx exp) + +-------------------------------------------------------------------------------- + +-- | Attempts to fetch resolved value of index +resolve :: (MonadReader (Resolution i exp) m, Ord i, Typeable a) => i -> TStruct exp a -> m (TStruct exp a) +resolve i _ = + do ex <- asks ((! i) . _output) + return $ case ex of + Ex t -> case gcast t of + Nothing -> error "resolve: type error" + Just o -> o + +-- | Mark tree with index +mark :: String -> TStruct exp a -> TStruct exp a +mark s (TLeaf _) = TLeaf (s) +mark s (TPair l r) = TPair (mark (s ++ "_l") l) (mark (s ++ "_r") r) + +-- | Adds an output constraint +constrain :: (MonadWriter [Constraint i exp] m, Typeable a) => i -> TStruct exp a -> m () +constrain i t = tell [Out (i, Ex t)] + +-- | Adds an input constraint +introduce :: (MonadWriter [Constraint i exp] m, Typeable a) => i -> TStruct exp a -> m () +introduce i t = tell [In (i, Ex t)] + +-------------------------------------------------------------------------------- + +-- | Given a signal node, link creates constraints modeling its relation to others +link :: forall m i exp. (Monad m, Ord i, Show i) + => (i, TSignal exp i) + -> Knot (Resolution i exp) + (Constraint i exp) m + () + +link (i, TLambda l r) = + do return () + +link (i, TVar t) = + do constrain i $ mark (show i) t + +link (i, TConst (c :: Stream exp (exp a))) = + do constrain i (tleaf (show i) :: TStruct exp (Empty (exp a))) + +link (i, TLift (f :: Stream exp (exp a) -> Stream exp (exp b)) s) = + do let t = undefined :: TStruct exp (Empty (exp a)) + t' <- resolve s t + introduce i t' + constrain i (tleaf (show i) :: TStruct exp (Empty (exp b))) + +link (i, TDelay (e :: exp a) s) = + do let t = undefined :: TStruct exp (Empty (exp a)) + t' <- resolve s t + introduce i t' + constrain i (tleaf (show i) :: TStruct exp (Empty (exp a))) + +link (i, TMap ti to f s) = + do t' <- resolve s ti + introduce i t' + constrain i $ mark (show i) to + +link (i, TZip tl tr l r) = + do tl' <- resolve l tl + tr' <- resolve r tr + constrain i $ tpair tl' tr' + +link (i, TFst t l) = + do t' <- resolve l t + constrain i $ tleft t' + +link (i, TSnd t r) = + do t' <- resolve r t + constrain i $ tright t' + +-------------------------------------------------------------------------------- + +-- | ... +linker :: [(Unique, Node exp)] -> Resolution Unique exp +linker = snd . runIdentity . tie solve . sequence . fmap link + +-- | ... +solve :: Solver (Resolution Unique exp) (Constraint Unique exp) +solve constraints = + let inputs = [ i | In i <- constraints] + outputs = [ o | Out o <- constraints] + in Resolution + { _output = M.fromList outputs + , _input = M.fromList inputs + } diff --git a/Backend/Compiler/Sorter.hs b/Backend/Compiler/Sorter.hs new file mode 100644 --- /dev/null +++ b/Backend/Compiler/Sorter.hs @@ -0,0 +1,74 @@ +module Backend.Compiler.Sorter ( + Order + , sorter + ) +where + +import Frontend.SignalObsv (TSignal(..), Node, edges) + +import Control.Arrow +import Control.Monad.State + +import Data.Reify (Graph(..), Unique, reifyGraph) + +import Data.Map (Map, (!)) +import qualified Data.Map as M + +-------------------------------------------------------------------------------- +-- * Sorter +-------------------------------------------------------------------------------- + +-- | During the sorting process a node can either be sorted or unvisited +data Status = Visited | Unvisited + +-- | The ordering assigned to a node after being sorted +type Order = Int + +-------------------------------------------------------------------------------- + +-- | Returns a new and unique ordering +new :: State (Int, m) Order +new = do (i, m) <- get + put (i + 1, m) + return i + +-- | Updates the order of a node +tag :: Unique -> Order -> State (i, Map Unique (s, Order, n)) () +tag u o = modify $ second $ flip M.adjust u $ \(s, _, n) -> (s, o, n) + +-- | Updates the status of a node +mark :: Unique -> Status -> State (i, Map Unique (Status, o, n)) () +mark u s = modify $ second $ flip M.adjust u $ \(_, o, n) -> (s, o, n) + +-- | Gets the status of a node +status :: Unique -> State (i, Map Unique (Status, o, n)) Status +status u = get >>= return . (\(s, _, _) -> s) . (! u) . snd + +-- | Gets the adjacent nodes of an node +adjacent :: Unique -> State (i, Map Unique (s, o, Node e)) [Unique] +adjacent u = get >>= return . edges . (\(_, _, n) -> n) . (! u) . snd + +-------------------------------------------------------------------------------- + +-- | Standard depth-first ordering of a graph +-- +-- I wonder if this would look nicer when using knots intsead.. +sort :: Unique -> State (Int, Map Unique (Status, Order, Node e)) () +sort u = + do mark u Visited + ns <- adjacent u + forM_ ns $ \n -> + do s <- status n + case s of + Visited -> return () + Unvisited -> sort n + o <- new + tag u o + +-------------------------------------------------------------------------------- + +-- | Given a root and a set of graph nodes, a topological ordering is produced +sorter :: Unique -> [(Unique, Node e)] -> Map Unique Order +sorter root nodes = M.map (\(_, o, _) -> o) $ snd $ execState (sort root) init + where + init = (1, M.fromList $ map (fmap ((,,) Unvisited 0)) nodes) diff --git a/Backend/Ex.hs b/Backend/Ex.hs new file mode 100644 --- /dev/null +++ b/Backend/Ex.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} + +---------------------------------------- Testing +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +---------------------------------------- + +module Backend.Ex where + +import Data.Typeable +import Data.Proxy + +---------------------------------------- Testing +import Frontend.Signal (TStruct(..)) +---------------------------------------- + +-------------------------------------------------------------------------------- +-- * Existential types +-------------------------------------------------------------------------------- + +-- | Existential types over containers +data Ex c + where + Ex :: Typeable a => c a -> Ex c + +-- | Wrapper type for nested containers +newtype (f :*: g) e = T (f (g e)) + +-------------------------------------------------------------------------------- +-- ** Instances + +instance Show (Ex c) where show _ = "Ex" + +-------------------------------------------------------------------------------- +-- ** Helper functinons for generalized existential types + +-- | Hides the inner argument, wrapping the types +wrap :: Typeable e => f (g e) -> Ex (f :*: g) +wrap = Ex . T + +-- | Retreives the inner type, uses type casting +unwrap :: Typeable e => Ex (f :*: g) -> f (g e) +unwrap (Ex t) = case gcast t of + Just (T x) -> x + Nothing -> error "unwrap: type error" + +-------------------------------------------------------------------------------- +-- * Testing +-------------------------------------------------------------------------------- + +instance Show (Ex (TStruct e)) + where + show (Ex s) = showTS s + +showTS :: TStruct e a -> String +showTS (TLeaf c) = show c +showTS (TPair l r) = "(" ++ showTS l ++ "," ++ showTS r ++ ")" diff --git a/Backend/Knot.hs b/Backend/Knot.hs new file mode 100644 --- /dev/null +++ b/Backend/Knot.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE RecursiveDo #-} + +module Backend.Knot ( + Knot + , Solver + , tie + ) +where + +import Control.Monad.Reader +import Control.Monad.Writer +import Control.Monad.Fix + +-------------------------------------------------------------------------------- +-- * Knot Monad +-------------------------------------------------------------------------------- + +-- | Knot monad transformer +type Knot resolution constraint m = ReaderT resolution (WriterT [constraint] m) + +-- | Resolve linking constraints +type Solver resolution constraint = [constraint] -> resolution + +-------------------------------------------------------------------------------- + +-- | Tie the knot using @solve@ to resolve any constraints +tie :: MonadFix m => Solver resolution constraint -> Knot resolution constraint m a -> m (a, resolution) +tie solve knot = + mdo (a, constraints) <- runWriterT $ runReaderT knot solution + let solution = solve constraints + return (a, solution) diff --git a/Backend/Struct.hs b/Backend/Struct.hs new file mode 100644 --- /dev/null +++ b/Backend/Struct.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DeriveDataTypeable #-} + +module Backend.Struct where + +import Data.Typeable + +-------------------------------------------------------------------------------- +-- * +-------------------------------------------------------------------------------- + +data Empty a deriving Typeable + +data Struct exp a + where + Leaf :: Typeable a => exp a -> Struct exp (Empty (exp a)) + Node :: Struct exp a + -> Struct exp b + -> Struct exp (a, b) + deriving + Typeable + +-------------------------------------------------------------------------------- +-- ** + diff --git a/Core.hs b/Core.hs new file mode 100644 --- /dev/null +++ b/Core.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Core where + +import Interpretation + +import Control.Monad.Operational +import Data.Constraint +import Data.Dynamic +import Data.Typeable +import Data.IORef +import Data.Array.IO.Safe +import qualified System.IO as IO + +-------------------------------------------------------------------------------- +-- * Commands +-------------------------------------------------------------------------------- + +-- | Imperative commands +data CMD exp a + where + -- ^ File management (IOHandler in Haskell) + Open :: FilePath -> CMD exp Handle + Close :: Handle -> CMD exp () + Put :: Handle -> exp Float -> CMD exp () + Get :: Handle -> CMD exp (exp Float) + Eof :: Handle -> CMD exp (exp Bool) + + -- ^ Mutable references (IORef in Haskell) + InitRef :: Typeable a => CMD exp (Ref (exp a)) + NewRef :: Typeable a => exp a -> CMD exp (Ref (exp a)) + GetRef :: Typeable a => Ref (exp a) -> CMD exp (exp a) + SetRef :: Ref (exp a) -> exp a -> CMD exp () + + -- ^ Mutable arrays (IOArray in Haskell) + NewArr :: Integral n => exp n -> exp a -> CMD exp (Arr (exp a)) + GetArr :: Integral n => exp n -> Arr (exp a) -> CMD exp (exp a) + SetArr :: Integral n => exp n -> exp a -> Arr (exp a) -> CMD exp () + + -- no new var. is assigned. + UnsafeGetRef :: Ref (exp a) -> CMD exp (exp a) + UnsafeGetArr :: Integral n => exp n -> Arr (exp a) -> CMD exp (exp a) + + -- ^ Control structures | Todo: Move to seperate data class + If :: exp Bool + -> Program (CMD exp) () + -> Program (CMD exp) () + -> CMD exp () + While :: Program (CMD exp) (exp Bool) + -> Program (CMD exp) () + -> CMD exp () + Break :: CMD exp () + + -- ^ Misc. + Printf :: Show a => String -> exp a -> CMD exp () + GetTime :: CMD exp (exp Double) + +-- | +data Handle + = HandleComp String + | HandleEval IO.Handle + deriving Typeable + +-- | +data Ref a + = RefComp String + | RefEval (IORef a) + deriving Typeable + +-- | +data Arr a + = ArrComp String + | ArrEval (IOArray Int a) + deriving Typeable + +-------------------------------------------------------------------------------- +-- ** User Interface + +-------------------------------------------------------------------------------- +-- *** File Handling + +open :: FilePath -> ProgramT (CMD exp) m Handle +open = singleton . Open + +close :: Handle -> ProgramT (CMD exp) m () +close = singleton . Close + +fput :: Handle -> exp Float -> ProgramT (CMD exp) m () +fput p = singleton . Put p + +fget :: Handle -> ProgramT (CMD exp) m (exp Float) +fget = singleton . Get + +feof :: Handle -> ProgramT (CMD exp) m (exp Bool) +feof = singleton . Eof + +-------------------------------------------------------------------------------- +-- *** Variables + +initRef :: Typeable a => ProgramT (CMD exp) m (Ref (exp a)) +initRef = singleton InitRef + +newRef :: Typeable a => exp a -> ProgramT (CMD exp) m (Ref (exp a)) +newRef e = singleton (NewRef e) + +getRef :: Typeable a => Ref (exp a) -> ProgramT (CMD exp) m (exp a) +getRef r = singleton (GetRef r) + +setRef :: Ref (exp a) -> exp a -> ProgramT (CMD exp) m () +setRef r = singleton . SetRef r + +-------------------------------------------------------------------------------- +-- *** Arrays + +newArr :: Integral n => exp n -> exp a -> ProgramT (CMD exp) m (Arr (exp a)) +newArr n = singleton . NewArr n + +getArr :: Integral n => exp n -> Arr (exp a) -> ProgramT (CMD exp) m (exp a) +getArr n = singleton . GetArr n + +setArr :: Integral n => exp n -> exp a -> Arr (exp a) -> ProgramT (CMD exp) m () +setArr n a = singleton . SetArr n a + +---------------------------------------- +-- Unsafe + +-- | Like 'getRef' but assumes that the reference will not be modified later +-- in the program +unsafeGetRef :: Ref (exp a) -> ProgramT (CMD exp) m (exp a) +unsafeGetRef = singleton . UnsafeGetRef + -- TODO: It would be possible to make a conservative analysis to find out if + -- uses of `unsafeGetRef` are safe. Even better, the compiler could + -- automatically treat `getRef` as `unsafeGetRef` whenever possible. + +unsafeGetArr :: Integral n => exp n -> Arr (exp a) -> ProgramT (CMD exp) m (exp a) +unsafeGetArr i = singleton . UnsafeGetArr i + +-------------------------------------------------------------------------------- +-- ** + +iff :: exp Bool + -> Program (CMD exp) () + -> Program (CMD exp) () + -> Program (CMD exp) () +iff b t f = singleton $ If b t f + +while :: Program (CMD exp) (exp Bool) + -> Program (CMD exp) () + -> Program (CMD exp) () +while b t = singleton $ While b t + +break :: Program (CMD exp) () +break = singleton Break + +printf :: Show a => String -> exp a -> Program (CMD exp) () +printf format = singleton . Printf format + +getTime :: Program (CMD exp) (exp Double) +getTime = singleton GetTime + +-------------------------------------------------------------------------------- +-- * Constructs +-------------------------------------------------------------------------------- + +-- | +data Construct cmd a + where + Function :: String -> Program cmd () -> Construct cmd () + +-------------------------------------------------------------------------------- +-- ** User Interface + +mkFunction :: String -> Program cmd () -> Program (Construct cmd) () +mkFunction fun body = singleton $ Function fun body + +-------------------------------------------------------------------------------- +-- * +-------------------------------------------------------------------------------- + +class EEq exp a + where + (==:) :: exp a -> exp a -> exp Bool + (/=:) :: exp a -> exp a -> exp Bool diff --git a/Examples/Simple/Expr.hs b/Examples/Simple/Expr.hs new file mode 100644 --- /dev/null +++ b/Examples/Simple/Expr.hs @@ -0,0 +1,263 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Examples.Simple.Expr where + +import Core (EEq(..)) +import Interpretation + +import Backend.C.Monad + +import Language.C.Quote.C +import qualified Language.C.Syntax as C +import Data.Typeable (Typeable) + +-------------------------------------------------------------------------------- +-- * Expressions +-------------------------------------------------------------------------------- + +-- | +data Expr a + where + Val :: Show a => a -> Expr a + Var :: VarId -> Expr a + + -- ^ Math. operations + Add :: Num a => Expr a -> Expr a -> Expr a + Sub :: Num a => Expr a -> Expr a -> Expr a + Mul :: Num a => Expr a -> Expr a -> Expr a + Div :: Fractional a => Expr a -> Expr a -> Expr a + Exp :: Floating a => Expr a -> Expr a -> Expr a + Sin :: Floating a => Expr a -> Expr a + Mod :: Integral a => Expr a -> Expr a -> Expr a + I2N :: (Integral a, Num b) => Expr a -> Expr b + + -- ^ Bool. operations + Not :: Expr Bool -> Expr Bool + And :: Expr Bool -> Expr Bool -> Expr Bool + Or :: Expr Bool -> Expr Bool -> Expr Bool + + Eq :: Eq a => Expr a -> Expr a -> Expr Bool + LEq :: Ord a => Expr a -> Expr a -> Expr Bool + deriving Typeable + +-- | Variable indetifiers +type VarId = String + +-------------------------------------------------------------------------------- +-- ** Instances + +instance (Show a, Eq a) => Eq (Expr a) -- bad + where + a == b = todo + a /= b = todo + +instance (Show a, Ord a) => Ord (Expr a) -- bad + where + a <= b = todo + +instance (Show a, Real a) => Real (Expr a) -- bad + where + toRational = todo + +instance (Show a, Enum a) => Enum (Expr a) -- bad + where + toEnum = todo; fromEnum = todo; + +instance (Show a, Integral a) => Integral (Expr a) + where + mod = Mod + + quotRem = todo; toInteger = todo; + +instance (Show a, Num a, Eq a) => Num (Expr a) + where + fromInteger = Val . fromInteger + Val a + Val b = Val (a+b) + Val 0 + b = b + a + Val 0 = a + a + b = Add a b + Val a - Val b = Val (a-b) + Val 0 - b = b + a - Val 0 = a + a - b = Sub a b + Val a * Val b = Val (a*b) + Val 0 * b = Val 0 + a * Val 0 = Val 0 + Val 1 * b = b + a * Val 1 = a + a * b = Mul a b + + signum = todo; abs = todo; + +instance (Show a, Fractional a, Eq a) => Fractional (Expr a) + where + fromRational = Val . fromRational + Val a / Val b = Val (a/b) + a / b = Div a b + + recip = todo; + +instance (Show a, Floating a, Eq a) => Floating (Expr a) + where + pi = Val pi + sin = Sin + Val a ** Val b = Val (a**b) + a ** b = Exp a b + + exp = todo; sqrt = todo; log = todo; + tan = todo; cos = todo; asin = todo; + atan = todo; acos = todo; sinh = todo; + tanh = todo; cosh = todo; asinh = todo; + atanh = todo; acosh = todo; logBase = todo; + +i2n :: (Integral a, Num b) => Expr a -> Expr b +i2n = I2N + +todo = error "todo in expr" -- I'll add these later + +-------------------------------------------------------------------------------- +-- ** + +instance Eq a => EEq Expr a + where + (==:) = eq + (/=:) = neq + +-------------------------------------------------------------------------------- +-- * +-------------------------------------------------------------------------------- + +tru :: Expr Bool +tru = Val True + +fls :: Expr Bool +fls = Val False + +eq :: Eq a => Expr a -> Expr a -> Expr Bool +eq = Eq + +neq :: Eq a => Expr a -> Expr a -> Expr Bool +neq a b = Not $ a `eq` b + +leq :: Ord a => Expr a -> Expr a -> Expr Bool +leq = LEq + +lt :: Ord a => Expr a -> Expr a -> Expr Bool +lt l r = (LEq l r) `And` (Not $ Eq r l) + +gt :: Ord a => Expr a -> Expr a -> Expr Bool +gt = flip lt + +-------------------------------------------------------------------------------- +-- * Evaluation +-------------------------------------------------------------------------------- + +instance EvalExp Expr + where + type LitPred Expr = Show + + litExp = Val + evalExp = evalExpr' + +-- | +evalExpr' :: Expr a -> a +evalExpr' (Val a) = a +evalExpr' (Var _) = error "cannot eval var" + +-- ^ Math. ops. +evalExpr' (Add a b) = evalExpr' a + evalExpr' b +evalExpr' (Sub a b) = evalExpr' a - evalExpr' b +evalExpr' (Mul a b) = evalExpr' a * evalExpr' b +evalExpr' (Div a b) = evalExpr' a / evalExpr' b +evalExpr' (Mod a b) = evalExpr' a `mod` evalExpr' b +evalExpr' (Sin a) = sin $ evalExpr' a +evalExpr' (I2N a) = fromInteger $ fromIntegral $ evalExpr' a + +-- ^ Bool. ops. +evalExpr' (Not a) = not $ evalExpr' a +evalExpr' (And a b) = evalExpr' a && evalExpr' b +evalExpr' (Or a b) = evalExpr' a || evalExpr' b +evalExpr' (Eq a b) = evalExpr' a == evalExpr' b +evalExpr' (LEq a b) = evalExpr' a <= evalExpr' b + +-------------------------------------------------------------------------------- +-- * Compilation of Expressions +-------------------------------------------------------------------------------- + +class Any a +instance Any a + +instance CompExp Expr + where + type VarPred Expr = Any + varExp = Var + compExp = compExp' + +-- | +compExp' :: Expr a -> C C.Exp +compExp' (Var v) = return [cexp| $id:v |] +compExp' (Val v) = case show v of + "True" -> addInclude "" >> 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 new file mode 100644 --- /dev/null +++ b/Examples/Simple/Filters.hs @@ -0,0 +1,163 @@ +module Examples.Simple.Filters where + +import Prelude hiding (break) + +import Core +import Interpretation + +import Examples.Simple.Expr +import Frontend.Signal (Sig) +import Frontend.Stream (Str, Stream(..)) +import Backend.Compiler.Compiler +import qualified Frontend.Signal as S +import qualified Frontend.Stream as Str +import qualified Backend.C as B + +import Control.Monad +import Control.Monad.Operational (Program) +import Text.PrettyPrint.Mainland +import Data.IORef +import Data.Array.IO.Safe +import qualified System.IO as IO +import qualified Text.Printf as Printf + +-------------------------------------------------------------------------------- +-- * Misc Types +-------------------------------------------------------------------------------- + +type E = Expr + +type S = Sig E + +type P = Program (CMD E) + +-------------------------------------------------------------------------------- + +-- | classical for loop +for :: E Int -> E Int -> (E Int -> P ()) -> P () +for lo hi body = do + ir <- newRef lo + while + (do i <- unsafeGetRef ir; return (leq i hi)) + (do i <- unsafeGetRef ir + a <- body i + setRef ir (i+1) + return a + ) + -- unsafeGetRef is fine because writing to the reference is the last thing + -- that happens in each iteration + +-------------------------------------------------------------------------------- +-- * FIR Filter Example +-------------------------------------------------------------------------------- + +fir :: [E Float] -> S Float -> S Float +fir as = sums . muls as . delays ds + where ds = replicate (length as) 0 + +sums :: [S Float] -> S Float +sums = foldr1 (+) + +muls :: [E Float] -> [S Float] -> [S Float] +muls as = zipWith (*) (map S.repeat as) + +delays :: [E Float] -> S Float -> [S Float] +delays as s = scanl (flip S.delay) s as + +-------------------------------------------------------------------------------- +-- * IIR Filter Examples +-------------------------------------------------------------------------------- + +iir :: [E Float] -> [E Float] -> S Float -> S Float +iir (a:as) bs s = o + where + u = fir bs s + l = fir as $ S.delay 0 o + o = (1 / S.repeat a) * (u - l) + +-------------------------------------------------------------------------------- +-- * FFT Filter Examples +-------------------------------------------------------------------------------- + +-- todo + +-------------------------------------------------------------------------------- +-- * Testing of filters +-------------------------------------------------------------------------------- + +-- for eval you will need to make sure there is an input file, called "input", +-- to read from. Its a standard file of numbers seperated by a space. + +test_fir = comp (fir [1,2,3]) +eval_fir = eval (fir [1,2,3]) + +test_iir = comp (iir [1,2] [3,4]) -- crashes! why?!.. +eval_iir = eval (iir [1,2] [3,4]) + +-------------------------------------------------------------------------------- + +crash = test (fir [1,2,3,4]) + +-------------------------------------------------------------------------------- + +-- | +eval :: (S Float -> S Float) -> IO () +eval = connect_io >=> B.runProgram + +-- | ... +comp :: (S Float -> S Float) -> IO Doc +comp = connect_io >=> B.cgen . mkFunction "main" + +-- | +test :: (S Float -> S Float) -> IO Doc +test = inspect_io >=> B.cgen . mkFunction "test" + +-------------------------------------------------------------------------------- + +connect_io :: (S Float -> S Float) -> IO (P ()) +connect_io s = do + prg <- compiler s + return $ do + inp <- open "input" + outp <- open "output" + + let (Stream init) = prg $ Str.stream $ return $ do + i <- fget inp + isEOF <- feof inp + iff isEOF break (return ()) + -- Apparently EOF can only be detected after one has tried to read past the end + return i + + let setty = fput outp + getty <- init + while (return $ litExp True) + (do v <- getty + setty v) + + close inp + close outp + +-------------------------------------------------------------------------------- + +inspect_io :: (S Float -> S Float) -> IO (P ()) +inspect_io s = do + prg <- inspect_compiler s + return $ do + inp <- open "input" + outp <- open "output" + + let (Stream init) = prg $ Str.stream $ return $ do + i <- fget inp + isEOF <- feof inp + iff isEOF break (return ()) + -- Apparently EOF can only be detected after one has tried to read past the end + return i + + let setty = fput outp + getty <- init + while (return $ litExp True) + (do v <- getty + setty v) + + close inp + close outp diff --git a/Frontend/Signal.hs b/Frontend/Signal.hs new file mode 100644 --- /dev/null +++ b/Frontend/Signal.hs @@ -0,0 +1,319 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Frontend.Signal where + +import Interpretation + +import Frontend.Stream (Stream, Str) +import qualified Frontend.Stream as S + +import Data.Dynamic +import Data.Typeable + +import Prelude ( ($), (.), id + , Num, (+), (-), (*), fromInteger + , Fractional, (/), fromRational + , Floating, (**), pi, sin + , Eq, Show, String) +import qualified Prelude as P + +-------------------------------------------------------------------------------- +-- * +-------------------------------------------------------------------------------- + +-- | ... +data Signal exp a + where + -- ^ lifts consant streams into signals + Const :: Typeable a => Stream exp (exp a) -> Signal exp (Empty (exp a)) + + -- ^ lifts stream transformers into signal transformers, possibly state-full + Lift :: (Typeable a, Typeable b) + => (Stream exp (exp a) -> Stream exp (exp b)) + -> (Signal exp (Empty (exp a)) -> Signal exp (Empty (exp b))) + + -- ^ maps a function over nested tuples to a function over signals + Map :: ( Typeable a, Typeable b + , StructT a, StructT b + , DomainT a ~ exp + , DomainT b ~ DomainT a) + => (Struct exp a -> Struct exp b) -> Signal exp a -> Signal exp b + + -- ^ joins together two nodes + Zip :: ( Typeable a, Typeable b + , StructT a, StructT b + , DomainT a ~ exp + , DomainT b ~ DomainT a) + => Signal exp a -> Signal exp b -> Signal exp (a, b) + + -- ^ breaks apart a signal of pairs, returning the first + Fst :: ( Typeable a, Typeable b + , StructT a, StructT b + , DomainT a ~ exp + , DomainT b ~ DomainT a) + => Signal exp (a, b) -> Signal exp a + + -- ^ breaks apart a signal of pairs, returning the second + Snd :: ( Typeable a, Typeable b + , StructT a, StructT b + , DomainT a ~ exp + , DomainT b ~ DomainT a) + => Signal exp (a, b) -> Signal exp b + + -- ^ prepends a value to the input signal + Delay :: Typeable a + => exp a -> Signal exp (Empty (exp a)) -> Signal exp (Empty (exp a)) + + -- ^ dummy argument used in observable sharing + SVar :: (Typeable a, StructT a, DomainT a ~ exp) + => Dynamic -> Signal exp a + + deriving (Typeable) + +-- | Signals with values ranging over the expression language +newtype Sig exp a = Sig {unSig :: Signal exp (Empty (exp a))} + +-------------------------------------------------------------------------------- +-- ** Instances + +instance (Typeable exp, Typeable a, Num (exp a), Eq (exp a), Show a) => Num (Sig exp a) + where + fromInteger = repeat . fromInteger + (+) = zipWith (+) + (*) = zipWith (*) + (-) = zipWith (-) + + abs = todo; signum = todo; + +instance (Typeable exp, Typeable a, Fractional (exp a), Eq (exp a), Show a) => Fractional (Sig exp a) + where + fromRational = repeat . fromRational + (/) = zipWith (/) + + recip = todo; + +instance (Typeable exp, Typeable a, Floating (exp a), Eq (exp a), Show a) => Floating (Sig exp a) + where + pi = repeat pi + sin = map sin + (**) = zipWith (**) + + exp = todo; sqrt = todo; log = todo; + tan = todo; cos = todo; asin = todo; + atan = todo; acos = todo; sinh = todo; + tanh = todo; cosh = todo; asinh = todo; + atanh = todo; acosh = todo; logBase = todo; + +todo = P.error "unsupported operation" + +-------------------------------------------------------------------------------- +-- ** "Smart" constructors + +constS :: (Typeable a) => Str exp a -> Sig exp a +constS = Sig . Const + +liftS :: (Typeable a, Typeable b) + => (Str exp a -> Str exp b) -> Sig exp a -> Sig exp b +liftS f = Sig . Lift f . unSig + +mapS :: ( Typeable a, Typeable b + , StructT a, StructT b + , DomainT a ~ exp + , DomainT b ~ DomainT a) + => (Struct exp a -> Struct exp b) -> Signal exp a -> Signal exp b +mapS = Map + +-------------------------------------------------------------------------------- +-- ** User Interface + +repeat :: (Typeable a) => exp a -> Sig exp a +repeat = constS . S.repeat + +map :: (Typeable a, Typeable b) => (exp a -> exp b) -> Sig exp a -> Sig exp b +map f = liftS $ S.map f + +delay :: (Typeable a) => exp a -> Sig exp a -> Sig exp a +delay e = Sig . Delay e . unSig + +zipWith :: (Typeable exp, Typeable a, Typeable b, Typeable c) + => (exp a -> exp b -> exp c) + -> Sig exp a -> Sig exp b -> Sig exp c +zipWith f = P.curry $ lift $ P.uncurry f + +-------------------------------------------------------------------------------- +-- * Generalised lifting of Signals +-------------------------------------------------------------------------------- + +-- | 0-tuple value +data Empty a deriving Typeable + +-- | Representation of nested tuples as a binary tree +data Struct exp a + where + Leaf :: Typeable a => exp a -> Struct exp (Empty (exp a)) + Pair :: Struct exp a -> Struct exp b -> Struct exp (a, b) + deriving + Typeable + +-- | Similar to `Struct`, with id's at the leafs +data TStruct exp a + where + TLeaf :: Typeable a => String -> TStruct exp (Empty (exp a)) + TPair :: TStruct exp a -> TStruct exp b -> TStruct exp (a, b) + deriving + Typeable + +-------------------------------------------------------------------------------- + +tpair :: TStruct exp a -> TStruct exp b -> TStruct exp (a, b) +tpair l r = TPair l r + +tleaf :: Typeable a => String -> TStruct exp (Empty (exp a)) +tleaf s = TLeaf s + +tleft :: TStruct exp (a, b) -> TStruct exp a +tleft ~t = case t of (TPair l _) -> l + +tright :: TStruct exp (a, b) -> TStruct exp b +tright ~t = case t of (TPair _ r) -> r + +tid :: TStruct exp (Empty (exp a)) -> String +tid ~t = case t of (TLeaf i) -> i + +-------------------------------------------------------------------------------- +-- ** Conversion between signals and tuples + +-- | ... +class StructS a + where + type Internal a :: * + type Domain a :: * -> * + + fromS :: a -> Signal (Domain a) (Internal a) + toS :: Signal (Domain a) (Internal a) -> a + +instance StructS (Signal exp (Empty (exp a))) + where + type Internal (Signal exp (Empty (exp a))) = Empty (exp a) + type Domain (Signal exp (Empty (exp a))) = exp + + fromS = id + toS = id + +instance StructS (Sig exp a) + where + type Internal (Sig exp a) = Empty (exp a) + type Domain (Sig exp a) = exp + + fromS = unSig + toS = Sig + +instance ( StructS a, StructT (Internal a), Typeable (Internal a) + , StructS b, StructT (Internal b), Typeable (Internal b) + , Domain a ~ Domain b + , DomainT (Internal a) ~ DomainT (Internal b) + , DomainT (Internal a) ~ Domain a + ) => + StructS (a, b) + where + type Internal (a, b) = (Internal a, Internal b) + type Domain (a, b) = Domain a + + fromS (a, b) = Zip (fromS a) (fromS b) + toS p = (toS (Fst p), toS (Snd p)) + +-------------------------------------------------------------------------------- +-- ** Conversion between signals and empty structs (used to remove structs later on) + +class StructT a + where + type DomainT a :: * -> * + + rep :: c (DomainT a) a -> TStruct (DomainT a) a + +instance Typeable a => StructT (Empty (exp a)) + where + type DomainT (Empty (exp a)) = exp + + rep _ = TLeaf "" + +instance ( StructT a, Typeable a + , StructT b, Typeable b + , DomainT a ~ DomainT b) => + StructT (a, b) + where + type DomainT (a, b) = DomainT a + + rep p = TPair (rep $ left p) (rep $ right p) + where + left :: c (DomainT a) (a, b) -> c (DomainT a) a + left = P.undefined + + right :: c (DomainT b) (a, b) -> c (DomainT b) b + right = P.undefined + +-------------------------------------------------------------------------------- +-- ** Conversion between struct's and tuples + +-- | ... +class StructE a + where + type Normal a :: * + type DomainE a :: * -> * + + fromE :: Struct (DomainE a) a -> Normal a + toE :: Normal a -> Struct (DomainE a) a + +instance Typeable a => StructE (Empty (exp a)) + where + type Normal (Empty (exp a)) = exp a + type DomainE (Empty (exp a)) = exp + + fromE (Leaf a) = a + toE a = Leaf a + +instance ( StructE a + , StructE b + , DomainE a ~ DomainE b + ) => + StructE (a, b) + where + type Normal (a, b) = (Normal a, Normal b) + type DomainE (a, b) = DomainE a + + fromE (Pair a b) = (fromE a, fromE b) + toE (a, b) = Pair (toE a) (toE b) + +-------------------------------------------------------------------------------- +-- ** Lifting operator + +-- | ... +lift + :: ( -- ... + StructT (Internal s1) , StructT (Internal s2) + , DomainT (Internal s1) ~ Domain s2 + , DomainT (Internal s2) ~ Domain s2 + + -- we must be able to do the signal \ tuple transformations + , StructS s1 , StructS s2 + , StructE (Internal s1), StructE (Internal s2) + + -- the `exp` type of the signals and tuples should be the same + , Domain s1 ~ Domain s2 + , DomainE (Internal s1) ~ Domain s1 + , DomainE (Internal s2) ~ Domain s2 + + -- requires typeable since we make use of `Zip` to transform signals + , Typeable (Internal s1), Typeable (Internal s2) + ) + => (Normal (Internal s1) -> Normal (Internal s2)) -> s1 -> s2 +lift f = toS . mapS (toE . f . fromE) . fromS diff --git a/Frontend/SignalObsv.hs b/Frontend/SignalObsv.hs new file mode 100644 --- /dev/null +++ b/Frontend/SignalObsv.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Frontend.SignalObsv where + +import Interpretation + +import Frontend.Signal (Signal(..), Sig(..), StructT(..), Empty, Struct, TStruct) +import Frontend.Stream (Stream(..), Str(..)) + +import Control.Applicative hiding (Const) +import Data.Dynamic +import Data.Proxy +import Data.Reify +import Data.Typeable + +-------------------------------------------------------------------------------- +-- * Graph representation of Signals +-------------------------------------------------------------------------------- + +data TSignal exp r + where + -- ^ Signal functions + TLambda :: r -> r -> TSignal exp r + + TVar :: (Typeable a, Typeable exp) + => TStruct exp a + -> TSignal exp r + + -- ^ Signal + TConst :: (Typeable a, Typeable exp) + => Stream exp (exp a) -> TSignal exp r + + TLift :: (Typeable a, Typeable b, Typeable exp) + => (Stream exp (exp a) -> Stream exp (exp b)) + -> r -> TSignal exp r + + TMap :: (Typeable a, Typeable b, Typeable exp) + => TStruct exp a -> TStruct exp b + -> (Struct exp a -> Struct exp b) + -> r -> TSignal exp r + + TZip :: (Typeable a, Typeable b) + => TStruct exp a + -> TStruct exp b + -> r -> r -> TSignal exp r + + TFst :: (Typeable a, Typeable b) + => TStruct exp (a, b) + -> r -> TSignal exp r + + TSnd :: (Typeable a, Typeable b) + => TStruct exp (a, b) + -> r -> TSignal exp r + + TDelay :: (Typeable a, Typeable exp) => exp a -> r -> TSignal exp r + + -- ^ Buffers + TBuff :: (Typeable a, Typeable exp) + => proxy (exp a) + -> r -> TSignal exp r + + deriving (Typeable) + +type Node e = TSignal e Unique + +-------------------------------------------------------------------------------- +-- ** Helper functions + +edges :: TSignal e a -> [a] +edges node = + case node of + TLambda x y -> [x, y] + TVar _ -> [] + TConst _ -> [] + TLift _ x -> [x] + TMap _ _ _ x -> [x] + TZip _ _ x y -> [x, y] + TFst _ x -> [x] + TSnd _ x -> [x] + TDelay _ x -> [x] + +-------------------------------------------------------------------------------- +-- ** MuRef instances for signals + +instance (Typeable exp) => MuRef (Signal exp a) + where + type DeRef (Signal exp a) = TSignal exp + + mapDeRef f node = case node of + (Const sf) -> pure $ TConst sf + (Lift sf s) -> TLift sf <$> f s + (Map sf s) -> TMap (rep s) (rep (undefined :: Struct exp a)) sf <$> f s + (Zip s u) -> TZip (rep s) (rep u) <$> f s <*> f u + (Fst s) -> TFst (rep s) <$> f s + (Snd s) -> TSnd (rep s) <$> f s + (Delay a s) -> TDelay a <$> f s + (SVar _) -> pure $ TVar (rep (undefined :: Struct exp a)) + +instance ( Typeable a, Typeable b, Typeable exp + , StructT a, DomainT a ~ exp + ) => + MuRef (Signal exp a -> Signal exp b) + where + type DeRef (Signal exp a -> Signal exp b) = TSignal exp + + mapDeRef f sf = + let (v, sg) = let a = SVar (toDyn sf) in (a, sf a) + in TLambda <$> f v <*> f sg + +-------------------------------------------------------------------------------- +-- ** MuRef instances for sig + +instance (Typeable exp) => MuRef (Sig exp a) + where + type DeRef (Sig exp a) = TSignal exp + + mapDeRef f node = mapDeRef f (unSig node) + +instance (Typeable a, Typeable b, Typeable exp) => + MuRef (Sig exp a -> Sig exp b) + where + type DeRef (Sig exp a -> Sig exp b) = TSignal exp + + mapDeRef f sf = mapDeRef f (unSig . sf . Sig) + +-------------------------------------------------------------------------------- +-- * Testing +-------------------------------------------------------------------------------- + +instance Show a => Show (TSignal exp a) where + show node = case node of + (TLambda i b) -> "lam. " ++ show i ++ " " ++ show b + (TVar _) -> "var. " + (TConst _) -> "const. " + (TLift _ s) -> "lift. " ++ show s + (TMap _ _ _ s) -> "map. " ++ show s + (TZip _ _ s u) -> "zip. " ++ show s ++ " " ++ show u + (TFst _ s) -> "fst. " ++ show s + (TSnd _ s) -> "snd. " ++ show s + (TDelay _ s) -> "delay. " ++ show s + (TBuff _ r) -> "dbuff ." ++ show r diff --git a/Frontend/Stream.hs b/Frontend/Stream.hs new file mode 100644 --- /dev/null +++ b/Frontend/Stream.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ConstraintKinds #-} + +module Frontend.Stream where + +import Core (CMD, newRef, getRef, setRef) + +import Control.Applicative +import Control.Monad +import Control.Monad.Operational + +import Data.Typeable (Typeable) + +import Prelude (($)) +import qualified Prelude as P + +-------------------------------------------------------------------------------- +-- * Streams +-------------------------------------------------------------------------------- + +-- | ... +data Stream exp a + where + Stream :: Program (CMD exp) (Program (CMD exp) a) -> Stream exp a + +-- | ... +type Str exp a = Stream exp (exp a) + +-------------------------------------------------------------------------------- +-- ** Instances + +deriving instance Typeable Stream + +-------------------------------------------------------------------------------- +-- * User Interface +-------------------------------------------------------------------------------- + +-------------------------------------------------------------------------------- +-- ** constructors + +-- | creates a stream from a program +stream :: Program (CMD exp) (Program (CMD exp) (exp a)) -> Str exp a +stream = Stream + +-------------------------------------------------------------------------------- +-- ** Combinatorial functions + +-- | creates and infinite stream by repeating @a@ +repeat :: exp a -> Str exp a +repeat a = Stream $ return $ return a + +-- | point-wise transform each value produced with @f@ +map :: (exp a -> exp b) -> Str exp a -> Str exp b +map f (Stream init) = Stream $ fmap (fmap f) init + +-- | joined two streams using @f@ to merge produced elements +zipWith :: (exp a -> exp b -> exp c) + -> Str exp a -> Str exp b -> Str exp c +zipWith f (Stream init1) (Stream init2) = Stream $ do + next1 <- init1 + next2 <- init2 + return $ do + a <- next1 + b <- next2 + return $ f a b + +-------------------------------------------------------------------------------- +-- ** Sequential functions + +-- | preappend @a@ to input stream +delay :: Typeable a => exp a -> Str exp a -> Str exp a +delay a (Stream init) = Stream $ do + next <- init + r <- newRef a + return $ do + o <- getRef r + v <- next + setRef r v + return o + +-------------------------------------------------------------------------------- +-- ** Run Functions + +run :: Stream exp a -> Program (CMD exp) a +run (Stream init) = join init diff --git a/Interpretation.hs b/Interpretation.hs new file mode 100644 --- /dev/null +++ b/Interpretation.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Interpretation where + +import Data.Constraint + +import Backend.C.Monad (C) +import Language.C.Syntax (Exp) + +-------------------------------------------------------------------------------- +-- * Evaluation +-------------------------------------------------------------------------------- + +-- | General interface for evaluating expressions +class EvalExp exp + where + -- | Predicate for literals + type LitPred exp :: * -> Constraint + + -- | Literal expressions + litExp :: LitPred exp a => a -> exp a + + -- | Evaluation of (closed) expressions + evalExp :: exp a -> a + +------------------------------------------------------------------------------- +-- * Compilation +------------------------------------------------------------------------------- + +-- | General interface for compiling expressions +class CompExp exp + where + -- | Predicate for variables + type VarPred exp :: * -> Constraint + + -- | Variable expressions + varExp :: VarPred exp a => String -> exp a + + -- | Compilation of expressions + compExp :: exp a -> C Exp + +-------------------------------------------------------------------------------- +-- ** + +-- | General interface for compiling constructs +class CompCMD cmd + where + -- | Compilation of constructs + compCMD :: cmd a -> C a diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2015, Markus Aronsson + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Markus Aronsson nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/signals.cabal b/signals.cabal new file mode 100644 --- /dev/null +++ b/signals.cabal @@ -0,0 +1,25 @@ +-- Initial signals.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: signals +version: 0.0.0.1 +synopsis: Stream Processing for Embedded Domain Specific Languages +-- description: +homepage: https://github.com/markus-git/signals +license: BSD3 +license-file: LICENSE +author: Markus Aronsson +maintainer: mararon@chalmers.se +-- copyright: +category: Language +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +library + exposed-modules: Core, Interpretation, Frontend.SignalObsv, Frontend.Stream, Frontend.Signal, Examples.Simple.Filters, Examples.Simple.Expr, Backend.Ex, Backend.Knot, Backend.C, Backend.Struct, Backend.Compiler.Sorter, Backend.Compiler.Cycles, Backend.Compiler.Compiler, Backend.Compiler.Linker, Backend.C.Monad + -- other-modules: + other-extensions: ConstraintKinds, FlexibleContexts, FlexibleInstances, GADTs, MultiParamTypeClasses, DeriveDataTypeable, ScopedTypeVariables, TypeFamilies, UndecidableInstances, StandaloneDeriving, KindSignatures, QuasiQuotes, TypeOperators, OverlappingInstances, AllowAmbiguousTypes, RecursiveDo, Rank2Types, BangPatterns, GeneralizedNewtypeDeriving + build-depends: base >=4.7 && <4.8, operational >=0.2 && <0.3, constraints >=0.4 && <0.5, array >=0.5 && <0.6, language-c-quote >=0.10 && <0.11, data-reify >=0.6 && <0.7, mainland-pretty >=0.2 && <0.3, mtl >=2.1 && <2.2, exception-transformers >=0.3 && <0.4, containers >=0.5 && <0.6, exception-mtl >=0.3 && <0.4 + -- hs-source-dirs: + default-language: Haskell2010