diff --git a/hardware-edsl.cabal b/hardware-edsl.cabal --- a/hardware-edsl.cabal +++ b/hardware-edsl.cabal @@ -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 diff --git a/src/Language/Embedded/Hardware/Command.hs b/src/Language/Embedded/Hardware/Command.hs --- a/src/Language/Embedded/Hardware/Command.hs +++ b/src/Language/Embedded/Hardware/Command.hs @@ -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 -------------------------------------------------------------------------------- diff --git a/src/Language/Embedded/Hardware/Command/Backend/VHDL.hs b/src/Language/Embedded/Hardware/Command/Backend/VHDL.hs --- a/src/Language/Embedded/Hardware/Command/Backend/VHDL.hs +++ b/src/Language/Embedded/Hardware/Command/Backend/VHDL.hs @@ -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) diff --git a/src/Language/Embedded/Hardware/Command/CMD.hs b/src/Language/Embedded/Hardware/Command/CMD.hs --- a/src/Language/Embedded/Hardware/Command/CMD.hs +++ b/src/Language/Embedded/Hardware/Command/CMD.hs @@ -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) -------------------------------------------------------------------------------- diff --git a/src/Language/Embedded/Hardware/Command/Frontend.hs b/src/Language/Embedded/Hardware/Command/Frontend.hs --- a/src/Language/Embedded/Hardware/Command/Frontend.hs +++ b/src/Language/Embedded/Hardware/Command/Frontend.hs @@ -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. -------------------------------------------------------------------------------- diff --git a/src/Language/Embedded/Hardware/Expression.hs b/src/Language/Embedded/Hardware/Expression.hs --- a/src/Language/Embedded/Hardware/Expression.hs +++ b/src/Language/Embedded/Hardware/Expression.hs @@ -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 () diff --git a/src/Language/Embedded/Hardware/Expression/Frontend.hs b/src/Language/Embedded/Hardware/Expression/Frontend.hs --- a/src/Language/Embedded/Hardware/Expression/Frontend.hs +++ b/src/Language/Embedded/Hardware/Expression/Frontend.hs @@ -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 diff --git a/src/Language/Embedded/Hardware/Expression/Represent.hs b/src/Language/Embedded/Hardware/Expression/Represent.hs --- a/src/Language/Embedded/Hardware/Expression/Represent.hs +++ b/src/Language/Embedded/Hardware/Expression/Represent.hs @@ -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" -------------------------------------------------------------------------------- diff --git a/src/Language/Embedded/Hardware/Expression/Represent/Bit.hs b/src/Language/Embedded/Hardware/Expression/Represent/Bit.hs --- a/src/Language/Embedded/Hardware/Expression/Represent/Bit.hs +++ b/src/Language/Embedded/Hardware/Expression/Represent/Bit.hs @@ -55,7 +55,7 @@ import GHC.TypeLits -------------------------------------------------------------------------------- --- * Bit vectors of known lenght. +-- * Bit vectors of known length. -------------------------------------------------------------------------------- newtype Bits (n :: Nat) = B Integer diff --git a/src/Language/Embedded/Hardware/Interface/AXI.hs b/src/Language/Embedded/Hardware/Interface/AXI.hs --- a/src/Language/Embedded/Hardware/Interface/AXI.hs +++ b/src/Language/Embedded/Hardware/Interface/AXI.hs @@ -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] --} --------------------------------------------------------------------------------- - diff --git a/src/Language/Embedded/VHDL/Monad.hs b/src/Language/Embedded/VHDL/Monad.hs --- a/src/Language/Embedded/VHDL/Monad.hs +++ b/src/Language/Embedded/VHDL/Monad.hs @@ -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 -------------------------------------------------------------------------------- diff --git a/src/Language/Embedded/VHDL/Monad/Type.hs b/src/Language/Embedded/VHDL/Monad/Type.hs --- a/src/Language/Embedded/VHDL/Monad/Type.hs +++ b/src/Language/Embedded/VHDL/Monad/Type.hs @@ -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 -------------------------------------------------------------------------------- diff --git a/src/Language/Embedded/VHDL/Monad/Util.hs b/src/Language/Embedded/VHDL/Monad/Util.hs --- a/src/Language/Embedded/VHDL/Monad/Util.hs +++ b/src/Language/Embedded/VHDL/Monad/Util.hs @@ -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