hardware-edsl 0.1.5 → 0.1.6
raw patch · 13 files changed
+1621/−1394 lines, 13 filesdep ~containersdep ~language-vhdldep ~operational-alacarte
Dependency ranges changed: containers, language-vhdl, operational-alacarte, pretty, syntactic
Files
- hardware-edsl.cabal +11/−11
- src/Language/Embedded/Hardware/Command.hs +57/−55
- src/Language/Embedded/Hardware/Command/Backend/VHDL.hs +419/−271
- src/Language/Embedded/Hardware/Command/CMD.hs +192/−159
- src/Language/Embedded/Hardware/Command/Frontend.hs +220/−176
- src/Language/Embedded/Hardware/Expression.hs +5/−0
- src/Language/Embedded/Hardware/Expression/Frontend.hs +20/−1
- src/Language/Embedded/Hardware/Expression/Represent.hs +44/−16
- src/Language/Embedded/Hardware/Expression/Represent/Bit.hs +1/−1
- src/Language/Embedded/Hardware/Interface/AXI.hs +289/−256
- src/Language/Embedded/VHDL/Monad.hs +280/−438
- src/Language/Embedded/VHDL/Monad/Type.hs +22/−4
- src/Language/Embedded/VHDL/Monad/Util.hs +61/−6
hardware-edsl.cabal view
@@ -1,5 +1,5 @@ name: hardware-edsl-version: 0.1.5+version: 0.1.6 synopsis: Deep embedding of hardware descriptions with code generation. description: Deep embedding of hardware descriptions with code generation. license: BSD3@@ -58,17 +58,17 @@ UndecidableInstances build-depends:- base >=4.8 && <5,- mtl >=2.2 && <2.3,- array >=0.5 && <0.6,- containers >=0.5 && <0.6,- pretty >=1.1 && <1.2,- bytestring >=0.10 && <0.11,- deepseq >=1.4,+ base >=4.8 && <5,+ mtl >=2.2 && <2.3,+ array >=0.5 && <0.6,+ containers >=0.5.10,+ pretty >=1.1 && <2,+ bytestring >=0.10 && <0.11,+ deepseq >=1.4, constraints >=0.6,- syntactic >=3.6.1,- operational-alacarte >=0.2,- language-vhdl >=0.1.3+ syntactic >=3.8,+ operational-alacarte >=0.3,+ language-vhdl >=0.1.4 hs-source-dirs: src
src/Language/Embedded/Hardware/Command.hs view
@@ -12,14 +12,15 @@ compile , icompile , runIO+ -- hardware compilers without process wrapping.+ , compileSig+ , icompileSig -- AXI compilers. , compileAXILite , icompileAXILite- -- compilers that wraps a program in a dummy entity.- , compileWrap- , icompileWrap- + -- , VHDL.Mode(..)+ -- , module CMD , module Language.Embedded.Hardware.Command.CMD , module Language.Embedded.Hardware.Command.Frontend@@ -50,19 +51,30 @@ -- | Compile a program to VHDL code represented as a string. compile :: forall instr (exp :: * -> *) (pred :: * -> GHC.Constraint) a.- ( Interp instr VHDL (Param2 exp pred)+ ( Interp instr VHDLGen (Param2 exp pred) , HFunctor instr+ , ProcessCMD :<: instr+ , VHDLCMD :<: instr+ , pred Bool )- => Program instr (Param2 exp pred) a+ => Program instr (Param2 exp pred) () -> String-compile = show . prettyVHDL . interpret+compile = show+ . VHDL.prettyVHDL+ . VHDL.wrapMain+ . flip runVHDLGen emptyEnv+ . interpret+ . process [] -- | Compile a program to VHDL code and print it on the screen. icompile :: forall instr (exp :: * -> *) (pred :: * -> GHC.Constraint) a.- ( Interp instr VHDL (Param2 exp pred)+ ( Interp instr VHDLGen (Param2 exp pred) , HFunctor instr+ , ProcessCMD :<: instr+ , VHDLCMD :<: instr+ , pred Bool )- => Program instr (Param2 exp pred) a+ => Program instr (Param2 exp pred) () -> IO () icompile = putStrLn . compile @@ -77,65 +89,55 @@ runIO = interpretBi (return . evalE) ----------------------------------------------------------------------------------- Some extra compilers that might be handy to have. -compileAXILite :: forall instr (exp :: * -> *) (pred :: * -> GHC.Constraint) a .- ( Interp instr VHDL (Param2 exp pred)+compileSig :: forall instr (exp :: * -> *) (pred :: * -> GHC.Constraint) a .+ ( Interp instr VHDLGen (Param2 exp pred) , HFunctor instr- , AXIPred instr exp pred+ , ComponentCMD :<: instr )- => Comp instr exp pred Identity a+ => Sig instr exp pred Identity a -> String-compileAXILite = compile . void . component . axi_light +compileSig =+ show+ . VHDL.prettyVHDL+ . flip runVHDLGen emptyEnv+ . interpret+ . component -icompileAXILite :: forall instr (exp :: * -> *) (pred :: * -> GHC.Constraint) a .- ( Interp instr VHDL (Param2 exp pred)+icompileSig :: forall instr (exp :: * -> *) (pred :: * -> GHC.Constraint) a .+ ( Interp instr VHDLGen (Param2 exp pred) , HFunctor instr- , AXIPred instr exp pred+ , ComponentCMD :<: instr )- => Comp instr exp pred Identity a+ => Sig instr exp pred Identity a -> IO ()-icompileAXILite = putStrLn . compileAXILite+icompileSig = putStrLn . compileSig ----------------------------------------------------------------------------------- todo: Not sure we need these any more.+-- Some extra compilers that might be handy to have. -compileWrap :: forall instr (exp :: * -> *) (pred :: * -> GHC.Constraint) a .- ( Interp instr VHDL (Param2 exp pred)- , HFunctor instr- , ComponentCMD :<: instr- , StructuralCMD :<: instr- , SignalCMD :<: instr- , pred Bool- )- => (Signal Bool -> Signal Bool -> Program instr (Param2 exp pred) ())+compileAXILite :: forall instr (exp :: * -> *) (pred :: * -> GHC.Constraint) a .+ ( Interp instr VHDLGen (Param2 exp pred)+ , HFunctor instr+ , AXIPred instr exp pred+ )+ => Sig instr exp pred Identity a -> String-compileWrap = compile . wrap+compileAXILite sig =+ show+ . VHDL.prettyVHDL+ . flip runVHDLGen emptyEnv+ . interpret+ $ do comp <- component sig+ clockedComponent "AXI" "S_AXI_ACLK" "S_AXI_ARESETN" (axi_light comp) -icompileWrap :: forall instr (exp :: * -> *) (pred :: * -> GHC.Constraint) a.- ( Interp instr VHDL (Param2 exp pred)- , HFunctor instr- , ComponentCMD :<: instr- , StructuralCMD :<: instr- , SignalCMD :<: instr- , pred Bool- )- => (Signal Bool -> Signal Bool -> Program instr (Param2 exp pred) ())+icompileAXILite :: forall instr (exp :: * -> *) (pred :: * -> GHC.Constraint) a .+ ( Interp instr VHDLGen (Param2 exp pred)+ , HFunctor instr+ , AXIPred instr exp pred+ )+ => Sig instr exp pred Identity a -> IO ()-icompileWrap = icompile . wrap---- | Wrap a hardware program in a architecture/entity pair.-wrap :: forall instr (exp :: * -> *) (pred :: * -> GHC.Constraint) a .- ( ComponentCMD :<: instr- , StructuralCMD :<: instr- , SignalCMD :<: instr- , pred Bool- )- => (Signal Bool -> Signal Bool -> Program instr (Param2 exp pred) ())- -> Program instr (Param2 exp pred) ()-wrap sf = void $ component $- namedInput "clk" $ \c ->- namedInput "rst" $ \r ->- ret $ process (c .: r .: []) $ sf c r+icompileAXILite = putStrLn . compileAXILite --------------------------------------------------------------------------------
src/Language/Embedded/Hardware/Command/Backend/VHDL.hs view
@@ -9,8 +9,19 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleContexts #-} -module Language.Embedded.Hardware.Command.Backend.VHDL (CompileType(..)) where+module Language.Embedded.Hardware.Command.Backend.VHDL+ ( SignalEnv(..)+ , emptyEnv+ , VHDLGenT+ , VHDLGen+ , runVHDLGenT+ , runVHDLGen+ , CompileType(..)+ )+ where import Control.Monad.Operational.Higher @@ -20,10 +31,21 @@ import Language.Embedded.Hardware.Expression.Represent.Bit (Bits, ni) import Language.Embedded.Hardware.Command.CMD -import Language.Embedded.VHDL (VHDL)+import Language.Embedded.VHDL (VHDLT, VHDL) import qualified Language.VHDL as V import qualified Language.Embedded.VHDL as V+--+import qualified Language.Embedded.VHDL.Monad as V+-- ++import Control.Monad.Identity (Identity)+import Control.Monad.Reader (ReaderT, MonadReader)+import Control.Monad.State (StateT, MonadState, MonadIO)+import qualified Control.Monad.Identity as CMI+import qualified Control.Monad.Reader as CMR+import qualified Control.Monad.State as CMS+ import Data.Array.IO (freeze) import Data.List (genericTake) import Data.Proxy@@ -34,9 +56,56 @@ import GHC.TypeLits (KnownNat) ----------------------------------------------------------------------------------- * Translation of hardware commands into VHDL.+-- * VHDL code generation. -------------------------------------------------------------------------------- +data SignalEnv = SignalEnv+ { _clock :: Signal Bool+ , _reset :: Signal Bool+ }++-- todo: 'wrapMain' will add these ports.+emptyEnv :: SignalEnv+emptyEnv = SignalEnv {+ _clock = SignalC "clk"+ , _reset = SignalC "rst" }++type MonadGen m = (Functor m, Applicative m, Monad m, MonadReader SignalEnv m)++newtype VHDLGenT m a = VHDLGenT { unVHDLGenT :: ReaderT SignalEnv (VHDLT m) a }+ deriving ( Functor+ , Applicative+ , Monad+ , MonadReader SignalEnv+ , MonadState V.VHDLEnv+ )++type VHDLGen = VHDLGenT Identity++runVHDLGenT :: Monad m => VHDLGenT m a -> SignalEnv -> VHDLT m a+runVHDLGenT m = CMR.runReaderT (unVHDLGenT m)++runVHDLGen :: VHDLGen a -> SignalEnv -> VHDL a+runVHDLGen = runVHDLGenT++--------------------------------------------------------------------------------++readClock :: MonadGen m => m (V.Identifier)+readClock = CMR.asks (\e -> let (SignalC clk) = _clock e in ident' clk)++readReset :: MonadGen m => m (V.Identifier)+readReset = CMR.asks (\e -> let (SignalC clk) = _reset e in ident' clk)++localClock :: MonadGen m => String -> m () -> m ()+localClock clk = CMR.local $ \e -> e { _clock = SignalC clk }++localReset :: MonadGen m => String -> m () -> m ()+localReset rst = CMR.local $ \e -> e { _reset = SignalC rst }++--------------------------------------------------------------------------------+-- ** Translation of hardware types and expressions into VHDL.+--------------------------------------------------------------------------------+ class CompileType ct where compileType :: ct a => proxy1 ct -> proxy2 a -> VHDL V.Type@@ -45,34 +114,36 @@ instance CompileType PrimType where- compileType _ = compT- compileLit _ = return . literal . primTypeVal- compileBits _ = return . literal . primTypeBits+ compileType _ x = declareType $ proxyE x+ compileLit _ = return . literal . primTypeVal+ compileBits _ = return . literal . primTypeBits -------------------------------------------------------------------------------- -compT :: forall proxy a . PrimType a => proxy a -> VHDL V.Type-compT _ = declareType (Proxy :: Proxy a)+compTC :: forall proxy ct exp a . (CompileType ct, ct a) => Proxy ct -> Proxy a -> VHDLGen V.Type+compTC ct p = VHDLGenT $ CMS.lift $ compileType ct p -compTM :: forall proxy ct exp a . (CompileType ct, ct a)- => proxy ct -> Maybe (exp a) -> VHDL V.Type-compTM _ _ = compileType (Proxy::Proxy ct) (Proxy::Proxy a)+compTM :: forall proxy ct exp a . (CompileType ct, ct a) => Proxy ct -> Maybe (exp a) -> VHDLGen V.Type+compTM ct m = compTC ct (proxyM m) -compTF :: forall proxy ct exp a b . (CompileType ct, ct a)- => proxy ct -> (exp a -> b) -> VHDL V.Type-compTF _ _ = compileType (Proxy::Proxy ct) (Proxy::Proxy a)+compTF :: forall proxy ct exp a b . (CompileType ct, ct a) => Proxy ct -> (exp a -> b) -> VHDLGen V.Type+compTF ct f = compTC ct (proxyF f) -compTA :: forall proxy ct array i a . (CompileType ct, ct a)- => proxy ct -> V.Range -> array a -> VHDL V.Type-compTA _ range _ =+compTA :: forall proxy ct arr i a . (CompileType ct, ct a) => Proxy ct -> V.Range -> arr a -> VHDLGen V.Type+compTA ct range a = do i <- newSym (Base "array")- t <- compileType (Proxy::Proxy ct) (Proxy::Proxy a)- let array = V.constrainedArray (ident' i) t range- s <- V.findType array- case s of- Just n -> do return (named n)- Nothing -> do V.addType array- return (typed array)+ t <- compTC ct (proxyE a)+ -- use work.types+ V.addLibrary "WORK"+ V.addImport "WORK.types"+ let arr = V.constrainedArray (ident' i) t range+ b <- V.lookupArrayType arr+ case b of+ Just t' ->+ do return (named t')+ Nothing ->+ do V.addType arr+ return (typed arr) where typed :: V.TypeDeclaration -> V.SubtypeIndication typed (V.TDFull (V.FullTypeDeclaration i _)) = named i@@ -83,19 +154,37 @@ -------------------------------------------------------------------------------- -evalEM :: forall exp a . EvaluateExp exp- => Maybe (exp a) -> a+compLC :: forall proxy ct a . (CompileType ct, ct a) => Proxy ct -> a -> VHDLGen V.Expression+compLC ct a = VHDLGenT $ CMS.lift $ compileLit ct a++compBC :: forall proxy ct a . (CompileType ct, ct a) => Proxy ct -> a -> VHDLGen V.Expression+compBC ct a = VHDLGenT $ CMS.lift $ compileBits ct a++--------------------------------------------------------------------------------++evalEM :: forall exp a . EvaluateExp exp => Maybe (exp a) -> a evalEM e = maybe (error "empty value") id $ fmap evalE e -compEM :: forall exp a . CompileExp exp- => Maybe (exp a) -> VHDL (Maybe V.Expression)-compEM e = maybe (return Nothing) (>>= return . Just) $ fmap compE e+compER :: forall exp a . CompileExp exp => exp a -> VHDLGen (V.Expression)+compER e = VHDLGenT $ CMS.lift $ compE e +compEM :: forall exp a . CompileExp exp => Maybe (exp a) -> VHDLGen (Maybe V.Expression)+compEM e = maybe (return Nothing) (>>= return . Just) (fmap compER e)+ -------------------------------------------------------------------------------- proxyE :: exp a -> Proxy a proxyE _ = Proxy +proxyS :: Signal a -> Proxy a+proxyS _ = Proxy++proxyV :: Variable a -> Proxy a+proxyV _ = Proxy++proxyA :: Array a -> Proxy a+proxyA _ = Proxy+ proxyM :: Maybe (exp a) -> Proxy a proxyM _ = Proxy @@ -103,37 +192,27 @@ proxyF _ = Proxy --------------------------------------------------------------------------------+-- Names.+-------------------------------------------------------------------------------- freshVar :: forall proxy ct exp a . (CompileType ct, ct a)- => proxy ct -> Name -> VHDL (Val a)+ => proxy ct -> Name -> VHDLGen (Val a) freshVar _ prefix = do i <- newSym prefix- t <- compileType (Proxy::Proxy ct) (Proxy::Proxy a)+ t <- compTC (Proxy::Proxy ct) (Proxy::Proxy a) V.variable (ident' i) t Nothing return (ValC i) -newSym :: Name -> VHDL String+newSym :: Name -> VHDLGen String newSym (Base n) = V.newSym n newSym (Exact n) = return n -ident :: ToIdent a => a -> String-ident a = let (Ident s) = toIdent a in s--ident' :: ToIdent a => a -> V.Identifier-ident' a = V.Ident $ ident a---- todo: this... why does this work?-instance ToIdent String where toIdent = Ident-instance ToIdent Ident where toIdent = id-instance ToIdent Name where- toIdent (Base s) = Ident s- toIdent (Exact s) = Ident s- -------------------------------------------------------------------------------- -- ** Signals. -------------------------------------------------------------------------------- -instance (CompileExp exp, CompileType ct) => Interp SignalCMD VHDL (Param2 exp ct)+instance (CompileExp exp, CompileType ct)+ => Interp SignalCMD VHDLGen (Param2 exp ct) where interp = compileSignal @@ -141,42 +220,36 @@ where interpBi = runSignal --- todo: is concurrent... really necessary? I think the VHDL monad handle that.-compileSignal :: forall exp ct a. (CompileExp exp, CompileType ct) => SignalCMD (Param3 VHDL exp ct) a -> VHDL a-compileSignal (NewSignal base mode exp) =+compileSignal :: forall exp ct a. (CompileExp exp, CompileType ct)+ => SignalCMD (Param3 VHDLGen exp ct) a+ -> VHDLGen a+compileSignal (NewSignal base exp) = do i <- newSym base v <- compEM exp- t <- compTM (Proxy::Proxy ct) exp- V.signal (ident' i) mode t v+ t <- compTM (Proxy :: Proxy ct) exp+ V.signal (ident' i) V.InOut t (fmap (flip V.uType t) v) return (SignalC i) compileSignal (GetSignal (SignalC s)) =- do i <- freshVar (Proxy::Proxy ct) (Base "v")+ do i <- freshVar (Proxy :: Proxy ct) (Base "v") V.assignVariable (simple $ ident i) (simple' s) return i compileSignal (SetSignal (SignalC s) exp) =- do e' <- compE exp- t <- compileType (Proxy::Proxy ct) (proxyE exp)+ do e' <- compER exp+ t <- compTC (Proxy :: Proxy ct) (proxyE exp) V.assignSignal (simple $ ident s) (V.uType e' t) compileSignal (UnsafeFreezeSignal (SignalC s)) = do return $ ValC s-compileSignal (ConcurrentSetSignal (SignalC s) exp) =- do e <- compE exp- V.concurrentSignal (simple $ ident s) e runSignal :: SignalCMD (Param3 IO IO pred) a -> IO a-runSignal (NewSignal _ _ Nothing) = fmap SignalE $ IR.newIORef (error "uninitialized signal")-runSignal (NewSignal _ _ (Just a)) = fmap SignalE . IR.newIORef =<< a-runSignal (GetSignal (SignalE r)) = fmap ValE $ IR.readIORef r-runSignal (SetSignal (SignalE r) exp) = IR.writeIORef r =<< exp-runSignal x@(UnsafeFreezeSignal r) = runSignal (GetSignal r `asTypeOf` x)-runSignal (ConcurrentSetSignal (SignalE r) exp) =- error "hardware-edsl.todo: run concurrent signals."+runSignal x@(UnsafeFreezeSignal r) = runSignal (GetSignal r `asTypeOf` x)+runSignal _ = error "hardware-edsl.todo: run signals." -------------------------------------------------------------------------------- -- ** Variables. -------------------------------------------------------------------------------- -instance (CompileExp exp, CompileType ct) => Interp VariableCMD VHDL (Param2 exp ct)+instance (CompileExp exp, CompileType ct)+ => Interp VariableCMD VHDLGen (Param2 exp ct) where interp = compileVariable @@ -185,7 +258,9 @@ interpBi = runVariable -- todo: why not initialize variable?-compileVariable :: forall ct exp a. (CompileExp exp, CompileType ct) => VariableCMD (Param3 VHDL exp ct) a -> VHDL a+compileVariable :: forall ct exp a. (CompileExp exp, CompileType ct)+ => VariableCMD (Param3 VHDLGen exp ct) a+ -> VHDLGen a compileVariable (NewVariable base exp) = do i <- newSym base v <- compEM exp@@ -196,54 +271,29 @@ Just v' -> V.assignVariable (simple $ ident i) (V.uType v' t) return (VariableC i) compileVariable (GetVariable (VariableC var)) =- do i <- freshVar (Proxy::Proxy ct) (Base "v")+ do i <- freshVar (Proxy :: Proxy ct) (Base "v") V.assignVariable (simple $ ident i) (simple' var) return i compileVariable (SetVariable (VariableC var) exp) =- do e' <- compE exp- t <- compileType (Proxy::Proxy ct) (proxyE exp)+ do e' <- compER exp+ t <- compTC (Proxy :: Proxy ct) (proxyE exp) V.assignVariable (simple var) (V.uType e' t) compileVariable (UnsafeFreezeVariable (VariableC v)) = do return $ ValC v runVariable :: VariableCMD (Param3 IO IO pred) a -> IO a+runVariable x@(UnsafeFreezeVariable v) = runVariable (GetVariable v `asTypeOf` x) runVariable (NewVariable _ Nothing) = fmap VariableE $ IR.newIORef (error "uninitialized variable") runVariable (NewVariable _ (Just a)) = fmap VariableE . IR.newIORef =<< a runVariable (GetVariable (VariableE v)) = fmap ValE $ IR.readIORef v runVariable (SetVariable (VariableE v) exp) = IR.writeIORef v =<< exp-runVariable x@(UnsafeFreezeVariable v) = runVariable (GetVariable v `asTypeOf` x) ----------------------------------------------------------------------------------- ** Constants.-----------------------------------------------------------------------------------instance (CompileExp exp, CompileType ct) => Interp ConstantCMD VHDL (Param2 exp ct)- where- interp = compileConstant--instance InterpBi ConstantCMD IO (Param1 pred)- where- interpBi = runConstant--compileConstant :: forall ct exp a. (CompileExp exp, CompileType ct) => ConstantCMD (Param3 VHDL exp ct) a -> VHDL a-compileConstant (NewConstant base (exp :: exp c)) =- do i <- newSym base- v <- compE exp- t <- compileType (Proxy::Proxy ct) (Proxy::Proxy c)- V.constant (ident' i) t v- return (ConstantC i)-compileConstant (GetConstant (ConstantC c)) =- do return $ ValC c--runConstant :: ConstantCMD (Param3 IO IO pred) a -> IO a-runConstant (NewConstant _ exp) = return . ConstantE =<< exp-runConstant (GetConstant (ConstantE exp)) = return $ ValE exp---------------------------------------------------------------------------------- -- ** Arrays. -------------------------------------------------------------------------------- -instance (CompileExp exp, CompileType ct) => Interp ArrayCMD VHDL (Param2 exp ct)+instance (CompileExp exp, CompileType ct)+ => Interp ArrayCMD VHDLGen (Param2 exp ct) where interp = compileArray @@ -251,42 +301,48 @@ where interpBi = runArray -compileArray :: forall ct exp a. (CompileExp exp, CompileType ct) => ArrayCMD (Param3 VHDL exp ct) a -> VHDL a+compileArray :: forall ct exp a. (CompileExp exp, CompileType ct)+ => ArrayCMD (Param3 VHDLGen exp ct) a+ -> VHDLGen a compileArray (NewArray base len) = do i <- newSym base- l <- compE len- t <- compTA (Proxy::Proxy ct) (rangeZero l) (undefined :: a)+ l <- compER len+ let len = V.sub [unpackTerm l, lift $ V.literal $ V.number "1"]+ t <- compTA (Proxy :: Proxy ct) (rangeZero (lift len)) (undefined :: a) V.array (ident' i) V.InOut t Nothing return (ArrayC i) compileArray (InitArray base is) = do i <- newSym base- t <- compTA (Proxy::Proxy ct) (rangePoint (length is - 1)) (undefined :: a)- x <- mapM (compileBits (Proxy::Proxy ct)) is+ let len = V.sub [lift $ V.literal $ V.number $ show $ length is, lift $ V.literal $ V.number "1"]+ t <- compTA (Proxy :: Proxy ct) (rangeZero (lift len)) (undefined :: a)+ x <- mapM (compBC (Proxy::Proxy ct)) is let v = V.aggregate $ V.aggregated x V.array (ident' i) V.InOut t (Just $ lift v) return (ArrayC i) compileArray (GetArray (ArrayC s) ix) =- do i <- freshVar (Proxy::Proxy ct) (Base "a")- e <- compE ix+ do i <- freshVar (Proxy :: Proxy ct) (Base "a")+ e <- compER ix V.assignVariable (simple $ ident i) (indexed' s e) return i compileArray (SetArray (ArrayC s) ix e) =- do ix' <- compE ix- e' <- compE e- t <- compileType (Proxy::Proxy ct) (proxyE e)+ do ix' <- compER ix+ e' <- compER e+ t <- compTC (Proxy :: Proxy ct) (proxyE e) V.assignArray (indexed s ix') (V.uType e' t) compileArray (CopyArray (ArrayC a, oa) (ArrayC b, ob) l) =- do oa' <- compE oa- ob' <- compE ob- len <- compE l- let lower_a = V.add [unpackTerm len, unpackTerm oa']- lower_b = V.add [unpackTerm len, unpackTerm ob']- dest = slice a $ range oa' V.downto $ lift $ lower_a- src = slice' b $ range ob' V.downto $ lift $ lower_b+ do oa' <- compER oa+ ob' <- compER ob+ len <- compER l+ let upper_a = V.add [unpackTerm len, unpackTerm oa']+ upper_b = V.add [unpackTerm len, unpackTerm ob']+ dest = slice a $ range (lift upper_a) V.downto oa'+ src = slice' b $ range (lift upper_b) V.downto ob' V.assignSignal dest src+compileArray (UnsafeFreezeArray (ArrayC a)) = return $ IArrayC a+compileArray (UnsafeThawArray (IArrayC a)) = return $ ArrayC a compileArray (ResetArray (ArrayC a) rst) =- do rst' <- compE rst- t <- compileType (Proxy::Proxy ct) (proxyE rst)+ do rst' <- compER rst+ t <- compTC (Proxy :: Proxy ct) (proxyE rst) let others = V.aggregate $ V.others (V.uType rst' t) V.assignArray (simple a) (lift others) @@ -297,7 +353,8 @@ -- ** Virtual Arrays. -------------------------------------------------------------------------------- -instance (CompileExp exp, CompileType ct) => Interp VArrayCMD VHDL (Param2 exp ct)+instance (CompileExp exp, CompileType ct)+ => Interp VArrayCMD VHDLGen (Param2 exp ct) where interp = compileVArray @@ -305,35 +362,38 @@ where interpBi = runVArray -compileVArray :: forall ct exp a. (CompileExp exp, CompileType ct) => VArrayCMD (Param3 VHDL exp ct) a -> VHDL a+compileVArray :: forall ct exp a. (CompileExp exp, CompileType ct)+ => VArrayCMD (Param3 VHDLGen exp ct) a+ -> VHDLGen a compileVArray (NewVArray base len) =- do l <- compE len- t <- compTA (Proxy::Proxy ct) (rangeZero l) (undefined :: a)- i <- newSym base+ do i <- newSym base+ l <- compER len+ let len = V.sub [unpackTerm l, lift $ V.literal $ V.number "1"]+ t <- compTA (Proxy :: Proxy ct) (rangeZero (lift len)) (undefined :: a) V.variable (ident' i) t Nothing return (VArrayC i) compileVArray (InitVArray base is) =- do let r = rangePoint (length is - 1)- t <- compTA (Proxy::Proxy ct) r (undefined :: a)- i <- newSym base- x <- mapM (compileBits (Proxy::Proxy ct)) is+ do i <- newSym base+ let len = V.sub [lift $ V.literal $ V.number $ show $ length is, lift $ V.literal $ V.number "1"]+ t <- compTA (Proxy :: Proxy ct) (rangeZero (lift len)) (undefined :: a)+ x <- mapM (compBC (Proxy :: Proxy ct)) is let v = V.aggregate $ V.aggregated x V.variable (ident' i) t (Just $ lift v) return (VArrayC i) compileVArray (GetVArray (VArrayC arr) ix) =- do i <- freshVar (Proxy::Proxy ct) (Base "a")- e <- compE ix+ do i <- freshVar (Proxy :: Proxy ct) (Base "a")+ e <- compER ix V.assignVariable (simple $ ident i) (indexed' arr e) return i compileVArray (SetVArray a@(VArrayC arr) i e) =- do i' <- compE i- e' <- compE e- t <- compileType (Proxy::Proxy ct) (proxyE e)+ do i' <- compER i+ e' <- compER e+ t <- compTC (Proxy::Proxy ct) (proxyE e) V.assignVariable (indexed arr i') (V.uType e' t) compileVArray (CopyVArray (VArrayC a, oa) (VArrayC b, ob) l) =- do oa' <- compE oa- ob' <- compE ob- len <- compE l+ do oa' <- compER oa+ ob' <- compER ob+ len <- compER l let lower_a = V.add [unpackTerm len, unpackTerm oa'] lower_b = V.add [unpackTerm len, unpackTerm ob'] dest = slice a $ range oa' V.downto $ lift $ lower_a@@ -343,6 +403,9 @@ compileVArray (UnsafeThawVArray (IArrayC arr)) = return $ VArrayC arr runVArray :: VArrayCMD (Param3 IO IO pred) a -> IO a+runVArray = error "hardware-edsl.todo: run arrays"++{- runVArray (NewVArray _ len) = do len' <- len arr <- IA.newArray_ (0, len')@@ -351,12 +414,13 @@ do arr <- IA.newListArray (0, fromIntegral $ length is - 1) is return (VArrayE arr) runVArray (GetVArray (VArrayE arr) i) =- do (l, h) <- IA.getBounds arr- ix <- i+ do ix <- i+ (l, h) <- IA.getBounds arr if (ix < l || ix > h)- then error "getArr out of bounds"- else do v <- IA.readArray arr ix- return (ValE v)+ then error "getArr out of bounds"+ else do+ v <- IA.readArray arr ix+ return (ValE v) runVArray (SetVArray (VArrayE arr) i e) = do (l, h) <- IA.getBounds arr ix <- i@@ -376,12 +440,13 @@ | i <- genericTake l' [0..] ] runVArray (UnsafeFreezeVArray (VArrayE arr)) = IA.freeze arr >>= return . IArrayE runVArray (UnsafeThawVArray (IArrayE arr)) = IA.thaw arr >>= return . VArrayE-+-} -------------------------------------------------------------------------------- -- ** Loops. -------------------------------------------------------------------------------- -instance (CompileExp exp, CompileType ct) => Interp LoopCMD VHDL (Param2 exp ct)+instance (CompileExp exp, CompileType ct)+ => Interp LoopCMD VHDLGen (Param2 exp ct) where interp = compileLoop @@ -389,19 +454,28 @@ where interpBi = runLoop -compileLoop :: forall ct exp a. (CompileExp exp, CompileType ct) => LoopCMD (Param3 VHDL exp ct) a -> VHDL a+-- todo: loops, as expressed here, aren't synthesizable in general for the+-- range is given as expressions, which could be any variable. To ensure the+-- for-loops are synthesizable we should limit its range to a constant.+compileLoop :: forall ct exp a. (CompileExp exp, CompileType ct)+ => LoopCMD (Param3 VHDLGen exp ct) a+ -> VHDLGen a compileLoop (For l u step) =- do -- *** todo: temp solution, should check if signed and size.- i <- newSym (Base "l")- l' <- compE l- u' <- compE u- loop <- V.inFor (ident' i) (range l' V.to u') (step (ValC i))+ do i <- newSym (Base "l")+ l' <- compER l+ u' <- compER u+ t <- compTC (Proxy :: Proxy ct) (proxyE l)+ let int v = V.uCast v t (V.integer Nothing)+ typ i = undefined+ loop <- V.inFor (ident' i)+ (range (int l') V.to (int u'))+ (step (ValC i)) V.addSequential $ V.SLoop $ loop compileLoop (While cont step) = do l <- V.newLabel loop <- V.inWhile l Nothing $ do b <- cont- exit <- compE b+ exit <- compER b V.exit l exit step V.addSequential $ V.SLoop $ loop@@ -423,7 +497,8 @@ -- ** Conditional. -------------------------------------------------------------------------------- -instance (CompileExp exp, CompileType ct) => Interp ConditionalCMD VHDL (Param2 exp ct)+instance (CompileExp exp, CompileType ct)+ => Interp ConditionalCMD VHDLGen (Param2 exp ct) where interp = compileConditional @@ -431,28 +506,30 @@ where interpBi = runConditional -compileConditional :: forall ct exp a. (CompileExp exp, CompileType ct) => ConditionalCMD (Param3 VHDL exp ct) a -> VHDL a+compileConditional :: forall ct exp a. (CompileExp exp, CompileType ct)+ => ConditionalCMD (Param3 VHDLGen exp ct) a+ -> VHDLGen a compileConditional (If (a, b) cs em) = do let (es, ds) = unzip cs el = maybe (return ()) id em- ae <- compE a- ese <- mapM compE es+ ae <- compER a+ ese <- mapM compER es s <- V.inConditional (ae, b) (zip ese ds) el V.addSequential $ V.SIf s compileConditional (Case e cs d) = do let el = maybe (return ()) id d- ae <- compE e+ ae <- compER e ce <- mapM compC cs s <- V.inCase ae ce el V.addSequential $ V.SCase s where- compC :: ct b => When b VHDL -> VHDL (V.Choices, VHDL ())+ compC :: ct b => When b VHDLGen -> VHDLGen (V.Choices, VHDLGen ()) compC (When (Is e) p) = do- e' <- compileLit (Proxy::Proxy ct) e+ e' <- compLC (Proxy :: Proxy ct) e return $ (V.Choices [V.is $ unpackSimple e'], p) compC (When (To l h) p) = do- l' <- compileLit (Proxy::Proxy ct) l- h' <- compileLit (Proxy::Proxy ct) h+ l' <- compLC (Proxy :: Proxy ct) l+ h' <- compLC (Proxy :: Proxy ct) h return $ (V.Choices [V.between $ range l' V.to h'], p) compileConditional (Null) = V.null @@ -475,10 +552,42 @@ runConditional (Null) = return () --------------------------------------------------------------------------------+-- ** Processes.+--------------------------------------------------------------------------------++instance (CompileExp exp, CompileType ct)+ => Interp ProcessCMD VHDLGen (Param2 exp ct)+ where+ interp = compileProcess++instance InterpBi ProcessCMD IO (Param1 pred)+ where+ interpBi = runProcess++compileProcess :: forall ct exp a. (CompileExp exp, CompileType ct)+ => ProcessCMD (Param3 VHDLGen exp ct) a+ -> VHDLGen a+compileProcess (Process is prog rst) =+ do clock <- readClock+ reset <- readReset+ label <- V.newLabel+ let is' = identifiers is+ let rst' = fmap ((,) reset) rst+ V.inSingleProcess label clock rst' (identifiers is) prog+ where+ identifiers :: Signals -> [V.Identifier]+ identifiers = fmap (\(Ident i) -> V.Ident i)++runProcess :: ProcessCMD (Param3 IO IO pred) a -> IO a+runProcess _ =+ do error "hardware-edsl-todo: figure out how to simulate processes in Haskell."++-------------------------------------------------------------------------------- -- ** Components. -------------------------------------------------------------------------------- -instance (CompileExp exp, CompileType ct) => Interp ComponentCMD VHDL (Param2 exp ct)+instance (CompileExp exp, CompileType ct)+ => Interp ComponentCMD VHDLGen (Param2 exp ct) where interp = compileComponent @@ -486,97 +595,102 @@ where interpBi = runComponent -compileComponent :: forall ct exp a. (CompileExp exp, CompileType ct) => ComponentCMD (Param3 VHDL exp ct) a -> VHDL a-compileComponent (StructComponent base sig) =+compileComponent :: forall ct exp a. (CompileExp exp, CompileType ct)+ => ComponentCMD (Param3 VHDLGen exp ct) a+ -> VHDLGen a+compileComponent (DeclareComponent base clock reset sig) = do comp <- newSym base- V.component $- do p <- V.entity (ident' comp) (traverseSig sig)- V.architecture (ident' comp) (V.Ident "imp") p- return comp-compileComponent (PortMap (Component name sig) as) =+ clk <- newSym clock+ rst <- newSym reset+ args <- V.component $+ do (prg, is) <- V.entity (ident' comp) (traverseSig clk rst [] sig)+ V.architecture (ident' comp) (V.Ident "behav") prg+ return is+ return (comp, args)+compileComponent (PortMap (Component name args sig) as) = do let i = ident' name l <- V.newLabel- vs <- applySig sig as- V.inheritContext i- V.declareComponent i vs- V.portMap l i (assocSig sig as)+ vs <- applySig sig as args+ ac <- assocSig sig as args+ V.importComponent i vs+ V.portMap l i ac+ --+-- (V.VHDLEnv _ _ _ c _ _ _ _ _ _ _ _) <- CMS.get+-- error $ show c runComponent :: ComponentCMD (Param3 IO IO pred) a -> IO a-runComponent = error "hardware-edsl-todo: run components."+runComponent _ = error "hardware-edsl-todo: run components." -------------------------------------------------------------------------------- -traverseSig :: forall ct exp a . (CompileExp exp, CompileType ct) => Signature (Param3 VHDL exp ct) a -> VHDL (VHDL ())-traverseSig (Ret prog) = return prog-traverseSig (SSig n m sf) = +traverseSig :: forall ct exp a . (CompileExp exp, CompileType ct)+ => String -- Clock name.+ -> String -- Reset name.+ -> [String] -- Store of all parameters.+ -> Signature (Param3 VHDLGen exp ct) a+ -> VHDLGen (VHDLGen (), [String])+traverseSig clk rst is (Ret prog) =+ do let c@(V.Ident c') = ident' clk+ r@(V.Ident r') = ident' rst+ xs = reverse $ r' : c' : is + V.port c V.In V.std_logic Nothing+ V.port r V.In V.std_logic Nothing+ let prg = localClock clk $ localReset rst $ prog + return (prg, xs)+traverseSig clk rst is (SSig n m sf) = do i <- newSym n- t <- compTF (Proxy::Proxy ct) sf- V.signal (ident' i) m t Nothing- traverseSig (sf (SignalC i))-traverseSig (SArr n m l af) =+ t <- compTF (Proxy :: Proxy ct) sf+ V.port (ident' i) m t Nothing+ traverseSig clk rst (i : is) (sf (SignalC i))+traverseSig clk rst is (SArr n m l af) = do i <- newSym n- t <- compTA (Proxy::Proxy ct) (rangePoint l) (proxyF af)- V.array (ident' i) m t Nothing- traverseSig (af (ArrayC i))+ let len = V.sub [lift $ V.literal $ V.number $ show l, lift $ V.literal $ V.number "1"]+ t <- compTA (Proxy :: Proxy ct) (rangeZero (lift len)) (proxyF af)+ V.port (ident' i) m t Nothing+ traverseSig clk rst (i : is) (af (ArrayC i)) applySig :: forall ct exp a . (CompileExp exp, CompileType ct)- => Signature (Param3 VHDL exp ct) a -> Argument ct a- -> VHDL [V.InterfaceDeclaration]-applySig (Ret _) (Nil) = return []-applySig (SSig n m sf) (ASig s@(SignalC i) v) =- do t <- compTF (Proxy::Proxy ct) sf- is <- applySig (sf s) v+ => Signature (Param3 VHDLGen exp ct) a+ -> Argument ct a+ -> [String]+ -> VHDLGen [V.InterfaceDeclaration]+applySig (Ret _) (Nil) [c, r] = return [decl c, decl r]+ where+ decl :: String -> V.InterfaceDeclaration+ decl x = V.InterfaceSignalDeclaration [V.Ident x] (Just V.In) V.std_logic False Nothing+applySig (SSig _ m sf) (ASig s@(SignalC _) v) (n:ns) =+ do t <- compTF (Proxy :: Proxy ct) sf+ is <- applySig (sf s) v ns let i = V.InterfaceSignalDeclaration [ident' n] (Just m) t False Nothing return (i : is)-applySig (SArr n m l af) (AArr a@(ArrayC i) v) =- do t <- compTA (Proxy::Proxy ct) (rangePoint l) (proxyF af)- is <- applySig (af a) v+applySig (SArr _ m l af) (AArr a@(ArrayC _) v) (n:ns) =+ do let len = V.sub [lift $ V.literal $ V.number $ show l, lift $ V.literal $ V.number "1"]+ t <- compTA (Proxy :: Proxy ct) (rangeZero (lift len)) (proxyF af)+ is <- applySig (af a) v ns let i = V.InterfaceSignalDeclaration [ident' n] (Just m) t False Nothing return (i : is) assocSig :: forall ct exp a . (CompileExp exp, CompileType ct)- => Signature (Param3 VHDL exp ct) a -> Argument ct a- -> [(V.Identifier, V.Identifier)]-assocSig (Ret _) (Nil) = []-assocSig (SSig n _ sf) (ASig s@(SignalC i) v) =- (ident' n, ident' i) : assocSig (sf s) v-assocSig (SArr n _ _ af) (AArr a@(ArrayC i) v) =- (ident' n, ident' i) : assocSig (af a) v------------------------------------------------------------------------------------- ** Structural.-----------------------------------------------------------------------------------instance (CompileExp exp, CompileType ct) => Interp StructuralCMD VHDL (Param2 exp ct)- where- interp = compileStructural--instance InterpBi StructuralCMD IO (Param1 pred)- where- interpBi = runStructural--compileStructural :: forall ct exp a. (CompileExp exp, CompileType ct) => StructuralCMD (Param3 VHDL exp ct) a -> VHDL a-compileStructural (StructEntity (Exact e) prog) =- do V.entity (V.Ident e) prog-compileStructural (StructArchitecture (Exact e) (Exact a) prog) =- do V.architecture (V.Ident e) (V.Ident a) prog-compileStructural (StructProcess xs prog) =- do label <- V.newLabel- (a, c) <- V.inProcess label (fmap (\(Ident i) -> V.Ident i) xs) prog- V.addConcurrent (V.ConProcess c)- return a--runStructural :: StructuralCMD (Param3 IO IO pred) a -> IO a-runStructural (StructEntity _ prog) = prog-runStructural (StructArchitecture _ _ prog) = prog-runStructural (StructProcess xs prog) =- do error "hardware-edsl-todo: figure out how to simulate processes in Haskell."+ => Signature (Param3 VHDLGen exp ct) a+ -> Argument ct a+ -> [String]+ -> VHDLGen [(Maybe V.Identifier, V.Identifier)]+assocSig (Ret _) (Nil) [c, r] =+ do clk <- readClock+ rst <- readReset+ return [ (Just (V.Ident "clk"), clk)+ , (Just (V.Ident "rst"), rst)]+assocSig (SSig _ _ sf) (ASig s@(SignalC i) v) (n:ns) =+ ((Just (ident' n), ident' i) :) <$> assocSig (sf s) v ns+assocSig (SArr _ _ _ af) (AArr a@(ArrayC i) v) (n:ns) =+ ((Just (ident' n), ident' i) :) <$> assocSig (af a) v ns -------------------------------------------------------------------------------- -- ** VHDL. -------------------------------------------------------------------------------- -instance (CompileExp exp, CompileType ct) => Interp VHDLCMD VHDL (Param2 exp ct)+instance (CompileExp exp, CompileType ct)+ => Interp VHDLCMD VHDLGen (Param2 exp ct) where interp = compileVHDL @@ -584,62 +698,94 @@ where interpBi = runVHDL -compileVHDL :: forall ct exp a. (CompileExp exp, CompileType ct) => VHDLCMD (Param3 VHDL exp ct) a -> VHDL a-compileVHDL (Rising (SignalC clk) (SignalC rst) tru fls) =- do let condC = V.function (simple "rising_edge") [simple' clk]- condR = V.eq (unpackShift $ simple' rst) (unpackShift $ literal "'0'")- clock <- V.inConditional (lift condC,- do reset <- V.inConditional (lift condR, tru) [] (fls)- V.addSequential $ V.SIf $ reset- ) [] (return ())- V.addSequential $ V.SIf $ clock-compileVHDL (CopyBits ((SignalC a), oa) ((SignalC b), ob) l) =- do oa' <- compE oa- ob' <- compE ob- len <- compE l- let lower_a = V.add [unpackTerm len, unpackTerm oa']- lower_b = V.add [unpackTerm len, unpackTerm ob']- dest = slice a $ range oa' V.downto $ lift $ lower_a- src = slice' b $ range ob' V.downto $ lift $ lower_b- V.assignSignal dest src-compileVHDL (CopyVBits ((VariableC a), oa) ((SignalC b), ob) l) =- do oa' <- compE oa- ob' <- compE ob- len <- compE l- let lower_a = V.add [unpackTerm len, unpackTerm oa']- lower_b = V.add [unpackTerm len, unpackTerm ob']- dest = slice a $ range oa' V.downto $ lift $ lower_a- src = slice' b $ range ob' V.downto $ lift $ lower_b- V.assignVariable dest src+compileVHDL :: forall ct exp a. (CompileExp exp, CompileType ct)+ => VHDLCMD (Param3 VHDLGen exp ct) a+ -> VHDLGen a+compileVHDL (DeclarePort base exp mode) =+ do i <- newSym base+ v <- compEM exp+ t <- compTM (Proxy::Proxy ct) exp+ V.port (ident' i) mode t v+ return (SignalC i)+compileVHDL (CopyBits (as@(SignalC a), oa) (bs@(SignalC b), ob) l) =+ do oa' <- compER oa+ ob' <- compER ob+ len <- compER l+ ta <- compTC (Proxy :: Proxy ct) (proxyS as)+ tb <- compTC (Proxy :: Proxy ct) (proxyS bs)+ let upper_oa' = V.add [unpackTerm len, unpackTerm oa']+ upper_ob' = V.add [unpackTerm len, unpackTerm ob']+ let dest = slice a $ range (lift upper_oa') V.downto oa'+ src = slice' b $ range (lift upper_ob') V.downto ob'+ V.assignSignal dest (V.uCoerce src tb ta)+compileVHDL (CopyVBits (av@(VariableC a), oa) (bs@(SignalC b), ob) l) =+ do oa' <- compER oa+ ob' <- compER ob+ len <- compER l+ ta <- compTC (Proxy :: Proxy ct) (proxyV av)+ tb <- compTC (Proxy :: Proxy ct) (proxyS bs)+ let upper_oa' = V.add [unpackTerm len, unpackTerm oa']+ upper_ob' = V.add [unpackTerm len, unpackTerm ob']+ let dest = slice a $ range (lift upper_oa') V.downto oa'+ src = slice' b $ range (lift upper_ob') V.downto ob'+ V.assignVariable dest (V.uCoerce src tb ta)+compileVHDL (CopyABits (ar@(ArrayC a), oa, ia) (bs@(SignalC b), ob) l) =+ do oa' <- compER oa+ ia' <- compER ia+ ob' <- compER ob+ len <- compER l+ ta <- compTC (Proxy :: Proxy ct) (proxyA ar)+ tb <- compTC (Proxy :: Proxy ct) (proxyS bs)+ let upper_oa' = V.add [unpackTerm len, unpackTerm oa']+ upper_ob' = V.add [unpackTerm len, unpackTerm ob']+ let index = indexed a ia'+ dest = V.slice index $ range (lift upper_oa') V.downto oa'+ src = slice' b $ range (lift upper_ob') V.downto ob'+ V.assignSignal dest (V.uCoerce src tb ta) compileVHDL (GetBit (SignalC bits) ix) =- do i <- freshVar (Proxy::Proxy ct) (Base "b")- ix' <- compE ix+ do i <- freshVar (Proxy :: Proxy ct) (Base "b")+ ix' <- compER ix V.assignVariable (simple $ ident i) (indexed' bits ix') return i compileVHDL (SetBit s@(SignalC bits) ix bit) =- do ix' <- compE ix- bit' <- compE bit- t <- compileType (Proxy::Proxy ct) (proxyE s)+ do ix' <- compER ix+ bit' <- compER bit+ t <- compTC (Proxy :: Proxy ct) (proxyE s) case V.isBit t of True -> V.assignSignal (simple bits) (bit') False -> V.assignArray (indexed bits ix') (bit')-compileVHDL (GetBits (SignalC bits) l u) =- do i <- freshVar (Proxy::Proxy ct) (Base "b")- l' <- compE l- u' <- compE u- -- todo: this wrap around.- V.assignVariable (simple $ ident i)- ( lift $ V.toInteger $- lift $ V.asSigned $- slice' bits $- range l' V.downto u')+compileVHDL (GetBits s@(SignalC bits) start len) =+ do i <- freshVar (Proxy :: Proxy ct) (Base "b")+ start' <- compER start+ len' <- compER len+ typ <- compTC (Proxy :: Proxy ct) (proxyS s)+ let upper = V.add [unpackTerm len', unpackTerm start']+ exp = slice' bits $ range (lift upper) V.downto start'+ V.assignVariable (simple $ ident i) (V.uCoerce exp typ $ V.integer Nothing) return i runVHDL :: VHDLCMD (Param3 IO IO pred) a -> IO a runVHDL = error "hardware-edsl.runVHDL: todo." --------------------------------------------------------------------------------+-- Helpers.+-------------------------------------------------------------------------------- +-- todo: this... why does this work?+instance ToIdent String where toIdent = Ident+instance ToIdent Ident where toIdent = id+instance ToIdent Name where+ toIdent (Base s) = Ident s+ toIdent (Exact s) = Ident s++ident :: ToIdent a => a -> String+ident a = let (Ident s) = toIdent a in s++ident' :: ToIdent a => a -> V.Identifier+ident' a = V.Ident $ ident a++--------------------------------------------------------------------------------+ simple :: String -> V.Name simple s = V.simple s @@ -658,11 +804,13 @@ slice' :: String -> V.Range -> V.Expression slice' s = lift . V.name . slice s -literal :: String -> V.Expression-literal s = lift $ V.literal $ V.number s+literal :: String -> V.Expression+literal s = lift $ V.literal $ V.number s -range :: V.Expression -> V.Direction -> V.Expression -> V.Range-range l dir r = V.range (unpackSimple l) dir (unpackSimple r)+range :: V.Expression -> V.Direction -> V.Expression -> V.Range+range l dir r = V.range (unpackSimple l) dir (unpackSimple r)++-------------------------------------------------------------------------------- rangeZero :: V.Expression -> V.Range rangeZero l = V.range (unpackSimple l) V.downto (V.point 0)
src/Language/Embedded/Hardware/Command/CMD.hs view
@@ -10,6 +10,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Language.Embedded.Hardware.Command.CMD where @@ -44,6 +45,7 @@ -------------------------------------------------------------------------------- -- ** Values.+-------------------------------------------------------------------------------- -- | Value representation. data Val a = ValC String | ValE a@@ -55,6 +57,7 @@ -------------------------------------------------------------------------------- -- ** Signals.+-------------------------------------------------------------------------------- -- | Signal representation. data Signal a = SignalC VarId | SignalE (IORef a)@@ -63,50 +66,42 @@ data SignalCMD fs a where -- ^ Create a new signal.- NewSignal :: pred a => Name -> Mode -> Maybe (exp a) -> SignalCMD (Param3 prog exp pred) (Signal a)+ NewSignal :: pred a => Name -> Maybe (exp a) -> SignalCMD (Param3 prog exp pred) (Signal a) -- ^ Fetch the contents of a signal. GetSignal :: pred a => Signal a -> SignalCMD (Param3 prog exp pred) (Val a) -- ^ Write the value to a signal. SetSignal :: pred a => Signal a -> exp a -> SignalCMD (Param3 prog exp pred) () -- ^ Unsafe version of fetching a signal. UnsafeFreezeSignal :: pred a => Signal a -> SignalCMD (Param3 prog exp pred) (Val a)- -- *** todo: maybe this should be part of a set for concurrent instructions?- ConcurrentSetSignal :: pred a => Signal a -> exp a -> SignalCMD (Param3 prog exp pred) ()- -- *** todo: is this dangerous?- ToArray :: (pred a, Integral i, Ix i) => Signal a -> SignalCMD (Param3 prog exp pred) (Array i Bit) instance HFunctor SignalCMD where- hfmap _ (NewSignal n m e) = NewSignal n m e+ hfmap _ (NewSignal n e) = NewSignal n e hfmap _ (GetSignal s) = GetSignal s hfmap _ (SetSignal s e) = SetSignal s e hfmap _ (UnsafeFreezeSignal s) = UnsafeFreezeSignal s- -- ...- hfmap _ (ConcurrentSetSignal s e) = ConcurrentSetSignal s e- hfmap _ (ToArray s) = ToArray s instance HBifunctor SignalCMD where- hbimap _ f (NewSignal n m e) = NewSignal n m (fmap f e)+ hbimap _ f (NewSignal n e) = NewSignal n (fmap f e) hbimap _ _ (GetSignal s) = GetSignal s hbimap _ f (SetSignal s e) = SetSignal s (f e) hbimap _ _ (UnsafeFreezeSignal s) = UnsafeFreezeSignal s- -- ...- hbimap _ f (ConcurrentSetSignal s e) = ConcurrentSetSignal s (f e)- hbimap _ _ (ToArray s) = ToArray s instance (SignalCMD :<: instr) => Reexpressible SignalCMD instr env where- reexpressInstrEnv reexp (NewSignal n m e) = lift . singleInj . NewSignal n m =<< swapM (fmap reexp e)- reexpressInstrEnv reexp (GetSignal s) = lift $ singleInj $ GetSignal s- reexpressInstrEnv reexp (SetSignal s e) = lift . singleInj . SetSignal s =<< reexp e- reexpressInstrEnv reexp (UnsafeFreezeSignal s) = lift $ singleInj $ UnsafeFreezeSignal s- -- ...- reexpressInstrEnv reexp (ConcurrentSetSignal s e) = lift . singleInj . ConcurrentSetSignal s =<< reexp e- reexpressInstrEnv reexp (ToArray s) = lift $ singleInj $ ToArray s+ reexpressInstrEnv reexp (NewSignal n e) =+ lift . singleInj . NewSignal n =<< swapM (fmap reexp e)+ reexpressInstrEnv reexp (GetSignal s) =+ lift $ singleInj $ GetSignal s+ reexpressInstrEnv reexp (SetSignal s e) =+ lift . singleInj . SetSignal s =<< reexp e+ reexpressInstrEnv reexp (UnsafeFreezeSignal s) =+ lift $ singleInj $ UnsafeFreezeSignal s -------------------------------------------------------------------------------- -- ** Variables.+-------------------------------------------------------------------------------- -- | Variable representation. data Variable a = VariableC VarId | VariableE (IORef a)@@ -139,68 +134,48 @@ instance (VariableCMD :<: instr) => Reexpressible VariableCMD instr env where- reexpressInstrEnv reexp (NewVariable n e) = lift . singleInj . NewVariable n =<< swapM (fmap reexp e)- reexpressInstrEnv reexp (GetVariable v) = lift $ singleInj $ GetVariable v- reexpressInstrEnv reexp (SetVariable v e) = lift . singleInj . SetVariable v =<< reexp e- reexpressInstrEnv reexp (UnsafeFreezeVariable v) = lift $ singleInj $ UnsafeFreezeVariable v------------------------------------------------------------------------------------- ** Constants.---- | Constant representation.-data Constant a = ConstantC VarId | ConstantE a---- | Commands for constants.-data ConstantCMD fs a- where- -- ^ Create a new constant.- NewConstant :: pred a => Name -> exp a -> ConstantCMD (Param3 prog exp pred) (Constant a)- -- ^ Fetch the value of a constant.- GetConstant :: pred a => Constant a -> ConstantCMD (Param3 prog exp pred) (Val a)--instance HFunctor ConstantCMD- where- hfmap _ (NewConstant n e) = NewConstant n e- hfmap _ (GetConstant c) = GetConstant c--instance HBifunctor ConstantCMD- where- hbimap _ f (NewConstant n e) = NewConstant n (f e)- hbimap _ _ (GetConstant c) = GetConstant c--instance (ConstantCMD :<: instr) => Reexpressible ConstantCMD instr env- where- reexpressInstrEnv reexp (NewConstant n e) = lift . singleInj . NewConstant n =<< reexp e- reexpressInstrEnv reexp (GetConstant c) = lift $ singleInj $ GetConstant c+ reexpressInstrEnv reexp (NewVariable n e) =+ lift . singleInj . NewVariable n =<< swapM (fmap reexp e)+ reexpressInstrEnv reexp (GetVariable v) =+ lift $ singleInj $ GetVariable v+ reexpressInstrEnv reexp (SetVariable v e) =+ lift . singleInj . SetVariable v =<< reexp e+ reexpressInstrEnv reexp (UnsafeFreezeVariable v) =+ lift $ singleInj $ UnsafeFreezeVariable v -------------------------------------------------------------------------------- -- ** Arrays.+-------------------------------------------------------------------------------- -- | Expression types that support compilation of array indexing class CompArrayIx exp where -- | Generate code for an array indexing operation- compArrayIx :: (PredicateExp exp a, Integral i, Ix i) => exp i -> Array i a -> Maybe (exp a)+ compArrayIx :: (PredicateExp exp a) => exp Integer -> Array a -> Maybe (exp a) compArrayIx _ _ = Nothing -- | Array reprensentation.-data Array i a = ArrayC VarId | ArrayE (IOArray i a)+data Array a = ArrayC VarId | ArrayE (IOArray Integer a) -- | Commands for signal arrays. data ArrayCMD fs a where -- ^ Creates an array of given length.- NewArray :: (pred a, Integral i, Ix i) => Name -> exp i -> ArrayCMD (Param3 prog exp pred) (Array i a)+ NewArray :: (pred a) => Name -> exp Integer -> ArrayCMD (Param3 prog exp pred) (Array a) -- ^ Creates an array from the given list of elements.- InitArray :: (pred a, Integral i, Ix i) => Name -> [a] -> ArrayCMD (Param3 prog exp pred) (Array i a)+ InitArray :: (pred a) => Name -> [a] -> ArrayCMD (Param3 prog exp pred) (Array a) -- ^ Fetches the array's value at the specified index.- GetArray :: (pred a, Integral i, Ix i) => Array i a -> exp i -> ArrayCMD (Param3 prog exp pred) (Val a)+ GetArray :: (pred a) => Array a -> exp Integer -> ArrayCMD (Param3 prog exp pred) (Val a) -- ^ Writes a value to an array at some specified index.- SetArray :: (pred a, Integral i, Ix i) => Array i a -> exp i -> exp a -> ArrayCMD (Param3 prog exp pred) ()+ SetArray :: (pred a) => Array a -> exp Integer -> exp a -> ArrayCMD (Param3 prog exp pred) () -- ^ Copies a slice from the second array into the first.- CopyArray :: (pred a, Integral i, Ix i) => (Array i a, exp i) -> (Array i a, exp i) -> exp i -> ArrayCMD (Param3 prog exp pred) ()+ CopyArray :: (pred a) => (Array a, exp Integer) -> (Array a, exp Integer) -> exp Integer -> ArrayCMD (Param3 prog exp pred) ()+ -- ^ ...+ UnsafeFreezeArray :: (pred a) => Array a -> ArrayCMD (Param3 prog exp pred) (IArray a)+ -- ^ ...+ UnsafeThawArray :: (pred a) => IArray a -> ArrayCMD (Param3 prog exp pred) (Array a) -- ^ Writes a value to all indicies of the array.- ResetArray :: (pred a, Integral i, Ix i) => Array i a -> exp a -> ArrayCMD (Param3 prog exp pred) ()+ ResetArray :: (pred a) => Array a -> exp a -> ArrayCMD (Param3 prog exp pred) () instance HFunctor ArrayCMD where@@ -209,6 +184,8 @@ hfmap _ (GetArray a i) = GetArray a i hfmap _ (SetArray a i e) = SetArray a i e hfmap _ (CopyArray a b l) = CopyArray a b l+ hfmap _ (UnsafeFreezeArray a) = UnsafeFreezeArray a+ hfmap _ (UnsafeThawArray a) = UnsafeThawArray a -- ... hfmap _ (ResetArray a r) = ResetArray a r @@ -219,6 +196,8 @@ hbimap _ f (GetArray a i) = GetArray a (f i) hbimap _ f (SetArray a i e) = SetArray a (f i) (f e) hbimap _ f (CopyArray (a, oa) (b, ob) l) = CopyArray (a, f oa) (b, f ob) (f l)+ hbimap _ _ (UnsafeFreezeArray a) = UnsafeFreezeArray a+ hbimap _ _ (UnsafeThawArray a) = UnsafeThawArray a -- ... hbimap _ f (ResetArray a r) = ResetArray a (f r) @@ -235,38 +214,43 @@ reexpressInstrEnv reexp (CopyArray (a, oa) (b, ob) l) = do oa' <- reexp oa; ob' <- reexp ob; l' <- reexp l lift $ singleInj $ CopyArray (a, oa') (b, ob') l'+ reexpressInstrEnv reexp (UnsafeFreezeArray a)+ = lift $ singleInj $ UnsafeFreezeArray a+ reexpressInstrEnv reexp (UnsafeThawArray a)+ = lift $ singleInj $ UnsafeThawArray a -- ... reexpressInstrEnv reexp (ResetArray a r) = do r' <- reexp r; lift $ singleInj $ ResetArray a r' -------------------------------------------------------------------------------- -- ** Virtual arrays.+-------------------------------------------------------------------------------- -- | Virtual array reprensentation.-data VArray i a = VArrayC VarId | VArrayE (IOArray i a)+data VArray a = VArrayC VarId | VArrayE (IOArray Integer a) deriving (Eq, Typeable) -- | Immutable arrays.-data IArray i a = IArrayC VarId | IArrayE (Arr.Array i a)+data IArray a = IArrayC VarId | IArrayE (Arr.Array Integer a) deriving (Show, Typeable) -- | Commands for variable arrays. data VArrayCMD fs a where -- ^ Creates an array of given length.- NewVArray :: (pred a, Integral i, Ix i) => Name -> exp i -> VArrayCMD (Param3 prog exp pred) (VArray i a)+ NewVArray :: (pred a) => Name -> exp Integer -> VArrayCMD (Param3 prog exp pred) (VArray a) -- ^ Creates an array from the given list of elements.- InitVArray :: (pred a, Integral i, Ix i) => Name -> [a] -> VArrayCMD (Param3 prog exp pred) (VArray i a)+ InitVArray :: (pred a) => Name -> [a] -> VArrayCMD (Param3 prog exp pred) (VArray a) -- ^ Fetches the array's value at a specified index.- GetVArray :: (pred a, Integral i, Ix i) => VArray i a -> exp i -> VArrayCMD (Param3 prog exp pred) (Val a)+ GetVArray :: (pred a) => VArray a -> exp Integer -> VArrayCMD (Param3 prog exp pred) (Val a) -- ^ Writes a value to an array at some specified index.- SetVArray :: (pred a, Integral i, Ix i) => VArray i a -> exp i -> exp a -> VArrayCMD (Param3 prog exp pred) ()+ SetVArray :: (pred a) => VArray a -> exp Integer -> exp a -> VArrayCMD (Param3 prog exp pred) () -- ^ ...- CopyVArray:: (pred a, Integral i, Ix i) => (VArray i a, exp i) -> (VArray i a, exp i) -> exp i -> VArrayCMD (Param3 prog exp pred) ()+ CopyVArray:: (pred a) => (VArray a, exp Integer) -> (VArray a, exp Integer) -> exp Integer -> VArrayCMD (Param3 prog exp pred) () -- ^ ...- UnsafeFreezeVArray :: (pred a, Integral i, Ix i) => VArray i a -> VArrayCMD (Param3 prog exp pred) (IArray i a)+ UnsafeFreezeVArray :: (pred a) => VArray a -> VArrayCMD (Param3 prog exp pred) (IArray a) -- ^ ...- UnsafeThawVArray :: (pred a, Integral i, Ix i) => IArray i a -> VArrayCMD (Param3 prog exp pred) (VArray i a)+ UnsafeThawVArray :: (pred a) => IArray a -> VArrayCMD (Param3 prog exp pred) (VArray a) instance HFunctor VArrayCMD where@@ -308,12 +292,13 @@ -------------------------------------------------------------------------------- -- ** Looping.+-------------------------------------------------------------------------------- -- | Commands for looping constructs. data LoopCMD fs a where -- ^ Creates a new for loop.- For :: (pred i, Integral i) => exp i -> exp i -> (Val i -> prog ()) -> LoopCMD (Param3 prog exp pred) ()+ For :: pred Integer => exp Integer -> exp Integer -> (Val Integer -> prog ()) -> LoopCMD (Param3 prog exp pred) () -- ^ Creates a new while loop. While :: prog (exp Bool) -> prog () -> LoopCMD (Param3 prog exp pred) () @@ -341,6 +326,7 @@ -------------------------------------------------------------------------------- -- ** Conditional statements.+-------------------------------------------------------------------------------- -- | ... data When a prog = When (Constraint a) (prog ())@@ -406,19 +392,23 @@ -------------------------------------------------------------------------------- -- ** Components.+-------------------------------------------------------------------------------- -- | Signature description. data Signature fs a where Ret :: prog () -> Signature (Param3 prog exp pred) () SSig :: (pred a, Integral a, PrimType a)- => Name -> Mode+ => Name+ -> Mode -> (Signal a -> Signature (Param3 prog exp pred) b) -> Signature (Param3 prog exp pred) (Signal a -> b)- SArr :: (pred a, Integral a, PrimType a, pred i, Integral i, Ix i)- => Name -> Mode -> i- -> (Array i a -> Signature (Param3 prog exp pred) b)- -> Signature (Param3 prog exp pred) (Array i a -> b)+ SArr :: (pred a, Integral a, PrimType a, pred Integer)+ => Name+ -> Mode+ -> Integer+ -> (Array a -> Signature (Param3 prog exp pred) b)+ -> Signature (Param3 prog exp pred) (Array a -> b) instance HFunctor Signature where@@ -429,7 +419,7 @@ instance HBifunctor Signature where hbimap g f (Ret m) = Ret (g m)- hbimap g f (SSig n m sig) = SSig n m (hbimap g f . sig)+ hbimap g f (SSig n m sig) = SSig n m (hbimap g f . sig) hbimap g f (SArr n m l sig) = SArr n m l (hbimap g f . sig) reexpressSignature :: env@@ -447,22 +437,28 @@ => Signal a -> Argument pred b -> Argument pred (Signal a -> b)- AArr :: (pred a, Integral a, PrimType a, pred i, Integral i, Ix i)- => Array i a+ AArr :: (pred a, Integral a, PrimType a)+ => Array a -> Argument pred b- -> Argument pred (Array i a -> b)+ -> Argument pred (Array a -> b) -- | Named components.-data Component fs a = Component String (Signature fs a)+--+-- todo: I use the second param pass along the generated names for the+-- signature's parameters. It would be better to simply pass along the+-- updated signature in some way.+data Component fs a = Component String [String] (Signature fs a) -- | Commands for generating stand-alone components and calling them. data ComponentCMD fs a where -- ^ Wraps the given signature in a named component.- StructComponent+ DeclareComponent :: Name+ -> Name+ -> Name -> Signature (Param3 prog exp pred) a- -> ComponentCMD (Param3 prog exp pred) String+ -> ComponentCMD (Param3 prog exp pred) (String, [String]) -- ^ Call for interfacing with a component. PortMap :: Component (Param3 prog exp pred) a@@ -471,142 +467,148 @@ instance HFunctor ComponentCMD where- hfmap f (StructComponent n sig) = StructComponent n (hfmap f sig)- hfmap f (PortMap (Component m sig) as) = PortMap (Component m (hfmap f sig)) as+ hfmap f (DeclareComponent n c r sig) =+ DeclareComponent n c r (hfmap f sig)+ hfmap f (PortMap (Component m is sig) as) =+ PortMap (Component m is (hfmap f sig)) as instance HBifunctor ComponentCMD where- hbimap g f (StructComponent n sig) = StructComponent n (hbimap g f sig)- hbimap g f (PortMap (Component m sig) as) = PortMap (Component m (hbimap g f sig)) as+ hbimap g f (DeclareComponent n c r sig) =+ DeclareComponent n c r (hbimap g f sig)+ hbimap g f (PortMap (Component m is sig) as) =+ PortMap (Component m is (hbimap g f sig)) as instance (ComponentCMD :<: instr) => Reexpressible ComponentCMD instr env where- reexpressInstrEnv reexp (StructComponent n sig) = ReaderT $ \env ->- singleInj $ StructComponent n (reexpressSignature env sig)- reexpressInstrEnv reexp (PortMap (Component m sig) as) = ReaderT $ \env ->- singleInj $ PortMap (Component m (reexpressSignature env sig)) as+ reexpressInstrEnv reexp (DeclareComponent n c r sig) =+ ReaderT $ \env -> singleInj $+ DeclareComponent n c r (reexpressSignature env sig)+ reexpressInstrEnv reexp (PortMap (Component m is sig) as) =+ ReaderT $ \env -> singleInj $+ PortMap (Component m is (reexpressSignature env sig)) as -------------------------------------------------------------------------------- -- ** Structural entities.+-------------------------------------------------------------------------------- -data Ident = Ident VarId+type Signals = [Ident] +data Ident = Ident VarId+ class ToIdent a where toIdent :: a -> Ident instance ToIdent (Val a) where toIdent (ValC i) = Ident i instance ToIdent (Signal a) where toIdent (SignalC i) = Ident i instance ToIdent (Variable a) where toIdent (VariableC i) = Ident i-instance ToIdent (Constant a) where toIdent (ConstantC i) = Ident i-instance ToIdent (Array i a) where toIdent (ArrayC i) = Ident i-instance ToIdent (VArray i a) where toIdent (VArrayC i) = Ident i+instance ToIdent (Array a) where toIdent (ArrayC i) = Ident i+instance ToIdent (VArray a) where toIdent (VArrayC i) = Ident i -- | Commands for structural entities.-data StructuralCMD fs (a :: *)+data ProcessCMD fs (a :: *) where- -- ^ Wraps the program in an entity.- StructEntity- :: Name -> prog a -> StructuralCMD (Param3 prog exp pred) a- -- ^ Wraps the program in an architecture.- StructArchitecture- :: Name -> Name -> prog a -> StructuralCMD (Param3 prog exp pred) a- -- ^ Wraps the program in a process.- StructProcess- :: [Ident] -> prog () -> StructuralCMD (Param3 prog exp pred) ()---- todo: make sure entity and architectures always share a name.+ -- ^ Wraps the program in a process, triggered by the global clock.+ Process+ :: Signals -- ^ Inputs.+ -> prog () -- ^ Main program.+ -> Maybe (prog ()) -- ^ Reset program.+ -> ProcessCMD (Param3 prog exp pred) () -instance HFunctor StructuralCMD+instance HFunctor ProcessCMD where- hfmap f (StructEntity e p) = StructEntity e (f p)- hfmap f (StructArchitecture e a p) = StructArchitecture e a (f p)- hfmap f (StructProcess xs p) = StructProcess xs (f p)+ hfmap f (Process is prog rst) =+ Process is (f prog) (fmap f rst) -instance HBifunctor StructuralCMD+instance HBifunctor ProcessCMD where- hbimap g _ (StructEntity e p) = StructEntity e (g p)- hbimap g _ (StructArchitecture e a p) = StructArchitecture e a (g p)- hbimap g _ (StructProcess xs p) = StructProcess xs (g p)+ hbimap g _ (Process is prog rst) =+ Process is (g prog) (fmap g rst) -instance (StructuralCMD :<: instr) => Reexpressible StructuralCMD instr env+instance (ProcessCMD :<: instr) => Reexpressible ProcessCMD instr env where- reexpressInstrEnv reexp (StructEntity n p) =- ReaderT $ \env -> singleInj $ StructEntity n $ runReaderT p env- reexpressInstrEnv reexp (StructArchitecture e n p) =- ReaderT $ \env -> singleInj $ StructArchitecture e n $ runReaderT p env- reexpressInstrEnv reexp (StructProcess is p) =- ReaderT $ \env -> singleInj $ StructProcess is $ runReaderT p env+ reexpressInstrEnv reexp (Process is prog rst) =+ ReaderT $ \env -> singleInj $ Process is+ (runReaderT prog env)+ (fmap (flip runReaderT env) rst) -------------------------------------------------------------------------------- data VHDLCMD fs a where- -- todo: When we have external function calls we can replace this.- -- For now, its a handy short-hand for a common pattern in VHDL.- Rising :: pred Bit- => Signal Bit -- ^ clock.- -> Signal Bit -- ^ reset.- -> prog () -- ^ program for when clock & reset.- -> prog () -- ^ program for when clock & not reset.- -> VHDLCMD (Param3 prog exp pred) ()- -- todo: We should allow for base types to be treated as arrays of bits instead.+ DeclarePort :: pred a+ => Name -- ^ Port name.+ -> Maybe (exp a) -- ^ Initial value (if any).+ -> Mode -- ^ Direction.+ -> VHDLCMD (Param3 prog exp pred) (Signal a)+ -- todo: We should allow for base types to be treated as arrays of bits+ -- instead of having to explicitly convert them. -- todo: The second argument should be over a variable.- CopyBits :: (pred a, pred b, Integral i, Ix i)+ CopyBits :: (pred a, pred b) => (Signal a, exp i) -> (Signal b, exp i)- -> exp i+ -> exp Integer -> VHDLCMD (Param3 prog exp pred) ()- CopyVBits :: (pred a, pred b, Integral i, Ix i)+ CopyVBits :: (pred a, pred b) => (Variable a, exp i) -> (Signal b, exp i)- -> exp i+ -> exp Integer -> VHDLCMD (Param3 prog exp pred) ()+ CopyABits :: (pred a, pred b)+ => (Array a, exp Integer, exp Integer) -- todo: change j into i, problems with Integral.+ -> (Signal b, exp Integer)+ -> exp Integer+ -> VHDLCMD (Param3 prog exp pred) () -- todo: These two should be expressions instead.- GetBit :: (pred a, pred Bit, Integral i, Ix i)+ GetBit :: (pred a, pred Bit) => Signal a- -> exp i+ -> exp Integer -> VHDLCMD (Param3 prog exp pred) (Val Bit)- SetBit :: (pred a, pred Bit, Integral i, Ix i)+ SetBit :: (pred a, pred Bit) => Signal a- -> exp i+ -> exp Integer -> exp Bit -> VHDLCMD (Param3 prog exp pred) () -- todo: same as above two?... -- todo: result should be i?...- GetBits :: (pred i, Integral i, Ix i)+ GetBits :: (pred Integer, pred (Bits n)) => Signal (Bits n)- -> exp i- -> exp i- -> VHDLCMD (Param3 prog exp pred) (Val i)+ -> exp Integer+ -> exp Integer+ -> VHDLCMD (Param3 prog exp pred) (Val Integer) instance HFunctor VHDLCMD where- hfmap f (Rising clk rst tru fls) = Rising clk rst (f tru) (f fls)- hfmap _ (CopyBits a b l) = CopyBits a b l- hfmap _ (CopyVBits a b l) = CopyVBits a b l- hfmap _ (GetBit s i) = GetBit s i- hfmap _ (SetBit s i b) = SetBit s i b- hfmap _ (GetBits s l u) = GetBits s l u+ hfmap _ (DeclarePort n e m) = DeclarePort n e m+ hfmap _ (CopyBits a b l) = CopyBits a b l+ hfmap _ (CopyVBits a b l) = CopyVBits a b l+ hfmap _ (CopyABits a b l) = CopyABits a b l+ hfmap _ (GetBit s i) = GetBit s i+ hfmap _ (SetBit s i b) = SetBit s i b+ hfmap _ (GetBits s l u) = GetBits s l u instance HBifunctor VHDLCMD where- hbimap g _ (Rising clk rst tru fls) = Rising clk rst (g tru) (g fls)- hbimap _ f (CopyBits (a, oa) (b, ob) l) = CopyBits (a, f oa) (b, f ob) (f l)- hbimap _ f (CopyVBits (a, oa) (b, ob) l) = CopyVBits (a, f oa) (b, f ob) (f l)- hbimap _ f (GetBit s i) = GetBit s (f i)- hbimap _ f (SetBit s i b) = SetBit s (f i) (f b)- hbimap _ f (GetBits s l u) = GetBits s (f l) (f u)+ hbimap _ f (DeclarePort n e m) = DeclarePort n (fmap f e) m+ hbimap _ f (CopyBits (a, oa) (b, ob) l) = CopyBits (a, f oa) (b, f ob) (f l)+ hbimap _ f (CopyVBits (a, oa) (b, ob) l) = CopyVBits (a, f oa) (b, f ob) (f l)+ hbimap _ f (CopyABits (a, oa, ia) (b, ob) l) = CopyABits (a, f oa, f ia) (b, f ob) (f l)+ hbimap _ f (GetBit s i) = GetBit s (f i)+ hbimap _ f (SetBit s i b) = SetBit s (f i) (f b)+ hbimap _ f (GetBits s l u) = GetBits s (f l) (f u) instance (VHDLCMD :<: instr) => Reexpressible VHDLCMD instr env where- reexpressInstrEnv reexp (Rising clk rst tru fls) =- ReaderT $ \env -> singleInj $ Rising clk rst- (runReaderT tru env)- (runReaderT fls env)+ reexpressInstrEnv reexp (DeclarePort n e m)+ = do e' <- swapM (fmap reexp e)+ lift $ singleInj $ DeclarePort n e' m reexpressInstrEnv reexp (CopyBits (a, oa) (b, ob) l) = do oa' <- reexp oa; ob' <- reexp ob; l' <- reexp l lift $ singleInj $ CopyBits (a, oa') (b, ob') l' reexpressInstrEnv reexp (CopyVBits (a, oa) (b, ob) l) = do oa' <- reexp oa; ob' <- reexp ob; l' <- reexp l lift $ singleInj $ CopyVBits (a, oa') (b, ob') l'+ reexpressInstrEnv reexp (CopyABits (a, oa, ia) (b, ob) l)+ = do oa' <- reexp oa; ia' <- reexp ia; ob' <- reexp ob; l' <- reexp l+ lift $ singleInj $ CopyABits (a, oa', ia') (b, ob') l' reexpressInstrEnv reexp (GetBit s i) = do i' <- reexp i lift $ singleInj $ GetBit s i'@@ -616,5 +618,36 @@ reexpressInstrEnv reexp (GetBits s l u) = do l' <- reexp l; u' <- reexp u lift $ singleInj $ GetBits s l' u'++--------------------------------------------------------------------------------+-- **+--------------------------------------------------------------------------------++newtype a :-> sig = Partial (a -> sig)+ deriving (Typeable, Functor)++newtype Full a = Full { result :: a }+ deriving (Eq, Show, Typeable)++instance Functor Full+ where+ fmap f (Full a) = Full (f a)++data Foreign fs sig+ where+ Sym :: prog sig -> Foreign (Param3 prog exp pred) sig+ App :: Foreign (Param3 prog exp pred) (a :-> sig) ->+ Foreign (Param3 prog exp pred) (Full a) ->+ Foreign (Param3 prog exp pred) sig++instance HFunctor Foreign+ where+ hfmap f (Sym m) = Sym (f m)+ hfmap f (App s a) = App (hfmap f s) (hfmap f a)++instance HBifunctor Foreign+ where+ hbimap g f (Sym m) = Sym (g m)+ hbimap g f (App s a) = App (hbimap g f s) (hbimap g f a) --------------------------------------------------------------------------------
src/Language/Embedded/Hardware/Command/Frontend.hs view
@@ -11,6 +11,7 @@ import Language.Embedded.Hardware.Interface import Language.Embedded.Hardware.Command.CMD +import Language.Embedded.Hardware.Expression.Frontend (Primary(..), toInteger, cast') import Language.Embedded.Hardware.Expression.Represent import Language.Embedded.Hardware.Expression.Represent.Bit @@ -20,12 +21,15 @@ import Data.IORef (readIORef) import Data.Int import Data.Word+import Data.Proxy import Data.Typeable import System.IO.Unsafe -- used for `veryUnsafeFreezeVariable`. import GHC.TypeLits (KnownNat) +import Prelude hiding (toInteger)+ -------------------------------------------------------------------------------- -- * Hardware frontend. --------------------------------------------------------------------------------@@ -35,7 +39,7 @@ -- | Declare a named signal. initNamedSignal :: (SignalCMD :<: instr, pred a) => String -> exp a -> ProgramT instr (Param2 exp pred) m (Signal a)-initNamedSignal name = singleInj . NewSignal (Base name) InOut . Just+initNamedSignal name = singleInj . NewSignal (Base name) . Just -- | Declare a signal. initSignal :: (SignalCMD :<: instr, pred a) => exp a -> ProgramT instr (Param2 exp pred) m (Signal a)@@ -43,7 +47,7 @@ -- | Declare an uninitialized named signal. newNamedSignal :: (SignalCMD :<: instr, pred a) => String -> ProgramT instr (Param2 exp pred) m (Signal a)-newNamedSignal name = singleInj $ NewSignal (Base name) InOut Nothing+newNamedSignal name = singleInj $ NewSignal (Base name) Nothing -- | Declare an uninitialized signal. newSignal :: (SignalCMD :<: instr, pred a) => ProgramT instr (Param2 exp pred) m (Signal a)@@ -63,37 +67,14 @@ => Signal a -> ProgramT instr (Param2 exp pred) m (exp a) unsafeFreezeSignal = fmap valToExp . singleInj . UnsafeFreezeSignal --- | Concurrent update of a signals value.-concurrentSetSignal :: (SignalCMD :<: instr, pred a) => Signal a -> exp a -> ProgramT instr (Param2 exp pred) m ()-concurrentSetSignal s = singleInj . ConcurrentSetSignal s------------------------------------------------------------------------------------- ports.---- | Declare port signals of the given mode and assign it initial value.-initNamedPort, initExactPort :: (SignalCMD :<: instr, pred a)- => String -> Mode -> exp a -> ProgramT instr (Param2 exp pred) m (Signal a)-initNamedPort name m = singleInj . NewSignal (Base name) m . Just-initExactPort name m = singleInj . NewSignal (Exact name) m . Just--initPort :: (SignalCMD :<: instr, pred a) => Mode -> exp a -> ProgramT instr (Param2 exp pred) m (Signal a)-initPort = initNamedPort "p"---- | Declare port signals of the given mode.-newNamedPort, newExactPort :: (SignalCMD :<: instr, pred a)- => String -> Mode -> ProgramT instr (Param2 exp pred) m (Signal a)-newNamedPort name m = singleInj $ NewSignal (Base name) m Nothing-newExactPort name m = singleInj $ NewSignal (Exact name) m Nothing--newPort :: (SignalCMD :<: instr, pred a) => Mode -> ProgramT instr (Param2 exp pred) m (Signal a)-newPort = newNamedPort "p"+-- | Read the value of a signal without the monad in a very unsafe fashion.+veryUnsafeFreezeSignal :: (PredicateExp exp a, FreeExp exp) => Signal a -> exp a+veryUnsafeFreezeSignal (SignalE r) = litE $! unsafePerformIO $! readIORef r+veryUnsafeFreezeSignal (SignalC v) = varE v -------------------------------------------------------------------------------- -- short-hands. -signal :: (SignalCMD :<: instr, pred a) => String -> ProgramT instr (Param2 exp pred) m (Signal a)-signal = newNamedSignal- (<--) :: (SignalCMD :<: instr, pred a, PredicateExp exp a, FreeExp exp, Monad m) => Signal a -> a@@ -163,144 +144,168 @@ (==:) = setVariable ----------------------------------------------------------------------------------- ** Constants.--initNamedConstant :: (ConstantCMD :<: instr, pred a)- => String -> exp a -> ProgramT instr (Param2 exp pred) m (Constant a)-initNamedConstant name = singleInj . NewConstant (Base name)--initConstant :: (ConstantCMD :<: instr, pred a) => exp a -> ProgramT instr (Param2 exp pred) m (Constant a)-initConstant = initNamedConstant "c"--getConstant :: (ConstantCMD :<: instr, pred a, PredicateExp exp a, FreeExp exp, Monad m)- => Constant a -> ProgramT instr (Param2 exp pred) m (exp a)-getConstant = fmap valToExp . singleInj . GetConstant------------------------------------------------------------------------------------- short-hands.--constant :: (ConstantCMD :<: instr, pred a) => String -> exp a -> ProgramT instr (Param2 exp pred) m (Constant a)-constant = initNamedConstant---------------------------------------------------------------------------------- -- ** Arrays. -- | Create an initialized named virtual array.-initNamedArray :: (ArrayCMD :<: instr, pred a, Integral i, Ix i)- => String -> [a] -> ProgramT instr (Param2 exp pred) m (Array i a) +initNamedArray :: (ArrayCMD :<: instr, pred a)+ => String -> [a] -> ProgramT instr (Param2 exp pred) m (Array a) initNamedArray name = singleInj . InitArray (Base name) -- | Create an initialized virtual array.-initArray :: (ArrayCMD :<: instr, pred a, Integral i, Ix i)- => [a] -> ProgramT instr (Param2 exp pred) m (Array i a)+initArray :: (ArrayCMD :<: instr, pred a)+ => [a] -> ProgramT instr (Param2 exp pred) m (Array a) initArray = initNamedArray "a" -- | Create an uninitialized named virtual array.-newNamedArray :: (ArrayCMD :<: instr, pred a, Integral i, Ix i)- => String -> exp i -> ProgramT instr (Param2 exp pred) m (Array i a)+newNamedArray :: (ArrayCMD :<: instr, pred a)+ => String -> exp Integer -> ProgramT instr (Param2 exp pred) m (Array a) newNamedArray name = singleInj . NewArray (Base name) -- | Create an uninitialized virtual array.-newArray :: (ArrayCMD :<: instr, pred a, Integral i, Ix i)- => exp i -> ProgramT instr (Param2 exp pred) m (Array i a) +newArray :: (ArrayCMD :<: instr, pred a)+ => exp Integer -> ProgramT instr (Param2 exp pred) m (Array a) newArray = newNamedArray "a" -getArray :: (ArrayCMD :<: instr, pred a, Integral i, Ix i, PredicateExp exp a, FreeExp exp, Monad m)- => Array i a -> exp i -> ProgramT instr (Param2 exp pred) m (exp a)-getArray a = fmap valToExp . singleInj . GetArray a+getArray :: (ArrayCMD :<: instr, pred a, PredicateExp exp a, FreeExp exp, Monad m)+ => Array a -> exp Integer -> ProgramT instr (Param2 exp pred) m (exp a)+getArray a i = fmap valToExp $ singleInj $ GetArray a i -- | Set an element of an array.-setArray :: (ArrayCMD :<: instr, pred a, Integral i, Ix i, PredicateExp exp a, FreeExp exp, Monad m)- => Array i a -> exp i -> exp a -> ProgramT instr (Param2 exp pred) m ()+setArray :: (ArrayCMD :<: instr, pred a, PredicateExp exp a, FreeExp exp, Monad m)+ => Array a -> exp Integer -> exp a -> ProgramT instr (Param2 exp pred) m () setArray a i = singleInj . SetArray a i -- | Copy a slice of one array to another.-copyArray :: (ArrayCMD :<: instr, pred a, Integral i, Ix i)- => (Array i a, exp i) -- ^ destination and its offset.- -> (Array i a, exp i) -- ^ source and its offset.- -> exp i -- ^ number of elements to copy.+copyArray :: (ArrayCMD :<: instr, pred a)+ => (Array a, exp Integer) -- ^ destination and its offset.+ -> (Array a, exp Integer) -- ^ source and its offset.+ -> exp Integer -- ^ number of elements to copy. -> ProgramT instr (Param2 exp pred) m () copyArray dest src = singleInj . CopyArray dest src +-- | Freeze an array into an immutable one by copying.+freezeArray :: (ArrayCMD :<: instr, pred a, Num (exp Integer), Monad m)+ => Array a -> exp Integer -> ProgramT instr (Param2 exp pred) m (IArray a)+freezeArray array len =+ do copy <- newArray len+ copyArray (copy,0) (array,0) len+ unsafeFreezeArray copy++-- | Thaw an immutable array into a mutable one by copying.+thawArray :: (ArrayCMD :<: instr, pred a, Num (exp Integer), Monad m)+ => IArray a -> exp Integer -> ProgramT instr (Param2 exp pred) m (Array a)+thawArray iarray len =+ do array <- unsafeThawArray iarray+ copy <- newArray len+ copyArray (copy,0) (array,0) len+ return copy++-- | Freeze a mutable array to an immutable one wothout making a copy.+unsafeFreezeArray :: (ArrayCMD :<: instr, pred a)+ => Array a -> ProgramT instr (Param2 exp pred) m (IArray a)+unsafeFreezeArray = singleInj . UnsafeFreezeArray++-- | Thaw an immutable array to a mutable array without making a copy.+unsafeThawArray :: (ArrayCMD :<: instr, pred a)+ => IArray a -> ProgramT instr (Param2 exp pred) m (Array a)+unsafeThawArray = singleInj . UnsafeThawArray+ -- | ...-resetArray :: (ArrayCMD :<: instr, pred a, Integral i, Ix i)- => Array i a -> exp a -> ProgramT instr (Param2 exp pred) m ()+resetArray :: (ArrayCMD :<: instr, pred a)+ => Array a -> exp a -> ProgramT instr (Param2 exp pred) m () resetArray a rst = singleInj $ ResetArray a rst -------------------------------------------------------------------------------- -- ** Virtual arrays. -- | Create an initialized named virtual array.-initNamedVArray :: (VArrayCMD :<: instr, pred a, Integral i, Ix i)- => String -> [a] -> ProgramT instr (Param2 exp pred) m (VArray i a) +initNamedVArray :: (VArrayCMD :<: instr, pred a)+ => String -> [a] -> ProgramT instr (Param2 exp pred) m (VArray a) initNamedVArray name = singleInj . InitVArray (Base name) -- | Create an initialized virtual array.-initVArray :: (VArrayCMD :<: instr, pred a, Integral i, Ix i)- => [a] -> ProgramT instr (Param2 exp pred) m (VArray i a)+initVArray :: (VArrayCMD :<: instr, pred a)+ => [a] -> ProgramT instr (Param2 exp pred) m (VArray a) initVArray = initNamedVArray "a" -- | Create an uninitialized named virtual array.-newNamedVArray :: (VArrayCMD :<: instr, pred a, Integral i, Ix i)- => String -> exp i -> ProgramT instr (Param2 exp pred) m (VArray i a)+newNamedVArray :: (VArrayCMD :<: instr, pred a)+ => String -> exp Integer -> ProgramT instr (Param2 exp pred) m (VArray a) newNamedVArray name = singleInj . NewVArray (Base name) -- | Create an uninitialized virtual array.-newVArray :: (VArrayCMD :<: instr, pred a, Integral i, Ix i)- => exp i -> ProgramT instr (Param2 exp pred) m (VArray i a)+newVArray :: (VArrayCMD :<: instr, pred a)+ => exp Integer -> ProgramT instr (Param2 exp pred) m (VArray a) newVArray = newNamedVArray "a" -- | Get an element of an array.-getVArray :: (VArrayCMD :<: instr, pred a, Integral i, Ix i, PredicateExp exp a, FreeExp exp, Monad m)- => VArray i a -> exp i -> ProgramT instr (Param2 exp pred) m (exp a)-getVArray a = fmap valToExp . singleInj . GetVArray a+getVArray :: (VArrayCMD :<: instr, pred a, PredicateExp exp a, FreeExp exp, Monad m)+ => VArray a -> exp Integer -> ProgramT instr (Param2 exp pred) m (exp a)+getVArray a i = fmap valToExp $ singleInj $ GetVArray a i -- | Set an element of an array.-setVArray :: (VArrayCMD :<: instr, pred a, Integral i, Ix i)- => VArray i a -> exp i -> exp a -> ProgramT instr (Param2 exp pred) m ()+setVArray :: (VArrayCMD :<: instr, pred a)+ => VArray a -> exp Integer -> exp a -> ProgramT instr (Param2 exp pred) m () setVArray a i = singleInj . SetVArray a i -- | Copy a slice of one array to another.-copyVArray :: (VArrayCMD :<: instr, pred a, Integral i, Ix i)- => (VArray i a, exp i) -- ^ destination and its offset.- -> (VArray i a, exp i) -- ^ source and its offset.- -> exp i -- ^ number of elements to copy.+copyVArray :: (VArrayCMD :<: instr, pred a)+ => (VArray a, exp Integer) -- ^ destination and its offset.+ -> (VArray a, exp Integer) -- ^ source and its offset.+ -> exp Integer -- ^ number of elements to copy. -> ProgramT instr (Param2 exp pred) m () copyVArray dest src = singleInj . CopyVArray dest src -- | Freeze a mutable array into an immutable one by copying.-freezeVArray :: (VArrayCMD :<: instr, pred a, Integral i, Ix i, Num (exp i), Monad m)- => VArray i a -> exp i -> ProgramT instr (Param2 exp pred) m (IArray i a)+freezeVArray :: (VArrayCMD :<: instr, pred a, Num (exp Integer), Monad m)+ => VArray a -> exp Integer -> ProgramT instr (Param2 exp pred) m (IArray a) freezeVArray array len = do copy <- newVArray len copyVArray (copy,0) (array,0) len unsafeFreezeVArray copy -- | Thaw an immutable array into a mutable one by copying.-thawVArray :: (VArrayCMD :<: instr, pred a, Integral i, Ix i, Num (exp i), Monad m)- => IArray i a -> exp i -> ProgramT instr (Param2 exp pred) m (VArray i a)+thawVArray :: (VArrayCMD :<: instr, pred a, Num (exp Integer), Monad m)+ => IArray a -> exp Integer -> ProgramT instr (Param2 exp pred) m (VArray a) thawVArray iarray len = do array <- unsafeThawVArray iarray copy <- newVArray len copyVArray (copy,0) (array,0) len return copy --- | Freeze a mutable array to an immuatable one without making a copy.-unsafeFreezeVArray :: (VArrayCMD :<: instr, pred a, Integral i, Ix i)- => VArray i a -> ProgramT instr (Param2 exp pred) m (IArray i a)+-- | Freeze a mutable variable array to an immuatable one without making a copy.+unsafeFreezeVArray :: (VArrayCMD :<: instr, pred a)+ => VArray a -> ProgramT instr (Param2 exp pred) m (IArray a) unsafeFreezeVArray = singleInj . UnsafeFreezeVArray --- | Thaw an immutable array to a mutable one without making a copy.-unsafeThawVArray :: (VArrayCMD :<: instr, pred a, Integral i, Ix i)- => IArray i a -> ProgramT instr (Param2 exp pred) m (VArray i a)+-- | Thaw an immutable array to a mutable variable array without making a copy.+unsafeThawVArray :: (VArrayCMD :<: instr, pred a)+ => IArray a -> ProgramT instr (Param2 exp pred) m (VArray a) unsafeThawVArray = singleInj . UnsafeThawVArray -------------------------------------------------------------------------------- -- ** Looping. +-- | For loop, but guarantees the range is a known constant.+iterate+ :: ( LoopCMD :<: instr+ , pred Integer, PredicateExp exp Integer+ , FreeExp exp+ , Primary exp+ , Monad m+ )+ => Integer -- ^ Lower bound+ -> Integer -- ^ Upper bound+ -> (exp Integer -> ProgramT instr (Param2 exp pred) m ()) -- ^ Loop body+ -> ProgramT instr (Param2 exp pred) m ()+iterate lower upper = for (value lower) (value upper)+ -- | For loop.-for :: (LoopCMD :<: instr, pred i, Integral i, PredicateExp exp i, FreeExp exp, Monad m)- => exp i -> exp i -> (exp i -> ProgramT instr (Param2 exp pred) m ()) -> ProgramT instr (Param2 exp pred) m ()+for :: (LoopCMD :<: instr, pred Integer, PredicateExp exp Integer, FreeExp exp, Monad m)+ => exp Integer -- ^ Lower bound+ -> exp Integer -- ^ Upper bound+ -> (exp Integer -> ProgramT instr (Param2 exp pred) m ()) -- ^ Loop body+ -> ProgramT instr (Param2 exp pred) m () for lower upper body = singleInj $ For lower upper (body . valToExp) -- | While loop.@@ -379,13 +384,24 @@ type Sig instr exp pred m = Signature (Param3 (ProgramT instr (Param2 exp pred) m) exp pred) type Comp instr exp pred m = Component (Param3 (ProgramT instr (Param2 exp pred) m) exp pred) +-- | Declare a named component with named clock and reset signals.+clockedComponent :: (ComponentCMD :<: instr, Monad m)+ => String+ -> String+ -> String+ -> Sig instr exp pred m a+ -> ProgramT instr (Param2 exp pred) m (Comp instr exp pred m a)+clockedComponent name clock reset sig =+ do (name, args) <- singleInj $+ DeclareComponent (Base name) (Exact clock) (Exact reset) sig+ return $ Component name args sig+ -- | Declare a named component. namedComponent :: (ComponentCMD :<: instr, Monad m)- => String -> Sig instr exp pred m a+ => String+ -> Sig instr exp pred m a -> ProgramT instr (Param2 exp pred) m (Comp instr exp pred m a)-namedComponent name sig =- do n <- singleInj $ StructComponent (Base name) sig- return $ Component n sig+namedComponent name = clockedComponent name "clk" "rst" -- | Declare a component. component :: (ComponentCMD :<: instr, Monad m)@@ -400,9 +416,33 @@ -> ProgramT instr (Param2 exp pred) m () portmap pro arg = singleInj $ PortMap pro arg +-- | Empty argument.+nil :: Argument pred ()+nil = Nil++-- | Add signal to a argument.+(+:) :: (pred a, Integral a, PrimType a)+ => Signal a+ -> Argument pred b+ -> Argument pred (Signal a -> b)+(+:) x xs = ASig x xs++(++:) :: (pred a, Integral a, PrimType a, pred Integer)+ => Array a+ -> Argument pred b+ -> Argument pred (Array a -> b)+(++:) x xs = AArr x xs++infixr +:, ++:+ -------------------------------------------------------------------------------- -exactInput :: (pred a, Integral a, PrimType a)+ret :: ProgramT instr (Param2 exp pred) m () -> Sig instr exp pred m ()+ret = Ret++--------------------------------------------------------------------------------++exactInput :: (pred a, Integral a, PrimType a) => String -> (Signal a -> Sig instr exp pred m b) -> Sig instr exp pred m (Signal a -> b)@@ -419,17 +459,30 @@ -> Sig instr exp pred m (Signal a -> b) input = namedInput "in" -{--exactInputArr :: (pred a, Inhabited a, Sized a, Integral a, Rep a, Typeable a, pred i, Integral i, Ix i) => String -> i -> (Array i a -> Sig instr exp pred m b) -> Sig instr exp pred m (Array i a -> b)-exactInputArr n l = SArr (Exact n) In l+-------------------------------------------------------------------------------- -namedInputArr :: (pred a, Inhabited a, Sized a, Integral a, Rep a, Typeable a, pred i, Integral i, Ix i) => String -> i -> (Array i a -> Sig instr exp pred m b) -> Sig instr exp pred m (Array i a -> b)-namedInputArr n l = SArr (Base n) In l+exactInputArray :: (pred a, Integral a, PrimType a, pred Integer)+ => String+ -> Integer+ -> (Array a -> Sig instr exp pred m b)+ -> Sig instr exp pred m (Array a -> b)+exactInputArray n i = SArr (Exact n) In i -inputArr :: (pred a, Inhabited a, Sized a, Integral a, Rep a, Typeable a, pred i, Integral i, Ix i) => i -> (Array i a -> Sig instr exp pred m b) -> Sig instr exp pred m (Array i a -> b)-inputArr = namedInputArr "in"--}+namedInputArray :: (pred a, Integral a, PrimType a, pred Integer)+ => String+ -> Integer+ -> (Array a -> Sig instr exp pred m b)+ -> Sig instr exp pred m (Array a -> b)+namedInputArray n = SArr (Base n) In +inputArray :: (pred a, Integral a, PrimType a, pred Integer)+ => Integer+ -> (Array a -> Sig instr exp pred m b)+ -> Sig instr exp pred m (Array a -> b)+inputArray = namedInputArray "in"++--------------------------------------------------------------------------------+ exactOutput :: (pred a, Integral a, PrimType a) => String -> (Signal a -> Sig instr exp pred m b)@@ -447,101 +500,92 @@ -> Sig instr exp pred m (Signal a -> b) output = namedOutput "out" -{--exactOutputArr :: (pred a, Inhabited a, Sized a, Integral a, Rep a, Typeable a, pred i, Integral i, Ix i) => String -> i -> (Array i a -> Sig instr exp pred m b) -> Sig instr exp pred m (Array i a -> b)-exactOutputArr n l = SArr (Exact n) Out l+-------------------------------------------------------------------------------- -namedOutputArr :: (pred a, Inhabited a, Sized a, Integral a, Rep a, Typeable a, pred i, Integral i, Ix i) => String -> i -> (Array i a -> Sig instr exp pred m b) -> Sig instr exp pred m (Array i a -> b)-namedOutputArr n l = SArr (Base n) Out l+exactOutputArray :: (pred a, Integral a, PrimType a, pred Integer)+ => String+ -> Integer+ -> (Array a -> Sig instr exp pred m b)+ -> Sig instr exp pred m (Array a -> b)+exactOutputArray n = SArr (Exact n) Out -outputArr :: (pred a, Inhabited a, Sized a, Integral a, Rep a, Typeable a, pred i, Integral i, Ix i) => i -> (Array i a -> Sig instr exp pred m b) -> Sig instr exp pred m (Array i a -> b)-outputArr = namedOutputArr "out"--}+namedOutputArray :: (pred a, Integral a, PrimType a, pred Integer)+ => String+ -> Integer+ -> (Array a -> Sig instr exp pred m b)+ -> Sig instr exp pred m (Array a -> b)+namedOutputArray n = SArr (Base n) Out -ret :: ProgramT instr (Param2 exp pred) m () -> Sig instr exp pred m ()-ret = Ret+outputArray ::+ ( pred a, Integral a, PrimType a, pred Integer)+ => Integer+ -> (Array a -> Sig instr exp pred m b)+ -> Sig instr exp pred m (Array a -> b)+outputArray = namedOutputArray "out" -------------------------------------------------------------------------------- -- ** Structural entities. --- | Declare a new entity by wrapping the program to declare ports & generics.-entity :: (StructuralCMD :<: instr)- => String- -> ProgramT instr (Param2 exp pred) m a- -> ProgramT instr (Param2 exp pred) m a-entity e = singleInj . StructEntity (Exact e)---- | Declare a new architecture for some entity by wrapping the given program.-architecture :: (StructuralCMD :<: instr)- => String -> String- -> ProgramT instr (Param2 exp pred) m a- -> ProgramT instr (Param2 exp pred) m a-architecture e a = singleInj . StructArchitecture (Exact e) (Exact a)---- | Declare a new process listening to some signals by wrapping the given program.-process :: (StructuralCMD :<: instr)- => [Ident]- -> ProgramT instr (Param2 exp pred) m ()+processR :: (ProcessCMD :<: instr)+ => Signals -- ^ Other triggers.+ -> ProgramT instr (Param2 exp pred) m () -- ^ Reset program.+ -> ProgramT instr (Param2 exp pred) m () -- ^ Main program. -> ProgramT instr (Param2 exp pred) m ()-process is = singleInj . StructProcess is+processR is rst prog = singleInj $ Process is rst (Just prog) ---------------------------------------------------------------------------------+process :: (ProcessCMD :<: instr)+ => Signals -- ^ Other triggers.+ -> ProgramT instr (Param2 exp pred) m () -- ^ Main program.+ -> ProgramT instr (Param2 exp pred) m ()+process is prog = singleInj $ Process is prog Nothing -- | Construct the untyped signal list for processes.-(.:) :: ToIdent a => a -> [Ident] -> [Ident]+(.:) :: ToIdent a => a -> Signals -> Signals (.:) x xs = toIdent x : xs infixr .: -------------------------------------------------------------------------------- -- ** VHDL specific instructions.------ todo: these bit operations really do not have to be over just `Bits`, since--- VHDL treats all of our types as bit vectors anyway.+-------------------------------------------------------------------------------- --- | Short-hand that catures the common pattern:--- "when (risingEdge clk) (if (not rst) then tru else fls)"--- assuming reset is triggered on low.-whenRising :: (VHDLCMD :<: instr, pred Bit)- => Signal Bit -- ^ Clock.- -> Signal Bit -- ^ Reset.- -> ProgramT instr (Param2 exp pred) m () -- ^ Reset program.- -> ProgramT instr (Param2 exp pred) m () -- ^ Normal program.- -> ProgramT instr (Param2 exp pred) m ()-whenRising clk rst tru fls = singleInj (Rising clk rst tru fls)+--------------------------------------------------------------------------------+-- *** Bit operations. --- | ...-copyBits :: (VHDLCMD :<: instr, pred a, pred b, Integral i, Ix i)- => (Signal a, exp i)- -> (Signal b, exp i)- -> exp i+copyBits :: (VHDLCMD :<: instr, pred a, pred b)+ => (Signal a, exp Integer)+ -> (Signal b, exp Integer)+ -> exp Integer -> ProgramT instr (Param2 exp pred) m () copyBits a b l = singleInj (CopyBits a b l) --- | ...-copyVBits :: (VHDLCMD :<: instr, pred a, pred b, Integral i, Ix i)- => (Variable a, exp i)- -> (Signal b, exp i)- -> exp i+copyVBits :: (VHDLCMD :<: instr, pred a, pred b)+ => (Variable a, exp Integer)+ -> (Signal b, exp Integer)+ -> exp Integer -> ProgramT instr (Param2 exp pred) m () copyVBits a b l = singleInj (CopyVBits a b l) --- | ...-getBit :: (VHDLCMD :<: instr, pred a, Integral i, Ix i, pred Bit, PredicateExp exp Bit, FreeExp exp, Monad m)- => Signal a -> exp i -> ProgramT instr (Param2 exp pred) m (exp Bit)+copyABits :: (VHDLCMD :<: instr, pred a, pred b)+ => (Array a, exp Integer, exp Integer)+ -> (Signal b, exp Integer)+ -> exp Integer+ -> ProgramT instr (Param2 exp pred) m ()+copyABits a b l = singleInj (CopyABits a b l)++getBit :: (VHDLCMD :<: instr, pred a, pred Bit, PredicateExp exp Bit, FreeExp exp, Monad m)+ => Signal a -> exp Integer -> ProgramT instr (Param2 exp pred) m (exp Bit) getBit bits ix = fmap valToExp $ singleInj $ GetBit bits ix --- | ...-setBit :: (VHDLCMD :<: instr, pred a, Integral i, Ix i, pred Bit)- => Signal a -> exp i -> exp Bit -> ProgramT instr (Param2 exp pred) m ()+setBit :: (VHDLCMD :<: instr, pred a, pred Bit)+ => Signal a -> exp Integer -> exp Bit -> ProgramT instr (Param2 exp pred) m () setBit bits ix bit = singleInj $ SetBit bits ix bit --- | ...-getBits :: (VHDLCMD :<: instr, pred i, Integral i, Ix i, PredicateExp exp i, FreeExp exp, Monad m)- => Signal (Bits u)- -> exp i- -> exp i- -> ProgramT instr (Param2 exp pred) m (exp i)+getBits :: (VHDLCMD :<: instr, pred Integer, pred (Bits u), PredicateExp exp Integer, FreeExp exp, Monad m)+ => Signal (Bits u) -> exp Integer -> exp Integer+ -> ProgramT instr (Param2 exp pred) m (exp Integer) getBits a l u = fmap valToExp $ singleInj $ GetBits a l u +-- todo: these bit operations really do not have to be over just `Bits`, since+-- VHDL treats all of our types as bit vectors anyway. --------------------------------------------------------------------------------
src/Language/Embedded/Hardware/Expression.hs view
@@ -1,9 +1,14 @@ module Language.Embedded.Hardware.Expression ( HExp , HType+ , Bit+ , Bits+ , bitFromInteger+ , bitToInteger , module Language.Embedded.Hardware.Expression.Frontend ) where import Language.Embedded.Hardware.Expression.Syntax (HExp, HType) import Language.Embedded.Hardware.Expression.Frontend+import Language.Embedded.Hardware.Expression.Represent.Bit (Bit, Bits, bitFromInteger, bitToInteger) import Language.Embedded.Hardware.Expression.Backend.VHDL ()
src/Language/Embedded/Hardware/Expression/Frontend.hs view
@@ -2,20 +2,25 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-}+ module Language.Embedded.Hardware.Expression.Frontend where import qualified Language.VHDL as V import Language.Embedded.Hardware.Expression.Syntax (HExp, HType, sugarT)+import Language.Embedded.Hardware.Expression.Represent (TypeRep(..), PrimType(..), isSigned, isUnsigned, isInteger) import Language.Embedded.Hardware.Expression.Represent.Bit (Bits, bitFromInteger, bitToInteger) import qualified Language.Embedded.Hardware.Expression.Syntax as H import qualified Language.Embedded.VHDL.Monad.Expression as V +import Data.Proxy import Data.Typeable (Typeable) import qualified Data.Bits as B (Bits) -import Prelude hiding (not, and, or, abs, rem, div, mod, exp)+import Prelude hiding (not, and, or, abs, rem, div, mod, exp, toInteger) import qualified Prelude as P import GHC.TypeLits@@ -179,6 +184,20 @@ fromBits :: (Primary exp, HType b, Num b, KnownNat a) => exp (Bits a) -> exp b fromBits = cast (fromIntegral . bitToInteger)++-- hmm...+cast' :: forall exp a b . (Primary exp, PrimType a, PrimType b, Integral b, Num a)+ => Proxy a -> exp b -> exp a+cast' _ = case typeRep :: TypeRep a of+ Int8T -> toSigned+ Int16T -> toSigned+ Int32T -> toSigned+ Int64T -> toSigned+ Word8T -> toUnsigned+ Word16T -> toUnsigned+ Word32T -> toUnsigned+ Word64T -> toUnsigned+ IntegerT -> toInteger -------------------------------------------------------------------------------- -- I should probably not support most of these, as they can't implement the
src/Language/Embedded/Hardware/Expression/Represent.hs view
@@ -3,13 +3,14 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE FlexibleContexts #-} module Language.Embedded.Hardware.Expression.Represent where import Language.Embedded.Hardware.Expression.Represent.Bit -import Language.Embedded.VHDL (VHDL)-import Language.Embedded.VHDL.Monad (newSym, newLibrary, newImport)+import Language.Embedded.VHDL (VHDL, MonadV)+import Language.Embedded.VHDL.Monad (newSym, addLibrary, addImport) import Language.Embedded.VHDL.Monad.Type import Language.Embedded.VHDL.Monad.Util (printBits) @@ -109,6 +110,33 @@ deriving instance Show (TypeRep a) deriving instance Typeable (TypeRep a) +isBool :: TypeRep a -> Bool+isBool BoolT = True+isBool _ = False++isSigned :: TypeRep a -> Bool+isSigned Int8T = True+isSigned Int16T = True+isSigned Int32T = True+isSigned Int64T = True+isSigned _ = False++isUnsigned :: TypeRep a -> Bool+isUnsigned Word8T = True+isUnsigned Word16T = True+isUnsigned Word32T = True+isUnsigned Word64T = True++isInteger :: TypeRep a -> Bool+isInteger IntT = True+isInteger IntegerT = True+isInteger _ = False++isFloat :: TypeRep a -> Bool+isFloat FloatT = True+isFloat DoubleT = True+isFloat _ = False+ -------------------------------------------------------------------------------- -- | Primitive hardware types.@@ -140,7 +168,7 @@ primTypeVal :: forall a . PrimType a => a -> String primTypeVal a = case typeRep :: TypeRep a of BoolT -> if a then "\'1\'" else "\'0\'"- _ -> show a+ t -> show a -- | Print a value as its bit representation. primTypeBits :: forall a . PrimType a => a -> String@@ -177,12 +205,12 @@ DoubleT -> double BitsT -> primTypeRepBits (Proxy :: Proxy a) -primTypeRepBits :: forall n . KnownNat n => Proxy (Bits n) -> Type+primTypeRepBits :: forall n. KnownNat n => Proxy (Bits n) -> Type primTypeRepBits _ = std_logic_vector size where size = fromInteger (ni (undefined :: Bits n)) -- | Declare the necessary imports/packages to support a primitive type.-primTypeDeclare :: forall a . PrimType a => Proxy a -> VHDL ()+primTypeDeclare :: forall m a. (MonadV m, PrimType a) => Proxy a -> m () primTypeDeclare p = case typeRep :: TypeRep a of BoolT -> declareBoolean Int8T -> declareNumeric@@ -200,26 +228,26 @@ BitsT -> declareBoolean -- | Declare a primitive hardware type and get back its representation.-declareType :: PrimType a => Proxy a -> VHDL Type+declareType :: (MonadV m, PrimType a) => Proxy a -> m Type declareType proxy = primTypeDeclare proxy >> return (primTypeRep proxy) -- | Declare the necessary libraries to support boolean operations.-declareBoolean :: VHDL ()+declareBoolean :: MonadV m => m () declareBoolean =- do newLibrary "IEEE"- newImport "IEEE.std_logic_1164"+ do addLibrary "IEEE"+ addImport "IEEE.std_logic_1164" -- | Declare the necessary libraries to support numerical operations.-declareNumeric :: VHDL ()+declareNumeric :: MonadV m => m () declareNumeric =- do newLibrary "IEEE"- newImport "IEEE.std_logic_1164"- newImport "IEEE.numeric_std"+ do addLibrary "IEEE"+ addImport "IEEE.std_logic_1164"+ addImport "IEEE.numeric_std" -- | Declare the necessary libraries to support floating point operations.-declareFloating :: VHDL ()+declareFloating :: MonadV m => m () declareFloating =- do newLibrary "IEEE"- newImport "IEEE.float_pkg"+ do addLibrary "IEEE"+ addImport "IEEE.float_pkg" --------------------------------------------------------------------------------
src/Language/Embedded/Hardware/Expression/Represent/Bit.hs view
@@ -55,7 +55,7 @@ import GHC.TypeLits ----------------------------------------------------------------------------------- * Bit vectors of known lenght.+-- * Bit vectors of known length. -------------------------------------------------------------------------------- newtype Bits (n :: Nat) = B Integer
src/Language/Embedded/Hardware/Interface/AXI.hs view
@@ -8,8 +8,9 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE Rank2Types #-} -module Language.Embedded.Hardware.Interface.AXI (axi_light, AXIPred) where+module Language.Embedded.Hardware.Interface.AXI (axi_light, AXIPred, FreePrim(..)) where import Language.Embedded.VHDL (Mode(..)) import Language.Embedded.Hardware.Command.CMD@@ -19,6 +20,10 @@ import Language.Embedded.Hardware.Expression.Represent import Language.Embedded.Hardware.Expression.Represent.Bit (Bits, Bit, bitFromInteger, ni) +-- hmm...+import Language.Embedded.Hardware.Expression.Syntax (HExp, HType)+import Language.Embedded.Hardware.Expression.Backend.VHDL ()+ import Control.Monad.Identity (Identity) import Control.Monad.Operational.Higher hiding (when) import Data.Constraint (Constraint)@@ -28,6 +33,8 @@ import Data.Bits () import Data.Ix (Ix) +import Data.Constraint+ import GHC.TypeLits import qualified GHC.Exts as GHC (Constraint) @@ -37,11 +44,21 @@ -------------------------------------------------------------------------------- -- * AXI-light Controller. ----------------------------------------------------------------------------------- todo : we make a slight simplification and assume that components which we--- connect to AXI-lite has a signature of--- "input -> input -> .. -> input -> output -> ()"--- this can easily be fixed by inspecting the modes given by the--- signature.++-- | Make sure that `pred a` implies `PredicateExp exp a`.+class FreeExp exp => FreePrim exp pred+ where+ witPred :: PrimType a => Proxy exp -> Dict (pred a) -> Dict (PredicateExp exp a)++instance FreePrim HExp HType+ where+ witPred _ _ = Dict++litP :: forall exp pred a . (FreePrim exp pred, PrimType a, pred a)+ => Proxy pred -> a -> exp a+litP _ a = case witPred (Proxy :: Proxy exp) (Dict :: Dict (pred a)) of+ Dict -> litE a+ -------------------------------------------------------------------------------- -- | Short-hand for programs.@@ -49,31 +66,38 @@ -- | Short-hand for constraints. type AXIPred instr exp pred = (+ -- Instructions. SignalCMD :<: instr , ArrayCMD :<: instr , VariableCMD :<: instr , ConditionalCMD :<: instr- , StructuralCMD :<: instr+ , ProcessCMD :<: instr , LoopCMD :<: instr , ComponentCMD :<: instr , VHDLCMD :<: instr---+ -- Expressions. , Expr exp , Rel exp , Factor exp , Primary exp---- , FreeExp exp- -- todo: this equality might be bad. It should be enough to- -- say that 'PredicateExp' holds, and not that it has- -- to be equal to 'pred'.- , pred ~ PredicateExp exp+ -- + , FreeExp exp+ , FreePrim exp pred+ --+ , PredicateExp exp (Bit)+ , PredicateExp exp (Bits 2)+ , PredicateExp exp (Bits 3)+ , PredicateExp exp (Bits 4)+ , PredicateExp exp (Bits 32)+ , PredicateExp exp (Integer)+ -- , pred (Bit) , pred (Bits 2) , pred (Bits 3) , pred (Bits 4) , pred (Bits 32) , pred (Integer)+ -- , Num (exp Integer) ) @@ -85,9 +109,7 @@ :: forall instr exp pred sig . AXIPred instr exp pred => Comp instr exp pred Identity sig -> Sig instr exp pred Identity (- Signal Bit -- ^ Global clock signal.- -> Signal Bit -- ^ Global reset signal.- -> Signal (Bits 32) -- ^ Write address.+ Signal (Bits 32) -- ^ Write address. -> Signal (Bits 3) -- ^ Write channel protection type. -> Signal Bit -- ^ Write address valid. -> Signal Bit -- ^ Write address ready.@@ -109,34 +131,31 @@ -> () ) axi_light comp =- exactInput "S_AXI_ACLK" $ \s_axi_aclk -> - exactInput "S_AXI_ARESETN" $ \s_axi_aresetn -> exactInput "S_AXI_AWADDR" $ \s_axi_awaddr -> exactInput "S_AXI_AWPROT" $ \s_axi_awprot ->- exactInput "S_AXI_AWVALID" $ \s_axi_awvalid -> + exactInput "S_AXI_AWVALID" $ \s_axi_awvalid -> exactOutput "S_AXI_AWREADY" $ \s_axi_awready -> exactInput "S_AXI_WDATA" $ \s_axi_wdata -> exactInput "S_AXI_WSTRB" $ \s_axi_wstrb ->- exactInput "S_AXI_WVALID" $ \s_axi_wvalid -> - exactOutput "S_AXI_WREADY" $ \s_axi_wready -> - exactOutput "S_AXI_BRESP" $ \s_axi_bresp -> - exactOutput "S_AXI_BVALID" $ \s_axi_bvalid -> - exactInput "S_AXI_BREADY" $ \s_axi_bready -> + exactInput "S_AXI_WVALID" $ \s_axi_wvalid ->+ exactOutput "S_AXI_WREADY" $ \s_axi_wready ->+ exactOutput "S_AXI_BRESP" $ \s_axi_bresp ->+ exactOutput "S_AXI_BVALID" $ \s_axi_bvalid ->+ exactInput "S_AXI_BREADY" $ \s_axi_bready -> exactInput "S_AXI_ARADDR" $ \s_axi_araddr -> exactInput "S_AXI_ARPROT" $ \s_axi_arprot ->- exactInput "S_AXI_ARVALID" $ \s_axi_arvalid -> + exactInput "S_AXI_ARVALID" $ \s_axi_arvalid -> exactOutput "S_AXI_ARREADY" $ \s_axi_arready ->- exactOutput "S_AXI_RDATA" $ \s_axi_rdata -> - exactOutput "S_AXI_RRESP" $ \s_axi_rresp -> + exactOutput "S_AXI_RDATA" $ \s_axi_rdata ->+ exactOutput "S_AXI_RRESP" $ \s_axi_rresp -> exactOutput "S_AXI_RVALID" $ \s_axi_rvalid ->- exactInput "S_AXI_RREADY" $ \s_axi_rready -> + exactInput "S_AXI_RREADY" $ \s_axi_rready -> ret $ axi_light_impl comp- s_axi_aclk s_axi_aresetn s_axi_awaddr s_axi_awprot s_axi_awvalid s_axi_awready s_axi_wdata s_axi_wstrb s_axi_wvalid s_axi_wready s_axi_bresp s_axi_bvalid s_axi_bready s_axi_araddr s_axi_arprot s_axi_arvalid s_axi_arready s_axi_rdata- s_axi_rresp s_axi_rvalid s_axi_rready + s_axi_rresp s_axi_rvalid s_axi_rready -------------------------------------------------------------------------------- -- ** Implementation.@@ -147,8 +166,6 @@ -- Component to connect: => Comp instr exp pred Identity sig -- AXI signals:- -> Signal Bit -- ^ Global clock signal.- -> Signal Bit -- ^ Global reset signal. -> Signal (Bits 32) -- ^ Write address. -> Signal (Bits 3) -- ^ Write channel protection type. -> Signal Bit -- ^ Write address valid.@@ -170,7 +187,6 @@ -> Signal Bit -- ^ Read ready. -> Prog instr exp pred () axi_light_impl comp- s_axi_aclk s_axi_aresetn s_axi_awaddr s_axi_awprot s_axi_awvalid s_axi_awready s_axi_wdata s_axi_wstrb s_axi_wvalid s_axi_wready s_axi_bresp s_axi_bvalid s_axi_bready@@ -180,24 +196,24 @@ ---------------------------------------- -- AXI Light signals. --- awaddr <- signal "axi_awaddr" :: Prog instr exp pred (Signal (Bits 32))- awready <- signal "axi_awready" :: Prog instr exp pred (Signal (Bit))- wready <- signal "axi_wready" :: Prog instr exp pred (Signal (Bit))- bresp <- signal "axi_bresp" :: Prog instr exp pred (Signal (Bits 2))- bvalid <- signal "axi_bvalid" :: Prog instr exp pred (Signal (Bit))- araddr <- signal "axi_araddr" :: Prog instr exp pred (Signal (Bits 32))- arready <- signal "axi_arready" :: Prog instr exp pred (Signal (Bit))- rdata <- signal "axi_rdata" :: Prog instr exp pred (Signal (Bits 32))- rresp <- signal "axi_rresp" :: Prog instr exp pred (Signal (Bits 2))- rvalid <- signal "axi_rvalid" :: Prog instr exp pred (Signal (Bit))+ awaddr :: Signal (Bits 32) <- newNamedSignal "axi_awaddr"+ awready :: Signal (Bit) <- newNamedSignal "axi_awready"+ wready :: Signal (Bit) <- newNamedSignal "axi_wready"+ bresp :: Signal (Bits 2) <- newNamedSignal "axi_bresp"+ bvalid :: Signal (Bit) <- newNamedSignal "axi_bvalid"+ araddr :: Signal (Bits 32) <- newNamedSignal "axi_araddr"+ arready :: Signal (Bit) <- newNamedSignal "axi_arready"+ rdata :: Signal (Bits 32) <- newNamedSignal "axi_rdata"+ rresp :: Signal (Bits 2) <- newNamedSignal "axi_rresp"+ rvalid :: Signal (Bit) <- newNamedSignal "axi_rvalid" ---------------------------------------- -- Signals for user logic registers. --- reg_rden <- signal "slv_reg_rden" :: Prog instr exp pred (Signal (Bit))- reg_wren <- signal "slv_reg_wren" :: Prog instr exp pred (Signal (Bit))- reg_out <- signal "reg_data_out" :: Prog instr exp pred (Signal (Bits 32))- reg_index <- signal "byte_index" :: Prog instr exp pred (Signal (Integer))+ reg_rden :: Signal (Bit) <- newNamedSignal "slv_reg_rden"+ reg_wren :: Signal (Bit) <- newNamedSignal "slv_reg_wren"+ reg_out :: Signal (Bits 32) <- newNamedSignal "reg_data_out"+ reg_index :: Signal (Integer) <- newNamedSignal "byte_index" registers <- declareRegisters (signatureOf comp) ----------------------------------------@@ -209,16 +225,18 @@ let mReload = reloadInputs (signatureOf comp) registers -- > fetch the names of all input registers. let mInputs = identInputs (signatureOf comp) registers+ -- > fetch the names of all output registers.+ let mOutputs = identOutputs (signatureOf comp) registers -- > write to output. let mWrite :: Prog instr exp pred () mWrite = loadOutputs araddr reg_out- (signatureOf comp)- (registers)+ (addr_lsb) (addr_bits) -- sizes.+ (signatureOf comp) (registers) -- sig and args. -- > read from input. let mRead :: Prog instr exp pred () mRead = loadInputs awaddr reg_wren s_axi_wdata s_axi_wstrb- (signatureOf comp)- (registers)+ (addr_lsb) (addr_bits) -- sizes.+ (signatureOf comp) (registers) -- sig and args. ---------------------------------------- -- I/O Connections.@@ -240,7 +258,7 @@ u_wv <- unsafeFreezeSignal s_axi_wvalid u_awr <- unsafeFreezeSignal awready u_awv <- unsafeFreezeSignal s_axi_awvalid- concurrentSetSignal reg_wren+ setSignal reg_wren (u_wr `and` u_wv `and` u_awr `and` u_awv) ----------------------------------------@@ -250,124 +268,116 @@ u_arr <- unsafeFreezeSignal arready u_arv <- unsafeFreezeSignal s_axi_arvalid u_rv <- unsafeFreezeSignal rvalid- concurrentSetSignal reg_rden+ setSignal reg_rden (u_arr `and` u_arv `and` not u_rv) ---------------------------------------- -- AXI_AWREADY generation. --- process (s_axi_aclk .: []) (do- whenRising s_axi_aclk s_axi_aresetn- (do awready <== low)- (do rdy <- getSignal awready- awv <- getSignal s_axi_awvalid- wv <- getSignal s_axi_wvalid- iff (isLow rdy `and` isHigh awv `and` isHigh wv)- (do awready <== high)- (do awready <== low)))- + -- processR s_axi_aclk s_axi_aresetn []+ processR []+ (do awready <== low)+ (do rdy <- unsafeFreezeSignal awready+ awv <- unsafeFreezeSignal s_axi_awvalid+ wv <- unsafeFreezeSignal s_axi_wvalid+ iff (isLow rdy `and` isHigh awv `and` isHigh wv)+ (do awready <== high)+ (do awready <== low))+ ---------------------------------------- -- AXI_AWADDR latching. --- process (s_axi_aclk .: []) (do- whenRising s_axi_aclk s_axi_aresetn- (do awaddr <== zeroes)- (do rdy <- getSignal awready- awv <- getSignal s_axi_awvalid- wv <- getSignal s_axi_wvalid- when (isLow rdy `and` isHigh awv `and` isHigh wv)- (awaddr <=- s_axi_awaddr)))+ processR []+ (do awaddr <== zeroes)+ (do rdy <- unsafeFreezeSignal awready+ awv <- unsafeFreezeSignal s_axi_awvalid+ wv <- unsafeFreezeSignal s_axi_wvalid+ when (isLow rdy `and` isHigh awv `and` isHigh wv)+ (do awaddr <=- s_axi_awaddr)) ---------------------------------------- -- AXI_WREADY generation. --- process (s_axi_aclk .: []) (do- whenRising s_axi_aclk s_axi_aresetn- (do wready <== low)- (do rdy <- getSignal awready- awv <- getSignal s_axi_awvalid- wv <- getSignal s_axi_wvalid- iff (isLow rdy `and` isHigh awv `and` isHigh wv)- (wready <== high)- (wready <== low)))+ processR []+ (do wready <== low)+ (do rdy <- unsafeFreezeSignal awready+ awv <- unsafeFreezeSignal s_axi_awvalid+ wv <- unsafeFreezeSignal s_axi_wvalid+ iff (isLow rdy `and` isHigh wv `and` isHigh awv)+ (do wready <== high)+ (do wready <== low)) ---------------------------------------- -- Slave register logic. --- process (s_axi_aclk .: []) (do- whenRising s_axi_aclk s_axi_aresetn- mReset- mRead)+ processR [] (mReset) (mRead) ---------------------------------------- -- Write response logic. --- process (s_axi_aclk .: []) (do- whenRising s_axi_aclk s_axi_aresetn- (do bvalid <== low- bresp <== zeroes)- (do awr <- getSignal awready- awv <- getSignal s_axi_awvalid- wr <- getSignal wready- wv <- getSignal s_axi_wvalid- bv <- getSignal bvalid- br <- getSignal s_axi_bready- ifE ((isHigh awr `and` isHigh awv- `and` isHigh wr- `and` isHigh wv- `and` isLow bv),- do bvalid <== high- bresp <== zeroes)- ((isHigh br `and` isHigh bv),- do bvalid <== low)))+ processR []+ (do bvalid <== low+ bresp <== zeroes)+ (do awr <- unsafeFreezeSignal awready+ awv <- unsafeFreezeSignal s_axi_awvalid+ wr <- unsafeFreezeSignal wready+ wv <- unsafeFreezeSignal s_axi_wvalid+ bv <- unsafeFreezeSignal bvalid+ br <- unsafeFreezeSignal s_axi_bready+ ifE ( isHigh awr `and`+ isHigh awv `and`+ isHigh wr `and`+ isHigh wv `and`+ isLow bv+ , do bvalid <== high+ bresp <== zeroes)+ ( isHigh br `and`+ isHigh bv+ , do bvalid <== low)) ---------------------------------------- -- AXI_AWREADY generation. --- process (s_axi_aclk .: []) (do- whenRising s_axi_aclk s_axi_aresetn- (do arready <== low- araddr <== ones)- (do arr <- getSignal arready- arv <- getSignal s_axi_arvalid- iff (isLow arr `and` isHigh arv)- (do arready <== high- araddr <=- s_axi_araddr)- (do arready <== low)))+ processR []+ (do arready <== low+ araddr <== ones)+ (do arr <- unsafeFreezeSignal arready+ arv <- unsafeFreezeSignal s_axi_arvalid+ iff (isLow arr `and` isHigh arv)+ (do arready <== high+ araddr <=- s_axi_araddr)+ (do arready <== low)) ---------------------------------------- -- AXI_ARVALID generation. --- process (s_axi_aclk .: []) (do- whenRising s_axi_aclk s_axi_aresetn- (do rvalid <== low- rresp <== zeroes)- (do arr <- getSignal arready- arv <- getSignal s_axi_arvalid- rv <- getSignal rvalid- rr <- getSignal s_axi_rready- ifE ((isHigh arr `and` isHigh arv),- do rvalid <== high- rresp <== zeroes)- ((isHigh rv `and` isHigh rr),- do rvalid <== low)))+ processR []+ (do rvalid <== low+ rresp <== zeroes)+ (do arr <- unsafeFreezeSignal arready+ arv <- unsafeFreezeSignal s_axi_arvalid+ rv <- unsafeFreezeSignal rvalid+ rr <- unsafeFreezeSignal s_axi_rready+ ifE ( isHigh arr `and` isHigh arv `and` isLow rv+ , do rvalid <== high+ rresp <== zeroes)+ ( isHigh rv `and` isHigh rr+ , do rvalid <== low)) ---------------------------------------- -- Memory mapped rigister select and -- read logic generaiton. --- process (araddr .: s_axi_aresetn .: reg_rden .: mInputs) (do- mWrite)+ process (araddr .: mOutputs) (mWrite) ---------------------------------------- -- Output register of memory read data. --- process (s_axi_aclk .: []) (do- whenRising s_axi_aclk s_axi_aresetn- (do rdata <== zeroes)- (do rden <- getSignal reg_rden- when (isHigh rden)- (do rdata <=- reg_out)))+ processR []+ (do rdata <== zeroes)+ (do rden <- unsafeFreezeSignal reg_rden+ when (isHigh rden)+ (do rdata <=- reg_out)) ---------------------------------------- -- User logic.@@ -377,12 +387,24 @@ -- The end. ---------------------------------------- where- -- Application-specific design signals.+ -- Application-specific design signals. The first depends on the bus width,+ -- the second on the number of bits needed to store an address. There's no+ -- '+ 1' on 'addr_bits' since the ranges add that by default (i.e. '0 to 0'+ -- contains one element). addr_lsb, addr_bits :: Integer- addr_lsb = 2- addr_bits = 2 + 1- --addr_lsb + (widthOf comp)+ addr_lsb = 2 -- always '2' for a 32-bit bus.+ addr_bits = bits (widthOf comp) - 1+ where+ bits :: Integer -> Integer+ bits 0 = 1+ bits 1 = 1+ bits x = floor $ (1+) $ logBase 2.0 $ fromIntegral x + -- AXI-lite constants.+ axi_data_width, axi_addr_width :: Integer+ axi_data_width = 32 -- always use 32-bit wide busses for AXI-lite.+ axi_addr_width = addr_lsb + addr_bits + 1 -- added one for consistency.+ -------------------------------------------------------------------------------- -- ** Helpers. --------------------------------------------------------------------------------@@ -398,7 +420,7 @@ a <- declareRegisters (sf s) return (ASig s a) declareRegisters (SArr _ _ l af) =- do s <- newArray (litE l)+ do s <- newArray (litP (Proxy :: Proxy pred) l) a <- declareRegisters (af s) return (AArr s a) @@ -413,10 +435,10 @@ resetInputs (SSig _ Out sf) (ASig s arg) = resetInputs (sf s) arg resetInputs (SArr _ Out _ af) (AArr a arg) = resetInputs (af a) arg resetInputs (SSig _ In sf) (ASig s arg) =- do setSignal s (litE reset)+ do setSignal s (litP (Proxy :: Proxy pred) reset) resetInputs (sf s) arg resetInputs (SArr _ In _ af) (AArr a arg) =- do resetArray a (litE reset)+ do resetArray a (litP (Proxy :: Proxy pred) reset) resetInputs (af a) arg --------------------------------------------------------------------------------@@ -429,13 +451,18 @@ reloadInputs (Ret _) (Nil) = return () reloadInputs (SSig _ Out sf) (ASig s arg) = reloadInputs (sf s) arg reloadInputs (SArr _ Out _ af) (AArr a arg) = reloadInputs (af a) arg-reloadInputs (SSig _ In sf) (ASig s arg) =- do sv <- unsafeFreezeSignal s- setSignal s sv- reloadInputs (sf s) arg+reloadInputs (SSig _ In sf) (ASig (s :: Signal b) arg) =+ case witPred (Proxy :: Proxy exp) (Dict :: Dict (pred b)) of+ Dict -> do+ sv <- unsafeFreezeSignal s+ setSignal s sv+ reloadInputs (sf s) arg reloadInputs (SArr _ In l af) (AArr a arg) =- do copyArray (a, litE 0) (a, litE 0) (litE l)+ do copyArray (a, lit 0) (a, lit 0) (lit $ l - 1) reloadInputs (af a) arg+ where+ lit :: (FreePrim exp pred, PrimType b, pred b) => b -> exp b+ lit = litP (Proxy :: Proxy pred) -------------------------------------------------------------------------------- @@ -445,12 +472,14 @@ -> Signal (Bit) -- ^ Ready. -> Signal (Bits 32) -- ^ Input. -> Signal (Bits 4) -- ^ Protected bits.+ -> Integer -- ^ Address lsb.+ -> Integer -- ^ Address width. -> Sig instr exp pred Identity a -> Argument pred a -> Prog instr exp pred ()-loadInputs waddr rwren wdata wren sig arg =- do loc <- getBits waddr addr_lsb addr_msb- ready <- getSignal rwren+loadInputs waddr rwren wdata wren addr_lsb addr_bits sig arg =+ do loc <- getBits waddr (lit addr_lsb) (lit $ addr_bits - 1)+ ready <- unsafeFreezeSignal rwren when (isHigh ready) $ switched loc (cases 0 sig arg)@@ -461,14 +490,18 @@ -> Argument pred b -> [When Integer (Prog instr exp pred)] cases ix (Ret _) (Nil) = []- cases ix (SArr _ _ l af) (AArr a arg) = error "axi-todo: loading arrays."- cases ix (SSig _ Out sf) (ASig s arg) = cases (ix+1) (sf s) arg- cases ix (SSig _ In sf) (ASig s arg) =- is (ix) (loadInputSignal wdata wren s) : cases (ix+1) (sf s) arg+ cases ix (SSig _ Out sf) (ASig s arg) = cases (ix + 1) (sf s) arg+ cases ix (SArr _ Out l af) (AArr a arg) = cases (ix + P.toInteger l) (af a) arg+ cases ix (SSig _ In sf) (ASig s arg) =+ let new = is (ix) (loadInputSignal wdata wren s)+ in new : cases (ix + 1) (sf s) arg+ cases ix (SArr _ In l af) (AArr a arg) =+ let len = P.toInteger l+ new = map (\(i, j) -> is i (loadInputArray wdata wren a j)) $ zip [ix..ix+len-1] [0..]+ in new ++ cases (ix + len) (af a) arg - addr_lsb, addr_msb :: exp Integer- addr_lsb = litE 2- addr_msb = litE 3+ lit :: (FreePrim exp pred, PrimType b, pred b) => b -> exp b+ lit = litP (Proxy :: Proxy pred) loadInputSignal :: forall instr (exp :: * -> *) pred a . (AXIPred instr exp pred, pred a, Sized a)@@ -479,75 +512,149 @@ loadInputSignal wdata wren reg = for 0 size $ \byte_index -> do bit <- getBit wren byte_index when (isHigh bit) $- copyBits (reg, byte_index*8) (wdata, byte_index*8) (litE 7)+ copyBits (reg, byte_index*8) (wdata, byte_index*8) (lit 7) where size :: exp Integer- size = litE $ (P.div (bits reg) 8) - 1--- todo: I assume that `a` has a type \width\ that is some multiple of eight,--- hence the hard-coded seven when copying.+ size = lit $ (P.div (bits reg) 8) - 1+ -- todo: I assume that `a` has a type \width\ that is some multiple of eight. + lit :: (FreePrim exp pred, PrimType b, pred b) => b -> exp b+ lit = litP (Proxy :: Proxy pred)++loadInputArray :: forall instr (exp :: * -> * ) pred i a .+ (AXIPred instr exp pred, pred a, Sized a)+ => Signal (Bits 32)+ -> Signal (Bits 4)+ -> Array a+ -> Integer+ -> Prog instr exp pred ()+loadInputArray wdata wren arr ix = for 0 size $ \byte_index ->+ do bit <- getBit wren byte_index+ when (isHigh bit) $+ copyABits (arr, byte_index*8, lit ix) (wdata, byte_index*8) (lit 7)+ where+ size :: exp Integer+ size = lit $ (P.div (bits arr) 8) - 1+ -- todo: I assume that `a` has a type \width\ that is some multiple of eight.++ lit :: (FreePrim exp pred, PrimType b, pred b) => b -> exp b+ lit = litP (Proxy :: Proxy pred)+ -------------------------------------------------------------------------------- -- | ... loadOutputs :: forall instr (exp :: * -> *) pred a . AXIPred instr exp pred => Signal (Bits 32) -- ^ Address. -> Signal (Bits 32) -- ^ Output.+ -> Integer -- ^ Address lsb.+ -> Integer -- ^ Address width. -> Sig instr exp pred Identity a -> Argument pred a -> Prog instr exp pred ()-loadOutputs araddr rout sig arg =- do loc <- getBits araddr addr_lsb addr_msb+loadOutputs araddr rout addr_lsb addr_bits sig arg =+ do loc <- getBits araddr (lit addr_lsb) (lit $ addr_bits - 1) switched loc (cases 0 sig arg)- (setSignal rout (litE reset))+ (resetOut) where cases :: Integer -> Sig instr exp pred Identity b -> Argument pred b -> [When Integer (Prog instr exp pred)]- cases ix (Ret _) (Nil) = []- cases ix (SArr _ _ l af) (AArr a arg) = error "axi-todo: loading arrays."- cases ix (SSig _ Out sf) (ASig s arg) = cases (ix+1) (sf s) arg- cases ix (SSig _ In sf) (ASig s arg) =- is (ix) (loadOutputSignal rout s) : cases (ix+1) (sf s) arg+-- todo: due to a bug in the Xilinx tools I use (Vivado 2015.4), we cannot skip+-- any cases. So even if a signal is tagged as an input singal, it must be+-- part of the generated case statement to avoid holes. That is, we can't have:+-- cases ix (Ret _) (Nil) = []+-- cases ix (SSig _ In sf) (ASig s arg) = cases (ix + 1) (sf s) arg+-- cases ix (SArr _ In l af) (AArr a arg) = cases (ix + P.toInteger l) (af a) arg+ cases ix (Ret _) (Nil)+ | ix < addr_max = to ix addr_max (resetOut) : []+ | otherwise = []+ cases ix (SSig _ In sf) (ASig s arg) =+ is ix (resetOut) : cases (ix + 1) (sf s) arg+ cases ix (SArr _ In l af) (AArr a arg) = let len = P.toInteger l in+ to ix (ix + len - 1) (resetOut) : cases (ix + len) (af a) arg+ cases ix (SSig _ Out sf) (ASig s arg) =+ let new = is ix (loadOutputSignal rout s)+ in new : cases (ix + 1) (sf s) arg+ cases ix (SArr _ Out l af) (AArr a arg) =+ let len = P.toInteger l+ new = map (\(i, j) -> is i (loadOutputArray rout a j)) $ zip [ix..ix+len-1] [0..]+ in new ++ cases (ix + len) (af a) arg - addr_lsb, addr_msb :: exp Integer- addr_lsb = litE 2- addr_msb = litE 3+ lit :: (FreePrim exp pred, PrimType b, pred b) => b -> exp b+ lit = litP (Proxy :: Proxy pred) + addr_max :: Integer+ addr_max = addr_bits ^ 2 - 1++ resetOut :: Prog instr exp pred ()+ resetOut = setSignal rout (lit reset)+ loadOutputSignal :: forall instr (exp :: * -> *) pred a . (AXIPred instr exp pred, pred a, PrimType a, Integral a) => Signal (Bits 32) -> Signal a -> Prog instr exp pred () loadOutputSignal rout reg =- do r <- unsafeFreezeSignal reg- setSignal rout (toBits r :: exp (Bits 32))+ case witPred (Proxy :: Proxy exp) (Dict :: Dict (pred a)) of+ Dict -> do+ r <- unsafeFreezeSignal reg+ setSignal rout (toBits r :: exp (Bits 32)) +loadOutputArray :: forall instr (exp :: * -> *) pred a .+ ( AXIPred instr exp pred, pred a, PrimType a, Integral a)+ => Signal (Bits 32)+ -> Array a+ -> Integer+ -> Prog instr exp pred ()+loadOutputArray rout arr ix =+ case witPred (Proxy :: Proxy exp) (Dict :: Dict (pred a)) of+ Dict -> do+ r <- getArray arr (lit $ P.fromInteger ix)+ setSignal rout (toBits r :: exp (Bits 32))+ where+ lit :: (FreePrim exp pred, PrimType b, pred b) => b -> exp b+ lit = litP (Proxy :: Proxy pred)+ -------------------------------------------------------------------------------- identInputs :: forall instr (exp :: * -> *) pred m a . Sig instr exp pred m a -> Argument pred a -> [Ident]-identInputs (Ret _) (Nil) = []+identInputs (Ret _) (Nil) = [] identInputs (SSig _ In sf) (ASig s arg) = toIdent s : identInputs (sf s) arg identInputs (SSig _ _ sf) (ASig s arg) = identInputs (sf s) arg identInputs (SArr _ In _ af) (AArr a arg) = toIdent a : identInputs (af a) arg identInputs (SArr _ _ _ af) (AArr a arg) = identInputs (af a) arg +identOutputs :: forall instr (exp :: * -> *) pred m a .+ Sig instr exp pred m a+ -> Argument pred a+ -> [Ident]+identOutputs (Ret _) (Nil) = []+identOutputs (SSig _ Out sf) (ASig s arg) = toIdent s : identOutputs (sf s) arg+identOutputs (SSig _ _ sf) (ASig s arg) = identOutputs (sf s) arg+identOutputs (SArr _ Out _ af) (AArr a arg) = toIdent a : identOutputs (af a) arg+identOutputs (SArr _ _ _ af) (AArr a arg) = identOutputs (af a) arg+ -------------------------------------------------------------------------------- -signatureOf :: Comp instr exp pred m a -> Sig instr exp pred m a-signatureOf (Component _ sig) = sig+signatureOf+ :: Comp instr exp pred m sig+ -> Sig instr exp pred m sig+signatureOf (Component _ _ sig) = sig -widthOf :: Comp instr exp pred m a -> Integer-widthOf = go . signatureOf+widthOf+ :: Comp instr exp pred m sig+ -> Integer+widthOf comp = go (signatureOf comp) where go :: Sig instr exp pred m b -> Integer go (Ret _) = 0- go (SSig _ _ f) = 1 + go (f dummy)--- go (SArr _ _ l g) = l + go (g dummy)+ go (SSig _ _ f) = 1 + go (f dummy)+ go (SArr _ _ l g) = P.toInteger l + go (g dummy) dummy :: a dummy = error "todo: evaluated dummy"@@ -564,81 +671,7 @@ zeroes = value 0 ones :: forall exp n. (Primary exp, Typeable n, KnownNat n) => exp (Bits n)-ones = value $ bitFromInteger (read (replicate size '1') :: Integer)- where size = fromIntegral (ni (Proxy::Proxy n)) - 1+ones = value $ bitFromInteger (2 ^ size - 1)+ where size = fromIntegral (ni (Proxy::Proxy n)) ----------------------------------------------------------------------------------- Program stubs.----------------------------------------------------------------------------------{--loadInputs wdata wren tmp i (SSig _ In sf) (ASig s arg) =- When (Is i) cases : loadInputs wdata wren tmp (i+1) (sf s) arg- where- size :: Integer- size = bits s-- loadBit :: Prog instr exp pred ()- loadBit = do- wb <- getBit wren (0 :: exp Integer)- undefined- when (isHigh wb) $- do bit <- getBit wdata (0 :: exp Integer)- setBit s (0 :: exp Integer) bit-- loadBits :: Integer -> Integer -> Prog instr exp pred ()- loadBits ix len = do- wb <- getBit wren (value ix)- undefined- when (isHigh wb) $- copyBits (s, value $ ix*8) (wdata, value $ ix*8) (value $ len-1)-- cases :: Prog instr exp pred ()- cases | size == 1 = loadBit- | otherwise = sequence_ $ map (uncurry loadBits) $ zip [0..] $ chunk size-loadInputs wdata wren tmp i (SArr _ Out l af) (AArr a arg) =- loadInputs wdata wren tmp (i+(Prelude.toInteger l)) (af a) arg-loadInputs wdata wren tmp i (SArr _ In l af) (AArr (a :: Array i b) arg)- let cs = map (\ix -> When (Is $ i+ix) $ cases ix) [0..l'-1]- in cs ++ loadInputs wdata wren tmp (i+l') (af a) arg- where- l', size :: Integer- l' = Prelude.toInteger l - size = bits a-- loadBit :: Integer -> Prog instr exp pred ()- loadBit ax = error "axi-todo: loadBit for array."-- loadBits :: Integer -> Integer -> Integer -> Prog instr exp pred ()- loadBits ax ix len = do- wb <- getBit wren (value ix)- when (isHigh wb) $- copyVBits (tmp, value $ ix*8) (wdata, value $ ix*8) (value $ len-1)-- cases :: Integer -> Prog instr exp pred ()- cases ax | size == 1 = loadBit ax- | otherwise = do- sequence_ $ map (uncurry $ loadBits ax) $ zip [0..] $ chunk size- val :: exp (Bits 32) <- unsafeFreezeVariable tmp- let ix = litE (fromInteger ax) :: exp i- let b = fromBits val :: exp b- undefined --setArray a ix b--}-{--loadOutputs o i (Ret _) (Nil) = []-loadOutputs o i (SSig _ Out sf) (ASig s arg) =- let p = setSignal o . toBits =<< unsafeFreezeSignal s- in When (Is i) p : loadOutputs o (i+1) (sf s) arg-loadOutputs o i (SSig _ _ sf) (ASig s arg) =- loadOutputs o (i+1) (sf s) arg-loadOutputs o i (SArr _ Out l af) (AArr a arg) =- let f ix = When (Is ix) (setSignal o . toBits =<< getArray a (value ix))- in map f [i..i+l-1] ++ loadOutputs o (i+l) (af a) arg-loadOutputs o i (SArr _ _ l af) (AArr a arg) =- loadOutputs o (i+l) (af a) arg--chunk :: Integer -> [Integer]-chunk i | i > 8 = 8 : chunk (i - 8)- | i <= 8 = [i]--}----------------------------------------------------------------------------------
src/Language/Embedded/VHDL/Monad.hs view
@@ -8,7 +8,8 @@ module Language.Embedded.VHDL.Monad ( VHDL , VHDLT- , VHDLEnv+ , VHDLEnv(..)+ , MonadV , emptyVHDLEnv -- ^ run@@ -17,34 +18,39 @@ -- ^ pretty printing , prettyVHDL, prettyVHDLT + -- ^ entity container+ , wrapMain+ -- ^ name generation , freshUnique, newSym, newLabel -- ^ imports- , newLibrary, newImport+ , addLibrary, addImport -- ^ ...---, addPort, addGeneric+ , addPort , addConstant, addSignal, addVariable , addConcurrent, addSequential , addType, addComponent -- ^ ...- , findType- , inheritContext+ , lookupArrayType - -- ^ declarations- , declareComponent+ -- ^ ...+ , importComponent -- ^ statements , inProcess, inFor, inWhile, inConditional, inCase , exit, null + -- ^ specialized statements+ , inSingleProcess+ -- ^ structures- , entity, architecture, package, component+ , entity, architecture, component -- ^ common things- , constant, signal, variable, array+ , port, constant, signal, variable, array , assignSignal, assignVariable, assignArray , concurrentSignal, concurrentArray , portMap@@ -52,7 +58,12 @@ import Language.VHDL -import Language.Embedded.VHDL.Monad.Util (maybePrimary)+import Language.Embedded.VHDL.Monad.Expression+ (eq, literal, number, simple, name, function)+import Language.Embedded.VHDL.Monad.Type+ (std_logic, eqType, eqRange)+import Language.Embedded.VHDL.Monad.Util+ (expr, primExpr, primShift, primSimple, primTerm, primFactor, maybePrimary) import Control.Applicative ((<$>)) import Control.Monad.Identity (Identity)@@ -60,11 +71,12 @@ import qualified Control.Monad.Identity as CMI import qualified Control.Monad.State as CMS +import Data.Char (isLetter) import Data.Either (partitionEithers)-import Data.Maybe (catMaybes)+import Data.Maybe (catMaybes, isJust) import Data.Foldable (toList) import Data.Functor (fmap)-import Data.List (groupBy, isPrefixOf, stripPrefix, find)+import Data.List (groupBy, isPrefixOf, stripPrefix, find, partition) import Data.Set (Set) import Data.Map (Map) import qualified Data.Set as Set@@ -87,9 +99,10 @@ { _unique :: !Integer , _designs :: [DesignFile] , _units :: [DesignUnit]- , _context :: Set ContextItem- , _types :: Set TypeDeclaration- , _components :: Set ComponentDeclaration+ , _context :: [ContextItem]+ , _types :: [TypeDeclaration]+ , _components :: [ComponentDeclaration]+ , _ports :: [InterfaceDeclaration] , _constants :: [InterfaceDeclaration] , _signals :: [InterfaceDeclaration] , _variables :: [InterfaceDeclaration]@@ -102,9 +115,10 @@ { _unique = 0 , _designs = [] , _units = []- , _context = Set.empty- , _types = Set.empty- , _components = Set.empty+ , _context = []+ , _types = []+ , _components = []+ , _ports = [] , _constants = [] , _signals = [] , _variables = []@@ -118,9 +132,6 @@ -- | Type constraints for the VHDL monads type MonadV m = (Functor m, Applicative m, Monad m, MonadState VHDLEnv m) --- | VHDL code generation monad-type VHDL = VHDLT Identity- -- | VHDL code genreation monad transformer. newtype VHDLT m a = VHDLT { unVGenT :: StateT VHDLEnv m a } deriving ( Functor@@ -130,11 +141,14 @@ , MonadIO ) +-- | VHDL code generation monad+type VHDL = VHDLT Identity+ -- | Run the VHDL code generation monad transformer. runVHDLT :: Monad m => VHDLT m a -> VHDLEnv -> m (a, VHDLEnv) runVHDLT m = CMS.runStateT (unVGenT m) --- | -- | Executes the VHDL code generation monad transformer, returning only its final state.+-- | Executes the VHDL code generation monad transformer, returning only its final state. execVHDLT :: Monad m => VHDLT m a -> VHDLEnv -> m VHDLEnv execVHDLT m = CMS.execStateT (unVGenT m) @@ -168,146 +182,51 @@ -- ** VHDL environment updates. -- | Adds a new library import to the context.-newLibrary :: MonadV m => String -> m ()-newLibrary l = CMS.modify $ \s -> s { _context = Set.insert item (_context s) }+addLibrary :: MonadV m => String -> m ()+addLibrary l = CMS.modify $ \s -> s { _context = add lib (_context s) } where- item :: ContextItem- item = ContextLibrary (LibraryClause (LogicalNameList [Ident l]))+ lib :: ContextItem+ lib = ContextLibrary (LibraryClause (LogicalNameList [Ident l])) -- | Adds a new library use clause to the context (with an .ALL suffix by default).-newImport :: MonadV m => String -> m ()-newImport i = CMS.modify $ \s -> s { _context = Set.insert item (_context s) }+addImport :: MonadV m => String -> m ()+addImport i = CMS.modify $ \s -> s { _context = add imp (_context s) } where- item :: ContextItem- item = ContextUse (UseClause [SelectedName (PName (NSimple (Ident i))) (SAll)])+ imp :: ContextItem+ imp = ContextUse (UseClause [SelectedName (PName (NSimple (Ident i))) SAll]) -- | Adds a type declaration. addType :: MonadV m => TypeDeclaration -> m ()-addType t = CMS.modify $ \s -> s { _types = Set.insert t (_types s) }+addType t = CMS.modify $ \s -> s { _types = t : _types s } -- | Adds a component declaration. addComponent :: MonadV m => ComponentDeclaration -> m ()-addComponent c = CMS.modify $ \s -> s { _components = Set.insert c (_components s) }+addComponent c = CMS.modify $ \s -> s { _components = c : _components s } +-- | Adds a port declaration.+addPort :: MonadV m => InterfaceDeclaration -> m ()+addPort p = CMS.modify $ \s -> s { _ports = p : _ports s }+ -- | ... addConstant :: MonadV m => InterfaceDeclaration -> m ()-addConstant c = CMS.modify $ \s -> s { _constants = c : (_constants s) }+addConstant c = CMS.modify $ \s -> s { _constants = c : _constants s } -- | Adds a global declaration. addSignal :: MonadV m => InterfaceDeclaration -> m ()-addSignal v = CMS.modify $ \s -> s { _signals = v : (_signals s) }+addSignal v = CMS.modify $ \s -> s { _signals = v : _signals s } -- | Adds a local declaration. --addVariable :: MonadV m => BlockDeclarativeItem -> m () addVariable :: MonadV m => InterfaceDeclaration -> m ()-addVariable v = CMS.modify $ \s -> s { _variables = v : (_variables s) }+addVariable v = CMS.modify $ \s -> s { _variables = v : _variables s } -- | Adds a concurrent statement. addConcurrent :: MonadV m => ConcurrentStatement -> m ()-addConcurrent con = CMS.modify $ \s -> s { _concurrent = con : (_concurrent s) }+addConcurrent con = CMS.modify $ \s -> s { _concurrent = con : _concurrent s } -- | Adds a sequential statement. addSequential :: MonadV m => SequentialStatement -> m ()-addSequential seq = CMS.modify $ \s -> s { _sequential = seq : (_sequential s) }------------------------------------------------------------------------------------- ** ...------ having units be indexed by their names would help.--inheritContext :: MonadV m => Identifier -> m ()-inheritContext e =- do u <- findEntity e- case u of- Nothing -> return ()- Just entity -> inherit $ getContext entity- where- inherit :: MonadV m => ContextClause -> m ()- inherit (ContextClause cs) = go cs- where- go :: MonadV m => [ContextItem] -> m ()- go [] = return ()- go (l@(ContextLibrary _):cs) = go cs- go (c@(ContextUse _) :cs) = add c >> go cs-- add :: MonadV m => ContextItem -> m ()- add c = CMS.modify $ \s -> s { _context = Set.insert c (_context s) }--extendContext :: MonadV m => Identifier -> m ()-extendContext e =- do u <- findEntity e- case u of- Nothing -> return ()- Just entity ->- do n <- extendUnit entity- updateUnit n- where- updateUnit :: MonadV m => DesignUnit -> m ()- updateUnit u =- do units <- CMS.gets _units- let new = update u units- CMS.modify $ \s -> s { _units = new }-- update :: DesignUnit -> [DesignUnit] -> [DesignUnit]- update u [] = []- update u (x:xs)- | Just a <- name u- , Just b <- name x- , a == b = u : xs- | otherwise = x : update u xs- where- name :: DesignUnit -> Maybe Identifier- name (DesignUnit _ (LibraryPrimary (PrimaryEntity (EntityDeclaration i _ _ _)))) = Just i- name _ = Nothing- - extendUnit :: MonadV m => DesignUnit -> m (DesignUnit)- extendUnit (DesignUnit (ContextClause cs) lib) =- do ctxt <- CMS.gets _context- let new = foldr extend cs ctxt- return (DesignUnit (ContextClause new) lib)-- extend :: ContextItem -> [ContextItem] -> [ContextItem]- extend c cs = if (elem c cs) then (cs) else (cs ++ [c])------------------------------------------------------------------------------------- ** ...--findType :: MonadV m => TypeDeclaration -> m (Maybe Identifier)-findType t =- do set <- CMS.gets $ \s -> Set.filter (\t' -> compare t t' == EQ) (_types s)- return $ case Set.null set of- False -> Just $ typeName $ Set.findMin set- True -> Nothing--findEntity :: MonadV m => Identifier -> m (Maybe DesignUnit)-findEntity e =- do curr <- CMS.gets _units- prev <- CMS.gets _designs- return $ safeHead $ filter select $ curr ++ concatMap getUnits prev- where- select :: DesignUnit -> Bool- select (DesignUnit _ (LibraryPrimary (PrimaryEntity (EntityDeclaration i _ _ _)))) | e == i = True- select _ = False-- safeHead :: [a] -> Maybe a- safeHead [] = Nothing- safeHead (x:_) = Just x- -----------------------------------------------------------------------------------getUnits :: DesignFile -> [DesignUnit]-getUnits (DesignFile units) = units--getContext :: DesignUnit -> ContextClause-getContext (DesignUnit ctxt _) = ctxt--typeName :: TypeDeclaration -> Identifier-typeName (TDFull (FullTypeDeclaration i _)) = i-typeName (TDPartial (IncompleteTypeDeclaration i)) = i--packageName :: DesignUnit -> Maybe Identifier-packageName (DesignUnit _ (LibraryPrimary (PrimaryPackage (PackageDeclaration i _)))) = Just i-packageName _ = Nothing+addSequential seq = CMS.modify $ \s -> s { _sequential = seq : _sequential s } -------------------------------------------------------------------------------- -- * Concurrent and sequential statements@@ -440,9 +359,47 @@ maybeList :: [SequentialStatement] -> [CaseStatementAlternative] maybeList [] = [] maybeList xs = [CaseStatementAlternative (Choices [ChoiceOthers]) xs]- --------------------------------------------------------------------------------++-- | Runs the given action, with its corresponding reset, in a process that+-- triggers on positive clock edges.+inSingleProcess :: MonadV m+ => Label -- ^ Process label.+ -> Identifier -- ^ Clock.+ -> Maybe (Identifier, m ())+ -- ^ Reset and program.+ -> [Identifier] -- ^ Sensitivity list.+ -> m () -- ^ Main program.+ -> m ()+inSingleProcess l clk rst is n =+ inProcess' (clk : is) $+ inConditional'+ ( whenRising' clk+ , case rst of+ Just (r, m) -> inConditional' (isLow r, n) m+ Nothing -> n+ )+ (return ())+ where+ inProcess' :: MonadV m => [Identifier] -> m () -> m ()+ inProcess' is m = inProcess l is m >>= addConcurrent . ConProcess . snd++ inConditional' :: MonadV m => (Condition, m ()) -> m () -> m ()+ inConditional' c e = inConditional c [] e >>= addSequential . SIf++ whenRising' :: Identifier -> Condition+ whenRising' i = expr (function (simple "rising_edge") [expr (name (NSimple i))])++ isLow :: Identifier -> Condition+ isLow i = primExpr $ eq+ (shift' (name (NSimple i)))+ (shift' (literal (number "\'0\'")))+ where+ shift' :: Primary -> ShiftExpression+ shift' = primShift . primSimple . primTerm . primFactor++-------------------------------------------------------------------------------- -- * Design units -------------------------------------------------------------------------------- @@ -453,14 +410,15 @@ -- | Design unit with context. addUnit :: MonadV m => LibraryUnit -> m () addUnit lib =- do ctxt <- CMS.gets _context- dsig <- CMS.gets _units- let item = DesignUnit (ContextClause (Set.toList ctxt)) lib+ do dsig <- CMS.gets _units+ ctxt <- CMS.gets _context+ let item = DesignUnit (ContextClause ctxt) lib CMS.modify $ \s -> s { _units = item : dsig- , _context = Set.empty+ , _context = [] } --- | Design unit ignoring context.+-- | Design unit ignoring context. Used for design units that inherit their+-- context from others, like architectures. addUnit_ :: MonadV m => LibraryUnit -> m () addUnit_ lib = CMS.modify $ \s -> s { _units = (DesignUnit (ContextClause []) lib) : (_units s)} @@ -476,27 +434,23 @@ oldGlobal <- CMS.gets _signals oldConcurrent <- CMS.gets _concurrent oldSequential <- CMS.gets _sequential- oldTypes <- CMS.gets _types oldComponents <- CMS.gets _components CMS.modify $ \e -> e { _constants = [] , _signals = [] , _concurrent = [] , _sequential = []- , _types = Set.empty- , _components = Set.empty }+ , _components = [] } result <- m newConstants <- reverse <$> CMS.gets _constants newGlobal <- reverse <$> CMS.gets _signals newConcurrent <- reverse <$> CMS.gets _concurrent newSequential <- reverse . filter isSignal <$> CMS.gets _sequential- newTypes <- fmap BDIType . Set.toList <$> CMS.gets _types- newComponents <- fmap BDIComp . Set.toList <$> CMS.gets _components+ newComponents <- fmap BDIComp <$> CMS.gets _components let signals = fmap translateSequential newSequential addUnit_ $ LibrarySecondary $ SecondaryArchitecture $ ArchitectureBody (name) (NSimple entity)- (newTypes -- merge- ++ newComponents+ (newComponents -- ++ newTypes ++ fmap translateInterface newGlobal ++ fmap translateInterface newConstants) (signals ++ newConcurrent)@@ -504,7 +458,6 @@ , _signals = oldGlobal , _concurrent = oldConcurrent , _sequential = oldSequential- , _types = oldTypes , _components = oldComponents } extendContext entity return result@@ -520,124 +473,50 @@ -- declaraions and context items produced by running the monadic action. entity :: MonadV m => Identifier -> m a -> m a entity name@(Ident n) m =- do oldTypes <- CMS.gets _types- oldPorts <- CMS.gets _signals- oldGenerics <- CMS.gets _variables- CMS.modify $ \e -> e { _types = Set.empty- , _signals = []- , _variables = [] }+ do oldPorts <- CMS.gets _ports+ CMS.modify $ \e -> e { _ports = [] } result <- m- types <- CMS.gets _types- newPorts <- reverse <$> CMS.gets _signals- newGenerics <- reverse <$> CMS.gets _variables- CMS.when (P.not $ Set.null types) $- do let packageName = n ++ "_types"- ctxt <- CMS.gets _context- addUnit $ packageTypes packageName types- CMS.modify $ \s -> s { _context = ctxt }- newImport $ "WORK." ++ packageName- addUnit $ LibraryPrimary $ PrimaryEntity $- EntityDeclaration name- (EntityHeader- (GenericClause <$> maybeNull newGenerics)- (PortClause <$> maybeNull newPorts))- ([])- (Nothing)- CMS.modify $ \e -> e { _types = oldTypes- , _signals = oldPorts- , _variables = oldGenerics }- return result--maybeNull :: [InterfaceDeclaration] -> Maybe InterfaceList-maybeNull [] = Nothing-maybeNull xs = Just $ InterfaceList $ xs --merge ...--packageTypes :: String -> Set TypeDeclaration -> LibraryUnit-packageTypes name types = LibraryPrimary $ PrimaryPackage $ PackageDeclaration- (Ident name) (fmap PHDIType (reverse $ Set.toList types))------------------------------------------------------------------------------------- ** Packages---- | Declares a package with the given name by consuming all type declarations--- produced by running the monadic action.-package :: MonadV m => String -> m a -> m a-package name m =- do oldTypes <- CMS.gets _types- CMS.modify $ \e -> e { _types = Set.empty }- result <- m- newTypes <- CMS.gets _types- addUnit $ packageTypes name newTypes- CMS.modify $ \e -> e { _types = oldTypes }+ newPorts <- reverse <$> CMS.gets _ports+ addUnit $ LibraryPrimary $ PrimaryEntity $ EntityDeclaration name+ (EntityHeader (Nothing) (PortClause <$> maybeNull newPorts)) [] Nothing+ CMS.modify $ \e -> e { _ports = oldPorts } return result+ where+ maybeNull :: [InterfaceDeclaration] -> Maybe InterfaceList+ maybeNull [] = Nothing+ maybeNull xs = Just $ InterfaceList xs --merge ... -------------------------------------------------------------------------------- -- ** Component. -- | Declares an entire component, with entity declaration and a body.-component :: MonadV m => m () -> m ()+component :: MonadV m => m a -> m a component m = do oldEnv <- CMS.get oldFiles <- CMS.gets _designs- CMS.put (emptyVHDLEnv { _designs = oldFiles })- m- newUnits <- CMS.gets _units+ oldTypes <- CMS.gets _types+ CMS.put $ emptyVHDLEnv {+ _designs = oldFiles+ , _types = oldTypes+ }+ result <- m+ newUnits <- reverse <$> CMS.gets _units newFiles <- CMS.gets _designs- CMS.put (oldEnv { _designs = newFiles })+ newTypes <- CMS.gets _types+ CMS.put $ oldEnv {+ _designs = newFiles+ , _types = newTypes+ } addDesign $ DesignFile newUnits------------------------------------------------------------------------------------- * Pretty printing VHDL programs------------------------------------------------------------------------------------- | Runs the VHDL monad and pretty prints its resulting VHDL program.-prettyVHDL :: VHDL a -> Doc-prettyVHDL = CMI.runIdentity . prettyVHDLT---- | Runs the VHDL monad transformer and pretty prints its resulting VHDL program.-prettyVHDLT :: Monad m => VHDLT m a -> m Doc-prettyVHDLT m = prettyVEnv <$> execVHDLT m emptyVHDLEnv-------------------------------------------------------------------------------------- | Pretty print a VHDL environment.-prettyVEnv :: VHDLEnv -> Doc-prettyVEnv env = Text.vcat (pp main : fmap pp files)- where- main = DesignFile units- units = reverse $ _units env- files = reverse $ map reorderDesign $ _designs env------------------------------------------------------------------------------------reorderDesign :: DesignFile -> DesignFile-reorderDesign (DesignFile units) = DesignFile (reverse units)--reorderUnit :: DesignUnit -> DesignUnit-reorderUnit (DesignUnit ctxt lib) = DesignUnit- (reorderContext ctxt)- (reorderLibrary lib)---- todo : reverse at the level of design file instead.-reorderLibrary :: LibraryUnit -> LibraryUnit-reorderLibrary (LibraryPrimary prim) = LibraryPrimary prim-reorderLibrary (LibrarySecondary second) = LibrarySecondary second---- todo : reverse instead?-reorderContext :: ContextClause -> ContextClause-reorderContext (ContextClause items) = ContextClause (reorder items [])- where- reorder :: [ContextItem] -> [ContextItem] -> [ContextItem]- reorder [] rs = rs- reorder (lib@(ContextLibrary _) : cs) rs = lib : (rs ++ cs)- reorder (use@(ContextUse _) : cs) rs = reorder (use : rs) cs+ return result+-- todo: since the types carry over ther could be name clashes in the generated+-- array types. This isn't a problem in our examples, but I should fix it. ----------------------------------------------------------------------------------- * Common things---------------------------------------------------------------------------------+-- ** Common declarations. ------------------------------------------------------------------------------------ ** Ports/Generic declarations+port :: MonadV m => Identifier -> Mode -> SubtypeIndication -> Maybe Expression -> m ()+port i m t e = addPort $ InterfaceSignalDeclaration [i] (Just m) t False e constant :: MonadV m => Identifier -> SubtypeIndication -> Expression -> m () constant i t e = addConstant $ InterfaceConstantDeclaration [i] t (Just e)@@ -656,18 +535,11 @@ assignSignal :: MonadV m => Name -> Expression -> m () assignSignal n e = addSequential $ SSignalAss $ - SignalAssignmentStatement- (Nothing)- (TargetName n)- (Nothing)- (WaveElem [WaveEExp e Nothing])+ SignalAssignmentStatement Nothing (TargetName n) Nothing (WaveElem [WaveEExp e Nothing]) assignVariable :: MonadV m => Name -> Expression -> m () assignVariable n e = addSequential $ SVarAss $- VariableAssignmentStatement- (Nothing)- (TargetName n)- (e)+ VariableAssignmentStatement Nothing (TargetName n) e assignArray :: MonadV m => Name -> Expression -> m () assignArray = assignSignal@@ -686,28 +558,165 @@ -------------------------------------------------------------------------------- -- Portmap. -portMap :: MonadV m => Label -> Identifier -> [(Identifier, Identifier)] -> m ()+portMap :: MonadV m => Label -> Identifier -> [(Maybe Identifier, Identifier)] -> m () portMap l c is = addConcurrent $ ConComponent $ ComponentInstantiationStatement l (IUComponent $ NSimple c) (Nothing) (Just $ PortMapAspect $ AssociationList $ flip fmap is $ \(i, j) ->- AssociationElement (Just $ FPDesignator $ FDPort $ NSimple i) $ APDesignator $ ADSignal $ NSimple j)+ AssociationElement+ (fmap (FPDesignator . FDPort . NSimple) i)+ (APDesignator $ ADSignal $ NSimple j)) -declareComponent :: MonadV m => Identifier -> [InterfaceDeclaration] -> m ()-declareComponent name is = addComponent $ ComponentDeclaration name Nothing- (Just (PortClause (InterfaceList is)))- (Nothing)+importComponent :: MonadV m => Identifier -> [InterfaceDeclaration] -> m ()+importComponent name is = addComponent $ ComponentDeclaration name Nothing+ (Just (PortClause (InterfaceList is)))+ (Nothing) ----------------------------------------------------------------------------------- ....+-- Null statements. null :: MonadV m => m () null = addSequential $ SNull $ NullStatement Nothing ----------------------------------------------------------------------------------- Some helper classes and their instances+-- * Pretty printing VHDL programs -----------------------------------------------------------------------------------++-- | Runs the VHDL monad and pretty prints its resulting VHDL program.+prettyVHDL :: VHDL a -> Doc+prettyVHDL = CMI.runIdentity . prettyVHDLT++-- | Runs the VHDL monad transformer and pretty prints its resulting VHDL program.+prettyVHDLT :: Monad m => VHDLT m a -> m Doc+prettyVHDLT m = prettyVEnv <$> execVHDLT (m >> package) emptyVHDLEnv+ where+ -- todo: importing like this is a bity "cheaty", as its assumets we know+ -- what kind of types will be packages. Also, I assume there _will_+ -- be a package called \types\ if any arrays are used.+ package :: Monad m => VHDLT m ()+ package =+ do addLibrary "IEEE"+ addImport "IEEE.std_logic_1164"+ addImport "IEEE.numeric_std"+ types <- CMS.gets _types+ ctxt <- CMS.gets _context+ CMS.when (P.not $ P.null types) $ addDesign $+ DesignFile $ (:[]) $ DesignUnit (ContextClause ctxt) $+ LibraryPrimary $ PrimaryPackage $ PackageDeclaration+ (Ident "types") (fmap PHDIType (reverse types))++--------------------------------------------------------------------------------++-- | Pretty print a VHDL environment.+prettyVEnv :: VHDLEnv -> Doc+prettyVEnv = Text.vcat . map pp . map reorderDesign . _designs++--------------------------------------------------------------------------------++reorderDesign :: DesignFile -> DesignFile+reorderDesign (DesignFile units) = DesignFile $ map reorderUnit units++reorderUnit :: DesignUnit -> DesignUnit+reorderUnit (DesignUnit ctxt lib) = DesignUnit (reorderContext ctxt) lib++reorderContext :: ContextClause -> ContextClause+reorderContext (ContextClause items) =+ ContextClause+ $ concatMap reorder+ $ groupBy prefix+ $ reverse items+ where+ prefix :: ContextItem -> ContextItem -> Bool+ prefix a b = prefixOf a == prefixOf b+ where+ prefixOf :: ContextItem -> String+ prefixOf (ContextLibrary (LibraryClause (LogicalNameList [Ident l]))) = l+ prefixOf (ContextUse (UseClause [SelectedName (PName (NSimple (Ident i))) _])) = takeWhile isLetter i++ reorder :: [ContextItem] -> [ContextItem]+ reorder cs = let (l, u) = partition isLib cs in l ++ u+ where+ isLib :: ContextItem -> Bool+ isLib (ContextLibrary _) = True+ isLib _ = False++--------------------------------------------------------------------------------+-- Some helper functions, classes and their instances+--------------------------------------------------------------------------------++-- | Wraps a program in an entity container.+wrapMain :: MonadV m => m a -> m ()+wrapMain prog = do+ let eName = Ident "main"+ let aName = Ident "behav"+ CMS.void $ component $ do+ entity eName $ do+ port (Ident "clk") (In) (std_logic) (Nothing)+ port (Ident "rst") (In) (std_logic) (Nothing)+ architecture eName aName prog+-- todo: take clock and reset names as parameters?++-- | Adds an element to a list if there's no element matching the predicate.+add :: Eq a => a -> [a] -> [a]+add a as+ | elem a as = as+ | otherwise = a : as++--------------------------------------------------------------------------------++lookupArrayType :: MonadV m => TypeDeclaration -> m (Maybe Identifier)+lookupArrayType t =+ do types <- CMS.gets _types+ return $ case find (compareTypeDecl t) types of+ Just (TDFull (FullTypeDeclaration i _)) -> Just i+ Nothing -> Nothing+ where+ compareTypeDecl :: TypeDeclaration -> TypeDeclaration -> Bool+ compareTypeDecl+ (TDFull (FullTypeDeclaration _ (TDComposite (CTDArray t1))))+ (TDFull (FullTypeDeclaration _ (TDComposite (CTDArray t2))))+ = compareType t1 t2+ compareTypeDecl _ _ = False++ compareType :: ArrayTypeDefinition -> ArrayTypeDefinition -> Bool+ compareType+ (ArrC (ConstrainedArrayDefinition (IndexConstraint [DRRange r1]) t1))+ (ArrC (ConstrainedArrayDefinition (IndexConstraint [DRRange r2]) t2))+ = eqType t1 t2 && eqRange r1 r2+ compareType _ _ = False++--------------------------------------------------------------------------------++extendContext :: MonadV m => Identifier -> m ()+extendContext i =+ do es <- CMS.gets _units+ case find (entity i) es of+ Just e -> extendEntity e+ Nothing -> error "hardware-edsl: extending context failed."+ where+ entity :: Identifier -> DesignUnit -> Bool+ entity i (DesignUnit _ (LibraryPrimary (PrimaryEntity (EntityDeclaration e _ _ _))))+ | i == e = True+ entity _ _ = False++extendEntity :: MonadV m => DesignUnit -> m ()+extendEntity old@(DesignUnit (ContextClause ctxt) lib) =+ do cs <- CMS.gets _context+ es <- CMS.gets _units+ let new = DesignUnit (ContextClause $ foldr mergeUnit ctxt cs) lib+ let es' = replaceUnit old new es+ CMS.modify $ \s -> s { _units = es' }+ where+ mergeUnit :: ContextItem -> [ContextItem] -> [ContextItem]+ mergeUnit item ds = add item ds++ replaceUnit :: DesignUnit -> DesignUnit -> [DesignUnit] -> [DesignUnit]+ replaceUnit o n [] = error "hardware-edsl: replacing unit failed."+ replaceUnit o n (d:ds)+ | o == d = n : ds+ | otherwise = d : replaceUnit o n ds++-------------------------------------------------------------------------------- -- I use BlockDeclarativeItem to represent all declarative items, which means we -- have to translate them over to their correct VHDL kind when generating an AST @@ -764,172 +773,5 @@ getBlockIds (BDISignal s) = signal_identifier_list s getBlockIds (BDIShared v) = var_identifier_list v getBlockIds (BDIFile f) = fd_identifier_list f------------------------------------------------------------------------------------- Ord instance for use in sets--------------------------------------------------------------------------------------- todo: don't rely on these too much.--deriving instance Ord ContextItem-deriving instance Ord LibraryClause-deriving instance Ord LogicalNameList-deriving instance Ord UseClause--instance Ord TypeDeclaration - where- compare (TDFull (FullTypeDeclaration a (TDComposite b)))- (TDFull (FullTypeDeclaration x (TDComposite y)))- = compare b y- compare _ _ = error "Ord not supported for incomplete type declarations."--instance Ord CompositeTypeDefinition- where- compare (CTDArray a) (CTDArray x) = compare a x- compare _ _ = error "Ord not supported for record type definitions."--instance Ord ArrayTypeDefinition- where- compare (ArrU (UnconstrainedArrayDefinition a b))- (ArrU (UnconstrainedArrayDefinition x y)) =- case compare b y of- GT -> GT- LT -> LT- EQ -> compare a x- compare (ArrC (ConstrainedArrayDefinition a b))- (ArrC (ConstrainedArrayDefinition x y)) =- case compare b y of- GT -> GT- LT -> LT- EQ -> compare a x--deriving instance Ord IndexSubtypeDefinition--deriving instance Ord IndexConstraint--deriving instance Ord IncompleteTypeDeclaration--instance Ord ComponentDeclaration- where- compare a x = compare (comp_identifier a) (comp_identifier x)--deriving instance Ord SubtypeIndication-deriving instance Ord TypeMark--instance Ord Constraint- where- compare (CRange a) (CRange x) = compare a x- compare _ _ = error "Ord not supported for index constraints."--deriving instance Ord RangeConstraint--instance Ord Range- where- compare (RSimple a b c) (RSimple x y z) =- case compare a x of- GT -> GT- LT -> LT- EQ -> case compare b y of- GT -> GT- LT -> LT- EQ -> case compare c z of- GT -> GT- LT -> LT- EQ -> EQ- compare _ _ = error "Ord not supported for attribute ranges"--deriving instance Ord Direction-deriving instance Ord Expression-deriving instance Ord Relation-deriving instance Ord ShiftExpression-deriving instance Ord SimpleExpression-deriving instance Ord Term-deriving instance Ord Factor--instance Ord Primary- where- compare (PrimName a) (PrimName x) = compare a x- compare (PrimLit a) (PrimLit x) = compare a x- compare (PrimAgg a) (PrimAgg x) = compare a x- compare (PrimFun a) (PrimFun x) = compare a x- compare (PrimQual a) (PrimQual x) = compare a x- compare (PrimTCon a) (PrimTCon x) = compare a x- compare (PrimAlloc a) (PrimAlloc x) = compare a x- compare (PrimExp a) (PrimExp x) = compare a x-- compare (PrimExp a) x | Just p <- maybePrimary a = compare p x- compare a (PrimExp x) | Just p <- maybePrimary x = compare a p- - compare a x = error ("\na: " ++ show a ++ "\nx: " ++ show x)--deriving instance Ord Aggregate-deriving instance Ord ElementAssociation-deriving instance Ord Choices-deriving instance Ord Choice--deriving instance Ord FunctionCall-deriving instance Ord AssociationList-deriving instance Ord AssociationElement-deriving instance Ord FormalPart-deriving instance Ord FormalDesignator-deriving instance Ord ActualPart-deriving instance Ord ActualDesignator--deriving instance Ord QualifiedExpression--deriving instance Ord TypeConversion--deriving instance Ord Allocator--deriving instance Ord LogicalOperator-deriving instance Ord RelationalOperator-deriving instance Ord ShiftOperator-deriving instance Ord AddingOperator-deriving instance Ord Sign-deriving instance Ord MultiplyingOperator-deriving instance Ord MiscellaneousOperator-deriving instance Ord Identifier--instance Ord Name- where- compare (NSimple a) (NSimple x) = compare a x- compare (NSelect a) (NSelect x) = compare a x- compare (NIndex a) (NIndex x) = compare a x- compare (NSlice a) (NSlice x) = compare a x- compare (NAttr a) (NAttr x) = compare a x--deriving instance Ord StringLiteral-deriving instance Ord SelectedName--instance Ord Suffix- where- compare (SSimple a) (SSimple x) = compare a x- compare (SChar a) (SChar x) = compare a x- compare (SAll) (SAll) = EQ- compare _ _ = error "Ord not supported for operator symbols"--deriving instance Ord CharacterLiteral-deriving instance Ord IndexedName-deriving instance Ord SliceName-deriving instance Ord DiscreteRange--instance Ord Prefix- where- compare (PName a) (PName x) = compare a x- compare _ _ = error "Ord not supported for function names"--deriving instance Ord AttributeName-deriving instance Ord Signature--deriving instance Ord Literal-deriving instance Ord NumericLiteral-deriving instance Ord AbstractLiteral-deriving instance Ord PhysicalLiteral-deriving instance Ord DecimalLiteral-deriving instance Ord EnumerationLiteral-deriving instance Ord BitStringLiteral--deriving instance Ord Exponent-deriving instance Ord BasedLiteral --------------------------------------------------------------------------------
src/Language/Embedded/VHDL/Monad/Type.hs view
@@ -9,6 +9,7 @@ , unconstrainedArray, constrainedArray -- utility. , typeName, typeRange, typeWidth+ , eqType, eqRange , isBit, isBits, isSigned, isUnsigned, isInteger, isFloating ) where @@ -123,14 +124,25 @@ typeRange (SubtypeIndication _ (TMType (NSlice (SliceName _ (DRRange r)))) _) = Just r typeRange _ = Nothing +--------------------------------------------------------------------------------++eqType :: Type -> Type -> Bool+eqType t1 t2 = typeName t1 == typeName t2 && typeRange t1 == typeRange t2++eqRange :: Range -> Range -> Bool+eqRange (RSimple l1 To u1) (RSimple l2 To u2) =+ unliteral u1 - unliteral l1 == unliteral u2 - unliteral l2+eqRange (RSimple u1 DownTo l1) (RSimple u2 DownTo l2) =+ unliteral u1 - unliteral l1 == unliteral u2 - unliteral l2+eqRange _ _ = False+ -- todo: skipped attribute names.++--------------------------------------------------------------------------------+ -- todo: this assumes we only use numbers when specifying ranges and constraints. typeWidth :: Type -> Integer typeWidth (SubtypeIndication _ t c) = (unrange t) * (maybe 1 unconstraint c) where- unliteral :: SimpleExpression -> Integer- unliteral (SimpleExpression _ (Term (FacPrim (PrimLit (LitNum (NLitPhysical (PhysicalLiteral _ (NSimple (Ident i)))))) _) _) _) =- read i- unrange :: TypeMark -> Integer unrange (TMType (NSlice (SliceName _ (DRRange (RSimple u DownTo l))))) = unliteral u - unliteral l + 1@@ -162,5 +174,11 @@ isFloating :: Type -> Bool isFloating t = "float" == typeName t++--------------------------------------------------------------------------------+-- Internal helper.++unliteral :: SimpleExpression -> Integer+unliteral (SimpleExpression _ (Term (FacPrim (PrimLit (LitNum (NLitPhysical (PhysicalLiteral _ (NSimple (Ident i)))))) _) _) _) = read i --------------------------------------------------------------------------------
src/Language/Embedded/VHDL/Monad/Util.hs view
@@ -1,9 +1,12 @@ module Language.Embedded.VHDL.Monad.Util- ( uType, uCast, uResize, uResizeBits+ ( uType, uCast, uCoerce, uResize, uResizeBits -- utility. , maybePrimary, maybeLit, maybeVar, maybeFun, maybeExp , printPrimary , printBits+ --+ , expr+ , primExpr, primRelation, primShift, primSimple, primTerm, primFactor ) where import Language.VHDL@@ -63,10 +66,41 @@ | otherwise = exp uCast exp from to | isBit from, isBit to = exp uCast exp from to =- error $ "hardware-edsl.todo: missing type cast from ("+ error $ "hardware-edsl.uCast: missing type cast from (" ++ show (typeName from) ++ ") to (" ++ show (typeName to) ++ ")." +-- | Type coercion, assumes both types have equal size.+--+-- todo: using `asUnsigned` in the coercion from bits to integer, rather than+-- `asSigned`, is a bit arbitary, as bits doesn't imply either signed or+-- unsigned. The AXI interface sort of relies on unsigned being used, but+-- that could be addressed by making use of the whole address range+-- instead of just the "necessary" bits.+uCoerce :: Expression -> SubtypeIndication -> SubtypeIndication -> Expression+uCoerce exp from to | isUnsigned from = go+ where+ go | isUnsigned to = exp+ | isSigned to = expr $ asSigned exp+ | isBits to = expr $ asBits exp+ | isInteger to = expr $ toInteger exp+uCoerce exp from to | isSigned from = go+ where+ go | isUnsigned to = expr $ asUnsigned exp+ | isSigned to = exp+ | isBits to = expr $ asBits exp+ | isInteger to = expr $ toInteger exp+uCoerce exp from to | isBits from = go+ where+ go | isUnsigned to = expr $ asUnsigned exp+ | isSigned to = expr $ asSigned exp+ | isBits to = exp+ | isInteger to = expr $ toInteger $ expr $ asUnsigned exp+uCoerce exp from to =+ error $ "hardware-edsl.uCoerce: missing coercion from ("+ ++ show (typeName from) ++ ") to ("+ ++ show (typeName to) ++ ")."+ uResize :: Expression -> SubtypeIndication -> SubtypeIndication -> Expression uResize exp from to -- if literal, simply resize it.@@ -94,7 +128,7 @@ let zeroes = name $ simple $ printBits (typeWidth to - typeWidth from) (0 :: Int) bits = name $ prefix wrap s = ENand (Relation (ShiftExpression s Nothing) Nothing) Nothing- in wrap (cat [term zeroes, term bits])+ in wrap (cat [primTerm (primFactor zeroes), primTerm (primFactor bits)]) | otherwise = error $ show exp where prefix :: Name@@ -106,10 +140,31 @@ expr :: Primary -> Expression expr (PrimExp e) = e-expr (primary) = ENand (Relation (ShiftExpression (SimpleExpression Nothing (Term (FacPrim primary Nothing) []) []) Nothing) Nothing) Nothing+expr (primary) = primExpr+ $ primRelation+ $ primShift+ $ primSimple+ $ primTerm+ $ primFactor+ $ primary -term :: Primary -> Term-term primary = Term (FacPrim primary Nothing) []+primExpr :: Relation -> Expression+primExpr relation = ENand relation Nothing++primRelation :: ShiftExpression -> Relation+primRelation shift = Relation shift Nothing++primShift :: SimpleExpression -> ShiftExpression+primShift simple = ShiftExpression simple Nothing++primSimple :: Term -> SimpleExpression+primSimple term = SimpleExpression Nothing term []++primTerm :: Factor -> Term+primTerm factor = Term factor []++primFactor :: Primary -> Factor+primFactor primary = FacPrim primary Nothing width :: SubtypeIndication -> Primary width = literal . number . show . typeWidth