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.0.1 +version: 0.1.2 synopsis: Deep embedding of hardware descriptions with code generation. description: Deep embedding of hardware descriptions with code generation. license: BSD3 @@ -21,22 +21,25 @@ exposed-modules: Language.Embedded.Hardware, Language.Embedded.Hardware.Expression, - Language.Embedded.Hardware.Expression.Syntax, - Language.Embedded.Hardware.Expression.Represent, + Language.Embedded.Hardware.Expression.Backend.VHDL, Language.Embedded.Hardware.Expression.Frontend, + Language.Embedded.Hardware.Expression.Hoist, + Language.Embedded.Hardware.Expression.Represent, + Language.Embedded.Hardware.Expression.Represent.Bit, + Language.Embedded.Hardware.Expression.Syntax, + Language.Embedded.Hardware.Interface, Language.Embedded.Hardware.Command, + Language.Embedded.Hardware.Command.Backend.VHDL, Language.Embedded.Hardware.Command.CMD, Language.Embedded.Hardware.Command.Frontend, - Language.Embedded.Hardware.Interface Language.Embedded.VHDL, Language.Embedded.VHDL.Monad, Language.Embedded.VHDL.Monad.Type, Language.Embedded.VHDL.Monad.Expression + Language.Embedded.VHDL.Monad.Util +-- Language.Embedded.Hardware.Common.AXI - other-modules: - Language.Embedded.Hardware.Expression.Hoist, - Language.Embedded.Hardware.Expression.Backend.VHDL, - Language.Embedded.Hardware.Command.Backend.VHDL + --other-modules: other-extensions: GADTs, @@ -46,6 +49,7 @@ FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, + PolyKinds, ScopedTypeVariables, GeneralizedNewtypeDeriving, ConstraintKinds, @@ -54,16 +58,17 @@ UndecidableInstances build-depends: - base >=4.8 && <4.9, + 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, constraints >=0.6, - syntactic >=3.2, - operational-alacarte >=0.1.1, - language-vhdl >=0.1.2.5 + syntactic >=3.6.1, + operational-alacarte >=0.2, + language-vhdl >=0.1.3 hs-source-dirs: src diff --git a/src/Language/Embedded/Hardware.hs b/src/Language/Embedded/Hardware.hs --- a/src/Language/Embedded/Hardware.hs +++ b/src/Language/Embedded/Hardware.hs @@ -7,4 +7,3 @@ import Language.Embedded.Hardware.Expression import Language.Embedded.Hardware.Command import Language.Embedded.Hardware.Interface - 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 @@ -1,12 +1,20 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ConstraintKinds #-} module Language.Embedded.Hardware.Command ( compile , icompile , runIO - , wcompile + , compileWrap + , icompileWrap + , runIOWrap + , VHDL.Mode(..) + , module CMD , module Language.Embedded.Hardware.Command.CMD , module Language.Embedded.Hardware.Command.Frontend @@ -17,6 +25,7 @@ import Language.Embedded.Hardware.Command.CMD hiding (Signal, Variable, Array) import Language.Embedded.Hardware.Command.Frontend import Language.Embedded.Hardware.Command.Backend.VHDL +import Language.Embedded.Hardware.Interface import Language.Embedded.VHDL (VHDL, prettyVHDL) @@ -25,34 +34,93 @@ import Control.Monad.Operational.Higher +import qualified GHC.Exts as GHC (Constraint) + -------------------------------------------------------------------------------- -- * Compilation and evaluation. -------------------------------------------------------------------------------- -- | Compile a program to VHDL code represented as a string. -compile :: (Interp instr VHDL, HFunctor instr) => Program instr a -> String +compile :: forall instr (exp :: * -> *) (pred :: * -> GHC.Constraint) a. + ( Interp instr VHDL (Param2 exp pred) + , HFunctor instr + ) + => Program instr (Param2 exp pred) a + -> String compile = show . prettyVHDL . interpret -- | Compile a program to VHDL code and print it on the screen. -icompile :: (Interp instr VHDL, HFunctor instr) => Program instr a -> IO () +icompile :: forall instr (exp :: * -> *) (pred :: * -> GHC.Constraint) a. + ( Interp instr VHDL (Param2 exp pred) + , HFunctor instr + ) + => Program instr (Param2 exp pred) a + -> IO () icompile = putStrLn . compile -- | Run a program in 'IO'. -runIO :: (Interp instr IO, HFunctor instr) => Program instr a -> IO a -runIO = interpret +runIO :: forall instr (exp :: * -> *) (pred :: * -> GHC.Constraint) a + . ( InterpBi instr IO (Param1 pred) + , HBifunctor instr + , EvaluateExp exp + ) + => Program instr (Param2 exp pred) a + -> IO a +runIO = interpretBi (return . evalE) -------------------------------------------------------------------------------- --- | Temp. -wcompile :: (Interp instr VHDL, HFunctor instr) => Program instr () -> IO () -wcompile = putStrLn . show . prettyVHDL . wrap . interpret - where - wrap :: VHDL () -> VHDL () - wrap v = do - VHDL.entity (VHDL.Ident "empty") (return ()) - VHDL.architecture (VHDL.Ident "empty") (VHDL.Ident "behavioural") $ - do l <- VHDL.newLabel - s <- snd <$> VHDL.inProcess l [] v - VHDL.addConcurrent $ VHDL.ConProcess s +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) ()) + -> String +compileWrap = compile . wrap + +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) ()) + -> IO () +icompileWrap = icompile . wrap + +runIOWrap :: forall instr (exp :: * -> *) (pred :: * -> GHC.Constraint) a + . ( InterpBi instr IO (Param1 pred) + , HBifunctor instr + , EvaluateExp exp + , ComponentCMD :<: instr + , StructuralCMD :<: instr + , SignalCMD :<: instr + , pred Bool + ) + => (Signal Bool -> Signal Bool -> Program instr (Param2 exp pred) ()) + -> IO () +runIOWrap = runIO . 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 -------------------------------------------------------------------------------- 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 @@ -1,301 +1,708 @@ {-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ConstraintKinds #-} -module Language.Embedded.Hardware.Command.Backend.VHDL () where +module Language.Embedded.Hardware.Command.Backend.VHDL (CompileType(..)) where import Control.Monad.Operational.Higher import Language.Embedded.Hardware.Interface import Language.Embedded.Hardware.Expression.Hoist +import Language.Embedded.Hardware.Expression.Represent +import Language.Embedded.Hardware.Expression.Represent.Bit (Bits, ni) import Language.Embedded.Hardware.Command.CMD import Language.Embedded.VHDL (VHDL) import qualified Language.VHDL as V import qualified Language.Embedded.VHDL as V +import Data.Array.IO (freeze) +import Data.List (genericTake) +import Data.Proxy +import Data.Word (Word8) import qualified Data.IORef as IR import qualified Data.Array.IO as IA +import GHC.TypeLits (KnownNat) + -------------------------------------------------------------------------------- -- * Translation of hardware commands into VHDL. -------------------------------------------------------------------------------- -class ToIdent a - where - toIdent :: a -> V.Identifier +-------------------------------------------------------------------------------- +-- ** ... -instance ToIdent String where toIdent = V.Ident -instance ToIdent (Signal a) where toIdent (SignalC i) = V.Ident $ 's' : show i -instance ToIdent (Variable a) where toIdent (VariableC i) = V.Ident $ 'v' : show i -instance ToIdent (Array i a) where toIdent (ArrayC i) = V.Ident $ 'a' : show i +evalEM :: forall exp a . EvaluateExp exp => Maybe (exp a) -> a +evalEM e = maybe (error "empty value") id $ fmap evalE e -compEM :: forall exp a. (PredicateExp exp a, CompileExp exp) => Maybe (exp a) -> VHDL (Maybe V.Expression) +compEM :: forall exp a . CompileExp exp => Maybe (exp a) -> VHDL (Maybe V.Expression) compEM e = maybe (return Nothing) (>>= return . Just) $ fmap compE e -compTM :: forall exp a. (PredicateExp exp a, CompileExp exp) => Maybe (exp a) -> VHDL V.Type -compTM _ = compT (undefined :: exp a) +-------------------------------------------------------------------------------- +-- ** ... -evalEM :: forall exp a. (PredicateExp exp a, EvaluateExp exp) => Maybe (exp a) -> a -evalEM e = maybe (error "empty value") (id) $ fmap evalE e +class CompileType ct + where + compileType :: ct a => proxy1 ct -> proxy2 a -> VHDL V.Type + compileLit :: ct a => proxy1 ct -> a -> VHDL V.Expression + compileBits :: ct a => proxy1 ct -> a -> VHDL V.Expression -freshVar :: forall exp a. (CompileExp exp, PredicateExp exp a) => VHDL (exp a, V.Identifier) -freshVar = do - i <- varE <$> V.freshUnique :: VHDL (exp a) - n <- dig <$> compE i - t <- compT (undefined :: exp a) - V.addLocal $ V.declareVariable n t Nothing - return (i, n) +instance CompileType HType where - -- diggity dig! - dig :: V.Expression -> V.Identifier - dig (V.ENand (V.Relation (V.ShiftExpression (V.SimpleExpression _ (V.Term (V.FacPrim (V.PrimName (V.NSimple i)) _)_)_)_)_)_) = i + compileType _ = compT + compileLit _ = return . literal . printVal + compileBits _ = return . literal . printBits -------------------------------------------------------------------------------- + +compT :: HType a => proxy a -> VHDL V.Type +compT = declare + +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) + +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) + +compTA :: forall proxy ct array i a . (CompileType ct, ct a) => proxy ct -> V.Range -> array a -> VHDL V.Type +compTA _ range _ = + 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) + where + typed :: V.TypeDeclaration -> V.SubtypeIndication + typed (V.TDFull (V.FullTypeDeclaration i _)) = named i + typed (V.TDPartial (V.IncompleteTypeDeclaration i)) = named i + + named :: V.Identifier -> V.SubtypeIndication + named i = V.SubtypeIndication Nothing (V.TMType (V.NSimple i)) Nothing + +-------------------------------------------------------------------------------- + +proxyE :: exp a -> Proxy a +proxyE _ = Proxy + +proxyM :: Maybe (exp a) -> Proxy a +proxyM _ = Proxy + +proxyF :: (exp a -> b) -> Proxy a +proxyF _ = Proxy + +-------------------------------------------------------------------------------- +-- ** ... + +newSym :: Name -> VHDL String +newSym (Base n) = V.newSym n +newSym (Exact n) = return n + +freshVar :: forall proxy ct exp a . (CompileType ct, ct a) + => proxy ct -> Name -> VHDL (Val a) +freshVar _ prefix = + do i <- newSym prefix + t <- compileType (Proxy::Proxy ct) (Proxy::Proxy a) + V.variable (ident' i) t Nothing + return (ValC i) + +-------------------------------------------------------------------------------- -- ** Signals. -instance CompileExp exp => Interp (SignalCMD exp) VHDL +instance (CompileExp exp, CompileType ct) => Interp SignalCMD VHDL (Param2 exp ct) where interp = compileSignal -instance EvaluateExp exp => Interp (SignalCMD exp) IO +instance InterpBi SignalCMD IO (Param1 pred) where - interp = runSignal + interpBi = runSignal -compileSignal :: forall exp a. CompileExp exp => SignalCMD exp VHDL a -> VHDL a -compileSignal (NewSignal clause scope mode exp) = - do v <- compEM exp - t <- compTM exp - i <- SignalC <$> V.freshUnique - let block = V.declareSignal (toIdent i) t v - interface = V.interfaceSignal (toIdent i) mode t v - case scope of - SProcess -> V.addLocal block - SArchitecture -> V.addGlobal block - SEntity -> case clause of - Port -> V.addPort interface - Generic -> V.addGeneric interface +-- 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) = + do i <- newSym base + v <- compEM exp + t <- compTM (Proxy::Proxy ct) exp + V.signal (ident' i) mode t v + return (SignalC i) +compileSignal (GetSignal (SignalC s)) = + do i <- freshVar (Proxy::Proxy ct) (Base "v") + V.assignVariable (simple $ ident i) (simple' s) return i -compileSignal (GetSignal s) = - do (v, i) <- freshVar :: VHDL (a, V.Identifier) - e <- compE v - V.addSequential $ V.assignVariable i (lift $ V.PrimName $ V.NSimple $ toIdent s) - return v -compileSignal (SetSignal s exp) = - do V.addSequential =<< V.assignSignalS (toIdent s) <$> compE exp +compileSignal (SetSignal (SignalC s) exp) = + do e' <- compE exp + t <- compileType (Proxy::Proxy ct) (proxyE exp) + V.assignSignal (simple $ ident s) (V.uType e' t) compileSignal (UnsafeFreezeSignal (SignalC s)) = - do return $ varE s + do return $ ValC s +compileSignal (ConcurrentSetSignal (SignalC s) exp) = + do e <- compE exp + V.concurrentSignal (simple $ ident s) e -runSignal :: forall exp prog a. EvaluateExp exp => SignalCMD exp prog a -> IO a -runSignal (NewSignal _ _ _ exp) = fmap SignalE $ IR.newIORef $ evalEM exp -runSignal (GetSignal (SignalE r)) = fmap litE $ IR.readIORef r -runSignal (SetSignal (SignalE r) exp) = IR.writeIORef r $ evalE exp -runSignal (UnsafeFreezeSignal r) = runSignal (GetSignal r) +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." -------------------------------------------------------------------------------- -- ** Variables. -instance CompileExp exp => Interp (VariableCMD exp) VHDL +instance (CompileExp exp, CompileType ct) => Interp VariableCMD VHDL (Param2 exp ct) where interp = compileVariable -instance EvaluateExp exp => Interp (VariableCMD exp) IO +instance InterpBi VariableCMD IO (Param1 pred) where - interp = runVariable + interpBi = runVariable -compileVariable :: forall exp a. CompileExp exp => VariableCMD exp VHDL a -> VHDL a -compileVariable (NewVariable exp) = - do v <- compEM exp - t <- compTM exp - i <- VariableC <$> V.freshUnique - V.addLocal $ V.declareVariable (toIdent i) t v +-- todo: why not initialize variable? +compileVariable :: forall ct exp a. (CompileExp exp, CompileType ct) => VariableCMD (Param3 VHDL exp ct) a -> VHDL a +compileVariable (NewVariable base exp) = + do i <- newSym base + v <- compEM exp + t <- compTM (Proxy::Proxy ct) exp + V.variable (ident' i) t (Nothing) + case v of + Nothing -> return () + 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") + V.assignVariable (simple $ ident i) (simple' var) return i -compileVariable (GetVariable var) = - do (v, i) <- freshVar :: VHDL (a, V.Identifier) - e <- compE v - V.addSequential $ V.assignVariable i (lift $ V.PrimName $ V.NSimple $ toIdent var) - return v -compileVariable (SetVariable var exp) = - do V.addSequential =<< V.assignVariable (toIdent var) <$> compE exp +compileVariable (SetVariable (VariableC var) exp) = + do e' <- compE exp + t <- compileType (Proxy::Proxy ct) (proxyE exp) + V.assignVariable (simple var) (V.uType e' t) compileVariable (UnsafeFreezeVariable (VariableC v)) = - do return $ varE v + do return $ ValC v -runVariable :: forall exp prog a. EvaluateExp exp => VariableCMD exp prog a -> IO a -runVariable (NewVariable exp) = fmap VariableE $ IR.newIORef $ evalEM exp -runVariable (GetVariable (VariableE v)) = fmap litE $ IR.readIORef v -runVariable (SetVariable (VariableE v) exp) = IR.writeIORef v $ evalE exp -runVariable (UnsafeFreezeVariable v) = runVariable (GetVariable v) +runVariable :: VariableCMD (Param3 IO IO pred) a -> IO a +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, EvaluateExp exp, CompArrayIx exp) => Interp (ArrayCMD exp) VHDL +instance (CompileExp exp, CompileType ct) => Interp ArrayCMD VHDL (Param2 exp ct) where interp = compileArray -instance EvaluateExp exp => Interp (ArrayCMD exp) IO +instance InterpBi ArrayCMD IO (Param1 pred) where - interp = runArray + interpBi = runArray --- *** Signal commands can be both sequential and parallel and I shouldn't --- depend on them always being sequential. -compileArray :: forall exp a. (CompileExp exp, EvaluateExp exp, CompArrayIx exp) => ArrayCMD exp VHDL a -> VHDL a -compileArray (NewArray len) = - do n <- compE len - t <- compTA len (undefined :: a) - a <- freshA - i <- ArrayC <$> V.freshUnique - let range = V.range (lift n) V.downto zero - array = V.constrainedArray a t range - V.addType array - V.addLocal $ V.declareVariable (toIdent i) (typed array) Nothing - return i -compileArray (InitArray is) = - do t <- compTA (undefined :: exp i) (undefined :: a) - a <- freshA - i <- ArrayC <$> V.freshUnique - x <- sequence [compE (litE a :: exp b) | (a :: b) <- is] - let len = V.lit (length is) - range = V.range (lift len) V.downto zero - array = V.constrainedArray a t range - V.addType array - V.addLocal $ V.declareVariable (toIdent i) (typed array) (Just $ lift $ V.aggregate x) - return i -compileArray (GetArray ix arr) = - do (v, i) <- freshVar :: VHDL (a, V.Identifier) +compileArray :: forall ct exp a. (CompileExp exp, CompileType ct) => ArrayCMD (Param3 VHDL exp ct) a -> VHDL a +compileArray (NewArray base len) = + do i <- newSym base + l <- compE len + t <- compTA (Proxy::Proxy ct) (rangeZero l) (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 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 - V.addSequential $ V.assignVariable i (lift $ V.PrimName $ V.indexed (toIdent arr) e) - return v -compileArray (SetArray i e arr) = - do i' <- compE i - e' <- compE e - -- this could be concurrent as well. - V.addSequential $ V.assignArray (V.indexed (toIdent arr) i') e' -compileArray (UnsafeGetArray ix arr) = - case compArrayIx ix arr of - Just e -> return e - Nothing -> do - (v, i) <- freshVar :: VHDL (a, V.Identifier) - e <- compE ix - V.addSequential $ V.assignVariable i (lift $ V.PrimName $ V.indexed (toIdent arr) e) - return v + 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) + 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 + V.assignSignal dest src +compileArray (ResetArray (ArrayC a) rst) = + do rst' <- compE rst + t <- compileType (Proxy::Proxy ct) (proxyE rst) + let others = V.aggregate $ V.others (V.uType rst' t) + V.assignArray (simple a) (lift others) -runArray :: forall exp prog a. EvaluateExp exp => ArrayCMD exp prog a -> IO a -runArray (NewArray len) = fmap ArrayE . IR.newIORef =<< IA.newArray_ (0, evalE len) -runArray (InitArray is) = fmap ArrayE . IR.newIORef =<< IA.newListArray (0, fromIntegral $ length is) is -runArray (GetArray i (ArrayE a)) = do r <- IR.readIORef a; fmap litE $ IA.readArray r (evalE i) -runArray (SetArray i e (ArrayE a)) = do r <- IR.readIORef a; IA.writeArray r (evalE i) (evalE e) -runArray (UnsafeGetArray i a) = runArray (GetArray i a) +runArray :: ArrayCMD (Param3 IO IO pred) a -> IO a +runArray = error "hardware-edsl.todo: run arrays" -------------------------------------------------------------------------------- - --- | Fresh array type identifier -freshA :: VHDL V.Identifier -freshA = toIdent . ('t' :) . show <$> V.freshUnique +-- ** Virtual Arrays. --- | Compile type of array. -compTA :: forall exp i a. (PredicateExp exp a, CompileExp exp) => exp i -> Array i a -> VHDL V.Type -compTA _ _ = compT (undefined :: exp a) +instance (CompileExp exp, CompileType ct) => Interp VArrayCMD VHDL (Param2 exp ct) + where + interp = compileVArray -zero :: V.SimpleExpression -zero = lift (V.lit 0) +instance InterpBi VArrayCMD IO (Param1 pred) + where + interpBi = runVArray -typed :: V.TypeDeclaration -> V.SubtypeIndication -typed (V.TDFull (V.FullTypeDeclaration i _)) = named i -typed (V.TDPartial (V.IncompleteTypeDeclaration i)) = named i +compileVArray :: forall ct exp a. (CompileExp exp, CompileType ct) => VArrayCMD (Param3 VHDL exp ct) a -> VHDL a +compileVArray (NewVArray base len) = + do l <- compE len + t <- compTA (Proxy::Proxy ct) (rangeZero l) (undefined :: a) + i <- newSym base + 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 + 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 + 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) + 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 + 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 +compileVArray (UnsafeFreezeVArray (VArrayC arr)) = return $ IArrayC arr +compileVArray (UnsafeThawVArray (IArrayC arr)) = return $ VArrayC arr -named :: V.Identifier -> V.SubtypeIndication -named i = V.SubtypeIndication Nothing (V.TMType (V.NSimple i)) Nothing +runVArray :: VArrayCMD (Param3 IO IO pred) a -> IO a +runVArray (NewVArray _ len) = + do len' <- len + arr <- IA.newArray_ (0, len') + return (VArrayE arr) +runVArray (InitVArray _ is) = + 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 + if (ix < l || ix > h) + 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 + e' <- e + if (ix < l || ix > h) + then error "setArr out of bounds" + else IA.writeArray arr (fromIntegral ix) e' +runVArray (CopyVArray (VArrayE arr, oa) (VArrayE brr, ob) l) = + do oa' <- oa + ob' <- ob + l' <- l + (0, ha) <- IA.getBounds arr + (0, hb) <- IA.getBounds brr + if (l' > hb + 1 - oa' || l' > ha + 1 - ob') + then error "copyArr out of bounts" + else sequence_ [ IA.readArray brr (i+ob') >>= IA.writeArray arr (i+oa') + | 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 => Interp (LoopCMD exp) VHDL +instance (CompileExp exp, CompileType ct) => Interp LoopCMD VHDL (Param2 exp ct) where interp = compileLoop -instance EvaluateExp exp => Interp (LoopCMD exp) IO +instance InterpBi LoopCMD IO (Param1 pred) where - interp = runLoop + interpBi = runLoop -compileLoop :: forall exp a. CompileExp exp => LoopCMD exp VHDL a -> VHDL a -compileLoop (For r step) = - do hi <- compE r - (v, i) <- freshVar - loop <- V.inFor i (V.range zero V.to (lift hi)) (step v) +compileLoop :: forall ct exp a. (CompileExp exp, CompileType ct) => LoopCMD (Param3 VHDL exp ct) a -> VHDL 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)) V.addSequential $ V.SLoop $ loop compileLoop (While cont step) = do l <- V.newLabel - loop <- V.inWhile l (Nothing) $ + loop <- V.inWhile l Nothing $ do b <- cont exit <- compE b V.exit l exit step V.addSequential $ V.SLoop $ loop -runLoop :: forall exp prog a. EvaluateExp exp => LoopCMD exp IO a -> IO a -runLoop (For r step) = loop (evalE r) +runLoop :: LoopCMD (Param3 IO IO pred) a -> IO a +runLoop (For l u step) = + do l' <- l + u' <- u + loop l' u' where - loop i | i > 0 = step (litE i) >> loop (i - 1) - | otherwise = return () + loop l u | l <= u = step (ValE l) >> loop (l + 1) u + | otherwise = return () runLoop (While b step) = loop where - loop = b >>= flip when (step >> loop) . evalE + loop = do e <- join b + when e (step >> loop) -------------------------------------------------------------------------------- -- ** Conditional. -instance CompileExp exp => Interp (ConditionalCMD exp) VHDL +instance (CompileExp exp, CompileType ct) => Interp ConditionalCMD VHDL (Param2 exp ct) where interp = compileConditional -instance EvaluateExp exp => Interp (ConditionalCMD exp) IO +instance InterpBi ConditionalCMD IO (Param1 pred) where - interp = runConditional + interpBi = runConditional -compileConditional :: forall exp a. CompileExp exp => ConditionalCMD exp VHDL a -> VHDL a +compileConditional :: forall ct exp a. (CompileExp exp, CompileType ct) => ConditionalCMD (Param3 VHDL exp ct) a -> VHDL a compileConditional (If (a, b) cs em) = do let (es, ds) = unzip cs - el = maybe (return ()) id em + el = maybe (return ()) id em ae <- compE a ese <- mapM compE 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 + 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 (When (Is e) p) = do + e' <- compileLit (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 + return $ (V.Choices [V.between $ range l' V.to h'], p) +compileConditional (Null) = V.null -runConditional :: forall exp a. EvaluateExp exp => ConditionalCMD exp IO a -> IO a -runConditional (If (a, b) cs em) = if (evalE a) then b else loop cs +runConditional :: ConditionalCMD (Param3 IO IO pred) a -> IO a +runConditional (If (a, b) cs em) = + do c <- a + if c then b else loop cs where - loop [] = maybe (return ()) id em - loop ((c, p):xs) = if (evalE c) then p else (loop xs) + loop [] = maybe (return ()) id em + loop ((c, p):xs) = do + b <- c + if b then p else (loop xs) +runConditional (Case e cs d) = + do c <- e + loop c cs + where + loop v [] = maybe (return ()) id d + loop v ((When (Is u) p):cs) = if v == u then p else loop v cs + loop v ((When (To l h) p):cs) = if v > l && v < h then p else loop v cs +runConditional (Null) = return () -------------------------------------------------------------------------------- +-- ** Components. + +instance (CompileExp exp, CompileType ct) => Interp ComponentCMD VHDL (Param2 exp ct) + where + interp = compileComponent + +instance InterpBi ComponentCMD IO (Param1 pred) + where + interpBi = runComponent + +compileComponent :: forall ct exp a. (CompileExp exp, CompileType ct) => ComponentCMD (Param3 VHDL exp ct) a -> VHDL a +compileComponent (StructComponent base 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) = + 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) + +runComponent :: ComponentCMD (Param3 IO IO pred) a -> IO a +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) = + 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) = + do i <- newSym n + t <- compTA (Proxy::Proxy ct) (rangePoint l) (proxyF af) + V.array (ident' i) m t Nothing + traverseSig (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 + 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 + 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 => Interp (StructuralCMD exp) VHDL +instance (CompileExp exp, CompileType ct) => Interp StructuralCMD VHDL (Param2 exp ct) where interp = compileStructural -instance EvaluateExp exp => Interp (StructuralCMD exp) IO +instance InterpBi StructuralCMD IO (Param1 pred) where - interp = runStructural + interpBi = runStructural -compileStructural :: forall exp a. CompileExp exp => StructuralCMD exp VHDL a -> VHDL a -compileStructural (Entity e prog) = V.entity (toIdent e) prog -compileStructural (Architecture e a prog) = V.architecture (toIdent e) (toIdent a) prog -compileStructural (Process xs prog) = +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 reveal xs) prog + (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." + +-------------------------------------------------------------------------------- +-- ** VHDL. + +instance (CompileExp exp, CompileType ct) => Interp VHDLCMD VHDL (Param2 exp ct) where - reveal :: SignalX -> V.Identifier - reveal (SignalX s) = toIdent s + interp = compileVHDL -runStructural :: forall exp a. EvaluateExp exp => StructuralCMD exp IO a -> IO a -runStructural (Entity _ prog) = prog -runStructural (Architecture _ _ prog) = prog -runStructural (Process xs prog) = error "todo: run process" +instance InterpBi VHDLCMD IO (Param1 pred) + 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 (GetBit (SignalC bits) ix) = + do i <- freshVar (Proxy::Proxy ct) (Base "b") + ix' <- compE 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) + 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') + return i + +runVHDL :: VHDLCMD (Param3 IO IO pred) a -> IO a +runVHDL = error "hardware-edsl.runVHDL: todo." + +-------------------------------------------------------------------------------- +-- Helpers. +-- +-- todo : make a lift that first tries to go backwards. If that's not possible, +-- perform a regular lift. This should get rid of most extra parenthesis. + +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 + +-------------------------------------------------------------------------------- + +simple :: String -> V.Name +simple s = V.simple s + +simple' :: String -> V.Expression +simple' s = lift $ V.name $ simple s + +indexed :: String -> V.Expression -> V.Name +indexed s = V.indexed $ V.simple s + +indexed' :: String -> V.Expression -> V.Expression +indexed' s = lift . V.name . indexed s + +slice :: String -> V.Range -> V.Name +slice s = V.slice $ V.simple s + +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 + +-------------------------------------------------------------------------------- + +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) + +rangePoint :: Integral a => a -> V.Range +rangePoint a = V.range (V.point $ toInteger a) V.downto (V.point 0) + +-------------------------------------------------------------------------------- +-- ... + +unpackShift :: V.Expression -> V.ShiftExpression +unpackShift (V.ENand (V.Relation s Nothing) Nothing) = s +unpackShift e = lift e + +unpackSimple :: V.Expression -> V.SimpleExpression +unpackSimple (V.ENand (V.Relation (V.ShiftExpression s Nothing) Nothing) Nothing) = s +unpackSimple e = lift e + +unpackTerm :: V.Expression -> V.Term +unpackTerm (V.ENand (V.Relation (V.ShiftExpression (V.SimpleExpression Nothing t []) Nothing) Nothing) Nothing) = t +unpackTerm e = lift e + +-------------------------------------------------------------------------------- + + +-------------------------------------------------------------------------------- +{- +ident :: String -> V.Identifier +ident s = V.Ident s + +ident' :: Name -> V.Identifier +ident' (Base n) = ident n +ident' (Exact n) = ident n + +name :: String -> V.Primary +name = V.PrimName . V.NSimple . ident +-} +-------------------------------------------------------------------------------- +{- +fromIdent :: ToIdent a => a -> V.Identifier +fromIdent a = let (Ident i) = toIdent a in ident i +-} -------------------------------------------------------------------------------- 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 @@ -1,213 +1,620 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} module Language.Embedded.Hardware.Command.CMD where -import Language.Embedded.VHDL (Mode) -import Language.Embedded.Hardware.Interface (PredicateExp) +import Language.Embedded.VHDL (Mode) +import Language.Embedded.Hardware.Interface +import Language.Embedded.Hardware.Expression.Represent (Inhabited, Sized) +import Language.Embedded.Hardware.Expression.Represent.Bit (Bit, Bits) +import Control.Monad.Reader (ReaderT(..), runReaderT, lift) import Control.Monad.Operational.Higher +import Data.Typeable (Typeable) import Data.Ix (Ix) import Data.IORef (IORef) import Data.Array.IO (IOArray) +import qualified Data.Array as Arr +import qualified Language.VHDL as V (Expression, Name, Identifier) + +import GHC.TypeLits (KnownNat) +import qualified GHC.Exts as GHC (Constraint) + -------------------------------------------------------------------------------- -- * Hardware commands. -------------------------------------------------------------------------------- +data Name = None | Base VarId | Exact VarId + +-- | ... +swapM :: Monad m => Maybe (m a) -> m (Maybe a) +swapM = maybe (return Nothing) (>>= return . Just) + -------------------------------------------------------------------------------- --- ** Signals. +-- ** Values. --- | If a signal is declared with a scope of 'Entity' its classified as either a --- port or generic signal. -data Clause = Port | Generic - deriving (Show) +-- | Value representation. +data Val a = ValC String | ValE a --- | Scope of a signal. -data Scope = SProcess | SArchitecture | SEntity - deriving (Show) +-- | ... +valToExp :: (PredicateExp exp a, FreeExp exp) => Val a -> exp a +valToExp (ValC i) = varE i +valToExp (ValE a) = litE a +-------------------------------------------------------------------------------- +-- ** Signals. + -- | Signal representation. -data Signal a = SignalC Integer | SignalE (IORef a) +data Signal a = SignalC VarId | SignalE (IORef a) -- | Commands for signals. -data SignalCMD (exp :: * -> *) (prog :: * -> *) a +data SignalCMD fs a where -- ^ Create a new signal. - NewSignal :: PredicateExp exp a => Clause -> Scope -> Mode -> Maybe (exp a) -> SignalCMD exp prog (Signal a) + NewSignal :: pred a => Name -> Mode -> Maybe (exp a) -> SignalCMD (Param3 prog exp pred) (Signal a) -- ^ Fetch the contents of a signal. - GetSignal :: PredicateExp exp a => Signal a -> SignalCMD exp prog (exp a) + GetSignal :: pred a => Signal a -> SignalCMD (Param3 prog exp pred) (Val a) -- ^ Write the value to a signal. - SetSignal :: PredicateExp exp a => Signal a -> exp a -> SignalCMD exp prog () + SetSignal :: pred a => Signal a -> exp a -> SignalCMD (Param3 prog exp pred) () -- ^ Unsafe version of fetching a signal. - UnsafeFreezeSignal :: PredicateExp exp a => Signal a -> SignalCMD exp prog (exp a) - -type instance IExp (SignalCMD e) = e -type instance IExp (SignalCMD e :+: i) = e + 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 exp) +instance HFunctor SignalCMD where - hfmap _ (NewSignal c s m e) = NewSignal c s m e - hfmap _ (GetSignal s) = GetSignal s - hfmap _ (SetSignal s e) = SetSignal s e + hfmap _ (NewSignal n m e) = NewSignal n m 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 _ _ (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 + -------------------------------------------------------------------------------- -- ** Variables. -- | Variable representation. -data Variable a = VariableC Integer | VariableE (IORef a) +data Variable a = VariableC VarId | VariableE (IORef a) -- | Commands for variables. -data VariableCMD (exp :: * -> *) (prog :: * -> *) a +data VariableCMD fs a where -- ^ Create a new variable. - NewVariable :: PredicateExp exp a => Maybe (exp a) -> VariableCMD exp prog (Variable a) + NewVariable :: pred a => Name -> Maybe (exp a) -> VariableCMD (Param3 prog exp pred) (Variable a) -- ^ Fetch the contents of a variable. - GetVariable :: PredicateExp exp a => Variable a -> VariableCMD exp prog (exp a) + GetVariable :: pred a => Variable a -> VariableCMD (Param3 prog exp pred) (Val a) -- ^ Write the value to a variable. - SetVariable :: PredicateExp exp a => Variable a -> exp a -> VariableCMD exp prog () + SetVariable :: pred a => Variable a -> exp a -> VariableCMD (Param3 prog exp pred) () -- ^ Unsafe version of fetching a variable. - UnsafeFreezeVariable :: PredicateExp exp a => Variable a -> VariableCMD exp prog (exp a) - -type instance IExp (VariableCMD e) = e -type instance IExp (VariableCMD e :+: i) = e + UnsafeFreezeVariable :: pred a => Variable a -> VariableCMD (Param3 prog exp pred) (Val a) -instance HFunctor (VariableCMD exp) +instance HFunctor VariableCMD where - hfmap _ (NewVariable e) = NewVariable e - hfmap _ (GetVariable s) = GetVariable s - hfmap _ (SetVariable s e) = SetVariable s e + hfmap _ (NewVariable n e) = NewVariable n e + hfmap _ (GetVariable s) = GetVariable s + hfmap _ (SetVariable s e) = SetVariable s e hfmap _ (UnsafeFreezeVariable s) = UnsafeFreezeVariable s +instance HBifunctor VariableCMD + where + hbimap _ f (NewVariable n e) = NewVariable n (fmap f e) + hbimap _ _ (GetVariable v) = GetVariable v + hbimap _ f (SetVariable v e) = SetVariable v (f e) + hbimap _ _ (UnsafeFreezeVariable v) = UnsafeFreezeVariable v + +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 + +-------------------------------------------------------------------------------- -- ** Arrays. -- | Expression types that support compilation of array indexing class CompArrayIx exp where -- | Generate code for an array indexing operation - compArrayIx :: PredicateExp exp a => exp i -> Array i a -> Maybe (exp a) + compArrayIx :: (PredicateExp exp a, Integral i, Ix i) => exp i -> Array i a -> Maybe (exp a) compArrayIx _ _ = Nothing -- | Array reprensentation. -data Array i a = ArrayC Integer | ArrayE (IORef (IOArray i a)) +data Array i a = ArrayC VarId | ArrayE (IOArray i a) --- | Commands for arrays. -data ArrayCMD (exp :: * -> *) (prog :: * -> *) a +-- | Commands for signal arrays. +data ArrayCMD fs a where -- ^ Creates an array of given length. - NewArray - :: ( PredicateExp exp a - , PredicateExp exp i - , Integral i - , Ix i ) - => exp i -> ArrayCMD exp prog (Array i a) + NewArray :: (pred a, Integral i, Ix i) => Name -> exp i -> ArrayCMD (Param3 prog exp pred) (Array i a) -- ^ Creates an array from the given list of elements. - InitArray - :: ( PredicateExp exp a - , PredicateExp exp i - , Integral i - , Ix i ) - => [a] -> ArrayCMD exp prog (Array i a) + InitArray :: (pred a, Integral i, Ix i) => Name -> [a] -> ArrayCMD (Param3 prog exp pred) (Array i 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) + -- ^ 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) () + -- ^ 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) () + -- ^ 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) () + +instance HFunctor ArrayCMD + where + hfmap _ (NewArray n i) = NewArray n i + hfmap _ (InitArray n is) = InitArray n is + 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 _ (ResetArray a r) = ResetArray a r + +instance HBifunctor ArrayCMD + where + hbimap _ f (NewArray n i) = NewArray n (f i) + hbimap _ _ (InitArray n is) = InitArray n is + 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 _ f (ResetArray a r) = ResetArray a (f r) + +instance (ArrayCMD :<: instr) => Reexpressible ArrayCMD instr env + where + reexpressInstrEnv reexp (NewArray n i) + = lift . singleInj . NewArray n =<< reexp i + reexpressInstrEnv reexp (InitArray n is) + = lift $ singleInj $ InitArray n is + reexpressInstrEnv reexp (GetArray a i) + = do i' <- reexp i; lift $ singleInj $ GetArray a i' + reexpressInstrEnv reexp (SetArray a i e) + = do i' <- reexp i; e' <- reexp e; lift $ singleInj $ SetArray a i' e' + 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 (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) + deriving (Eq, Typeable) + +-- | Immutable arrays. +data IArray i a = IArrayC VarId | IArrayE (Arr.Array i 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) + -- ^ 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) -- ^ Fetches the array's value at a specified index. - GetArray - :: ( PredicateExp exp a - , PredicateExp exp i - , Integral i - , Ix i ) - => exp i -> Array i a -> ArrayCMD exp prog (exp a) + GetVArray :: (pred a, Integral i, Ix i) => VArray i a -> exp i -> VArrayCMD (Param3 prog exp pred) (Val a) -- ^ Writes a value to an array at some specified index. - SetArray - :: ( PredicateExp exp a - , PredicateExp exp i - , Integral i - , Ix i ) - => exp i -> exp a -> Array i a -> ArrayCMD exp prog () - -- ^ Unsafe version of fetching an array's value. - UnsafeGetArray - :: ( PredicateExp exp a - , PredicateExp exp i - , Integral i - , Ix i ) - => exp i -> Array i a -> ArrayCMD exp prog (exp a) + SetVArray :: (pred a, Integral i, Ix i) => VArray i a -> exp i -> 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) () + -- ^ ... + UnsafeFreezeVArray :: (pred a, Integral i, Ix i) => VArray i a -> VArrayCMD (Param3 prog exp pred) (IArray i a) + -- ^ ... + UnsafeThawVArray :: (pred a, Integral i, Ix i) => IArray i a -> VArrayCMD (Param3 prog exp pred) (VArray i a) -type instance IExp (ArrayCMD e) = e -type instance IExp (ArrayCMD e :+: i) = e +instance HFunctor VArrayCMD + where + hfmap _ (NewVArray n i) = NewVArray n i + hfmap _ (InitVArray n is) = InitVArray n is + hfmap _ (GetVArray a i) = GetVArray a i + hfmap _ (SetVArray a i e) = SetVArray a i e + hfmap _ (CopyVArray a b l) = CopyVArray a b l + hfmap _ (UnsafeFreezeVArray a) = UnsafeFreezeVArray a + hfmap _ (UnsafeThawVArray a) = UnsafeThawVArray a -instance HFunctor (ArrayCMD exp) +instance HBifunctor VArrayCMD where - hfmap _ (NewArray i) = NewArray i - hfmap _ (InitArray is) = InitArray is - hfmap _ (GetArray i a) = GetArray i a - hfmap _ (SetArray i e a) = SetArray i e a - hfmap _ (UnsafeGetArray i a) = UnsafeGetArray i a + hbimap _ f (NewVArray n i) = NewVArray n (f i) + hbimap _ _ (InitVArray n is) = InitVArray n is + hbimap _ f (GetVArray a i) = GetVArray a (f i) + hbimap _ f (SetVArray a i e) = SetVArray a (f i) (f e) + hbimap _ f (CopyVArray (a, oa) (b, ob) l) = CopyVArray (a, f oa) (b, f ob) (f l) + hbimap _ _ (UnsafeFreezeVArray a) = UnsafeFreezeVArray a + hbimap _ _ (UnsafeThawVArray a) = UnsafeThawVArray a +instance (VArrayCMD :<: instr) => Reexpressible VArrayCMD instr env + where + reexpressInstrEnv reexp (NewVArray n i) + = lift . singleInj . NewVArray n =<< reexp i + reexpressInstrEnv reexp (InitVArray n is) + = lift $ singleInj $ InitVArray n is + reexpressInstrEnv reexp (GetVArray a i) + = do i' <- reexp i; lift $ singleInj $ GetVArray a i' + reexpressInstrEnv reexp (SetVArray a i e) + = do i' <- reexp i; e' <- reexp e; lift $ singleInj $ SetVArray a i' e' + reexpressInstrEnv reexp (CopyVArray (a, oa) (b, ob) l) + = do oa' <- reexp oa; ob' <- reexp ob; l' <- reexp l + lift $ singleInj $ CopyVArray (a, oa') (b, ob') l' + reexpressInstrEnv reexp (UnsafeFreezeVArray a) + = lift $ singleInj $ UnsafeFreezeVArray a + reexpressInstrEnv reexp (UnsafeThawVArray a) + = lift $ singleInj $ UnsafeThawVArray a + -------------------------------------------------------------------------------- -- ** Looping. -- | Commands for looping constructs. -data LoopCMD (exp :: * -> *) (prog :: * -> *) a +data LoopCMD fs a where -- ^ Creates a new for loop. - For :: (PredicateExp exp n, Integral n) => exp n -> (exp n -> prog ()) -> LoopCMD exp prog () + For :: (pred i, Integral i) => exp i -> exp i -> (Val i -> prog ()) -> LoopCMD (Param3 prog exp pred) () -- ^ Creates a new while loop. - While :: PredicateExp exp Bool => prog (exp Bool) -> prog () -> LoopCMD exp prog () - -type instance IExp (LoopCMD e) = e -type instance IExp (LoopCMD e :+: i) = e + While :: prog (exp Bool) -> prog () -> LoopCMD (Param3 prog exp pred) () -instance HFunctor (LoopCMD exp) +instance HFunctor LoopCMD where - hfmap f (For r step) = For r (f . step) + hfmap f (For l u step) = For l u (f . step) hfmap f (While cont step) = While (f cont) (f step) +instance HBifunctor LoopCMD + where + hbimap g f (For l u step) = For (f l) (f u) (g . step) + hbimap g f (While cont step) = While (g $ fmap f cont) (g step) + +instance (LoopCMD :<: instr) => Reexpressible LoopCMD instr env + where + reexpressInstrEnv reexp (For l u step) = do + l' <- reexp l + u' <- reexp u + ReaderT $ \env -> singleInj $ + For l' u' (flip runReaderT env . step) + reexpressInstrEnv reexp (While cont step) = do + ReaderT $ \env -> singleInj $ + While (runReaderT (cont >>= reexp) env) + (runReaderT step env) + -------------------------------------------------------------------------------- -- ** Conditional statements. +-- | ... +data When a prog = When (Constraint a) (prog ()) + +-- | ... +data Constraint a where + Is :: Eq a => a -> Constraint a + To :: Ord a => a -> a -> Constraint a + -- | Commnads for conditional statements. -data ConditionalCMD (exp :: * -> *) (prog :: * -> *) a +data ConditionalCMD fs a where - If :: PredicateExp exp Bool - => (exp Bool, prog ()) -- if - -> [(exp Bool, prog ())] -- else-if - -> Maybe (prog ()) -- else - -> ConditionalCMD exp prog () + -- ^ ... + If :: (exp Bool, prog ()) -> [(exp Bool, prog ())] -> Maybe (prog ()) -> ConditionalCMD (Param3 prog exp pred) () + -- ^ ... + Case :: pred a => exp a -> [When a prog] -> Maybe (prog ()) -> ConditionalCMD (Param3 prog exp pred) () + -- ^ ... + Null :: ConditionalCMD (Param3 prog exp pred) () -type instance IExp (ConditionalCMD e) = e -type instance IExp (ConditionalCMD e :+: i) = e +instance HFunctor ConditionalCMD + where + hfmap f (If a cs b) = If (fmap f a) (fmap (fmap f) cs) (fmap f b) + hfmap f (Case e xs d) = Case e (fmap (wmap f) xs) (fmap f d) + where wmap f (When a p) = When a (f p) + hfmap _ (Null) = Null -instance HFunctor (ConditionalCMD exp) +instance HBifunctor ConditionalCMD where - hfmap f (If a cs b) = If (fmap f a) (fmap (fmap f) cs) (fmap f b) + hbimap g f (If a cs b) = If (pmap a) (fmap pmap cs) (fmap g b) + where pmap (x, y) = (f x, g y) + hbimap g f (Case e xs d) = Case (f e) (fmap wmap xs) (fmap g d) + where wmap (When a p) = When a (g p) + hbimap _ _ (Null) = Null +instance (ConditionalCMD :<: instr) => Reexpressible ConditionalCMD instr env + where + reexpressInstrEnv reexp (If (c, a) cs b) = + do let (xs, ys) = unzip cs + c' <- reexp c + xs' <- mapM reexp xs + ReaderT $ \env -> + let ys' = fmap (flip runReaderT env) ys + in singleInj $ + If (c', runReaderT a env) + (zip xs' ys') + (fmap (flip runReaderT env) b) + reexpressInstrEnv reexp (Case c cs d) = + do let (xs, ys) = unzipWhen cs + c' <- reexp c + ReaderT $ \env -> + let ys' = fmap (flip runReaderT env) ys + in singleInj $ + Case c' + (zipWhen xs ys') + (fmap (flip runReaderT env) d) + reexpressInstrEnv reexp (Null) = lift $ singleInj $ Null + +unzipWhen :: [When a p] -> ([Constraint a], [p ()]) +unzipWhen = unzip . fmap (\(When a p) -> (a, p)) + +zipWhen :: [Constraint a] -> [p ()] -> [When a p] +zipWhen x y = fmap (\(a, p) -> When a p) $ zip x y + -------------------------------------------------------------------------------- +-- ** Components. + +-- | Signature description. +data Signature fs a + where + Ret :: prog () -> Signature (Param3 prog exp pred) () + SSig :: (pred a, Inhabited a, Sized a) + => Name -> Mode + -> (Signal a -> Signature (Param3 prog exp pred) b) + -> Signature (Param3 prog exp pred) (Signal a -> b) + SArr :: (pred a, Inhabited a, Sized 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) + +instance HFunctor Signature + where + hfmap f (Ret m) = Ret (f m) + hfmap f (SSig n m sig) = SSig n m (hfmap f . sig) + hfmap f (SArr n m l arr) = SArr n m l (hfmap f . arr) + +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 (SArr n m l sig) = SArr n m l (hbimap g f . sig) + +reexpressSignature :: env + -> Signature (Param3 (ReaderT env (ProgramT instr (Param2 exp2 pred) m)) exp1 pred) a + -> Signature (Param3 (ProgramT instr (Param2 exp2 pred) m) exp2 pred) a +reexpressSignature env (Ret prog) = Ret (runReaderT prog env) +reexpressSignature env (SSig n m sf) = SSig n m (reexpressSignature env . sf) +reexpressSignature env (SArr n m l af) = SArr n m l (reexpressSignature env . af) + +-- | Signature arguments. +data Argument pred a + where + Nil :: Argument pred () + ASig :: (pred a, Inhabited a, Sized a) + => Signal a + -> Argument pred b + -> Argument pred (Signal a -> b) + AArr :: (pred a, Inhabited a, Sized a, Integral i, Ix i) + => Array i a + -> Argument pred b + -> Argument pred (Array i a -> b) + +-- | Named components. +data Component fs a = Component 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 + :: Name + -> Signature (Param3 prog exp pred) a + -> ComponentCMD (Param3 prog exp pred) String + -- ^ Call for interfacing with a component. + PortMap + :: Component (Param3 prog exp pred) a + -> Argument pred a + -> ComponentCMD (Param3 prog exp pred) () + +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 + +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 + +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 + +-------------------------------------------------------------------------------- -- ** Structural entities. --- | Untyped signals. -data SignalX = forall a. SignalX (Signal a) +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 + -- | Commands for structural entities. -data StructuralCMD (exp :: * -> *) (prog :: * -> *) a +data StructuralCMD fs (a :: *) where -- ^ Wraps the program in an entity. - Entity :: String -> prog a -> StructuralCMD exp prog a + StructEntity + :: Name -> prog a -> StructuralCMD (Param3 prog exp pred) a -- ^ Wraps the program in an architecture. - Architecture :: String -> String -> prog a -> StructuralCMD exp prog a + StructArchitecture + :: Name -> Name -> prog a -> StructuralCMD (Param3 prog exp pred) a -- ^ Wraps the program in a process. - Process :: [SignalX] -> prog () -> StructuralCMD exp prog () + StructProcess + :: [Ident] -> prog () -> StructuralCMD (Param3 prog exp pred) () -type instance IExp (StructuralCMD e) = e -type instance IExp (StructuralCMD e :+: i) = e +-- todo: make sure entity and architectures always share a name. -instance HFunctor (StructuralCMD exp) +instance HFunctor StructuralCMD where - hfmap f (Entity e p) = Entity e (f p) - hfmap f (Architecture e a p) = Architecture e a (f p) - hfmap f (Process xs p) = Process xs (f p) + 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) + +instance HBifunctor StructuralCMD + 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) + +instance (StructuralCMD :<: instr) => Reexpressible StructuralCMD 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 + +-------------------------------------------------------------------------------- + +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. + -- todo: The second argument should be over a variable. + CopyBits :: (pred a, pred b, Integral i, Ix i) + => (Signal a, exp i) + -> (Signal b, exp i) + -> exp i + -> VHDLCMD (Param3 prog exp pred) () + CopyVBits :: (pred a, pred b, Integral i, Ix i) + => (Variable a, exp i) + -> (Signal b, exp i) + -> exp i + -> VHDLCMD (Param3 prog exp pred) () + -- todo: These two should be expressions instead. + GetBit :: (pred a, pred Bit, Integral i, Ix i) + => Signal a + -> exp i + -> VHDLCMD (Param3 prog exp pred) (Val Bit) + SetBit :: (pred a, pred Bit, Integral i, Ix i) + => Signal a + -> exp i + -> exp Bit + -> VHDLCMD (Param3 prog exp pred) () + -- todo: same as above two?... + -- todo: result should be i?... + GetBits :: (pred i, Integral i, Ix i) + => Signal (Bits n) + -> exp i + -> exp i + -> VHDLCMD (Param3 prog exp pred) (Val i) + +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 + +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) + +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 (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 (GetBit s i) + = do i' <- reexp i + lift $ singleInj $ GetBit s i' + reexpressInstrEnv reexp (SetBit s i b) + = do i' <- reexp i; b' <- reexp b + lift $ singleInj $ SetBit s i' b' + reexpressInstrEnv reexp (GetBits s l u) + = do l' <- reexp l; u' <- reexp u + lift $ singleInj $ GetBits s l' u' -------------------------------------------------------------------------------- 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 @@ -1,199 +1,526 @@ -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE PolyKinds #-} module Language.Embedded.Hardware.Command.Frontend where -import Language.Embedded.VHDL (Mode(..)) -import Language.Embedded.Hardware.Interface (PredicateExp) +import Language.Embedded.VHDL (Mode(..)) +import Language.Embedded.Hardware.Interface import Language.Embedded.Hardware.Command.CMD +import Language.Embedded.Hardware.Expression.Represent +import Language.Embedded.Hardware.Expression.Represent.Bit + import Control.Monad.Operational.Higher -import Data.Ix (Ix) +import Data.Ix (Ix) +import Data.IORef (readIORef) +import Data.Int +import Data.Word +import System.IO.Unsafe -- used for `veryUnsafeFreezeVariable`. + +import GHC.TypeLits (KnownNat) + -------------------------------------------------------------------------------- +-- * Hardware frontend. +-------------------------------------------------------------------------------- + +-------------------------------------------------------------------------------- -- ** Signals. +-- | 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 + -- | Declare a signal. -newSignal :: (SignalCMD (IExp i) :<: i, PredicateExp (IExp i) a) => IExp i a -> ProgramT i m (Signal a) -newSignal = singleE . NewSignal Port SArchitecture InOut . Just +initSignal :: (SignalCMD :<: instr, pred a) => exp a -> ProgramT instr (Param2 exp pred) m (Signal a) +initSignal = initNamedSignal "s" +-- | 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 + -- | Declare an uninitialized signal. -newSignal_ :: (SignalCMD (IExp i) :<: i, PredicateExp (IExp i) a) => ProgramT i m (Signal a) -newSignal_ = singleE $ NewSignal Port SArchitecture InOut Nothing +newSignal :: (SignalCMD :<: instr, pred a) => ProgramT instr (Param2 exp pred) m (Signal a) +newSignal = newNamedSignal "s" -- | Fetches the current value of a signal. -getSignal :: (SignalCMD (IExp i) :<: i, PredicateExp (IExp i) a) => Signal a -> ProgramT i m (IExp i a) -getSignal = singleE . GetSignal +getSignal :: (SignalCMD :<: instr, pred a, FreeExp exp, PredicateExp exp a, Monad m) + => Signal a -> ProgramT instr (Param2 exp pred) m (exp a) +getSignal = fmap valToExp . singleInj . GetSignal -- | Update the value of a signal. -setSignal :: (SignalCMD (IExp i) :<: i, PredicateExp (IExp i) a) => Signal a -> IExp i a -> ProgramT i m () -setSignal s = singleE . SetSignal s +setSignal :: (SignalCMD :<: instr, pred a) => Signal a -> exp a -> ProgramT instr (Param2 exp pred) m () +setSignal s = singleInj . SetSignal s -- | Unsafe version of fetching the contents of a signal. -unsafeFreezeSignal :: (SignalCMD (IExp i) :<: i, PredicateExp (IExp i) a) => Signal a -> ProgramT i m (IExp i a) -unsafeFreezeSignal = singleE . UnsafeFreezeSignal +unsafeFreezeSignal :: (SignalCMD :<: instr, pred a, FreeExp exp, PredicateExp exp a, Monad m) + => 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. -newPort :: (SignalCMD (IExp i) :<: i, PredicateExp (IExp i) a) => Mode -> IExp i a -> ProgramT i m (Signal a) -newPort m = singleE . NewSignal Port SEntity m . Just +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. -newPort_ :: (SignalCMD (IExp i) :<: i, PredicateExp (IExp i) a) => Mode -> ProgramT i m (Signal a) -newPort_ m = singleE $ NewSignal Port SEntity m Nothing +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 --- | Declare generic signals of the given mode and assign it initial value. -newGeneric :: (SignalCMD (IExp i) :<: i, PredicateExp (IExp i) a) => Mode -> IExp i a -> ProgramT i m (Signal a) -newGeneric m = singleE . NewSignal Generic SEntity m . Just +newPort :: (SignalCMD :<: instr, pred a) => Mode -> ProgramT instr (Param2 exp pred) m (Signal a) +newPort = newNamedPort "p" --- | Declare generic signals of the given mode. -newGeneric_ :: (SignalCMD (IExp i) :<: i, PredicateExp (IExp i) a) => Mode -> ProgramT i m (Signal a) -newGeneric_ m = singleE $ NewSignal Generic SEntity m Nothing +-------------------------------------------------------------------------------- +-- short-hands. --- | Short-hand for 'setSignal'. -(<==) :: (SignalCMD (IExp i) :<: i, PredicateExp (IExp i) a) => Signal a -> IExp i a -> ProgramT i m () -(<==) = setSignal +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 + -> ProgramT instr (Param2 exp pred) m () +(<--) s e = s <== (litE e) + +(<==) :: (SignalCMD :<: instr, pred a) + => Signal a + -> exp a + -> ProgramT instr (Param2 exp pred) m () +(<==) s e = setSignal s e + +(<=-) :: (SignalCMD :<: instr, pred a, PredicateExp exp a, FreeExp exp, Monad m) + => Signal a + -> Signal a + -> ProgramT instr (Param2 exp pred) m () +(<=-) s v = do v' <- unsafeFreezeSignal v; s <== v' + -------------------------------------------------------------------------------- -- ** Variables. +-- | Declare a named variable. +initNamedVariable :: (VariableCMD :<: instr, pred a) + => String -> exp a -> ProgramT instr (Param2 exp pred) m (Variable a) +initNamedVariable name = singleInj . NewVariable (Base name) . Just + -- | Declare a variable. -newVariable :: (VariableCMD (IExp i) :<: i, PredicateExp (IExp i) a) => IExp i a -> ProgramT i m (Variable a) -newVariable = singleE . NewVariable . Just +initVariable :: (VariableCMD :<: instr, pred a) => exp a -> ProgramT instr (Param2 exp pred) m (Variable a) +initVariable = initNamedVariable "v" +-- | Declare an uninitialized named variable. +newNamedVariable :: (VariableCMD :<: instr, pred a) + => String -> ProgramT instr (Param2 exp pred) m (Variable a) +newNamedVariable name = singleInj $ NewVariable (Base name) Nothing + -- | Declare an uninitialized variable. -newVariable_ :: (VariableCMD (IExp i) :<: i, PredicateExp (IExp i) a) => ProgramT i m (Variable a) -newVariable_ = singleE $ NewVariable Nothing +newVariable :: (VariableCMD :<: instr, pred a) => ProgramT instr (Param2 exp pred) m (Variable a) +newVariable = newNamedVariable "v" -- | Fetches the current value of a variable. -getVariable :: (VariableCMD (IExp i) :<: i, PredicateExp (IExp i) a) => Variable a -> ProgramT i m (IExp i a) -getVariable = singleE . GetVariable +getVariable :: (VariableCMD :<: instr, pred a, PredicateExp exp a, FreeExp exp, Monad m) + => Variable a -> ProgramT instr (Param2 exp pred) m (exp a) +getVariable = fmap valToExp . singleInj . GetVariable -- | Updates the value of a variable. -setVariable :: (VariableCMD (IExp i) :<: i, PredicateExp (IExp i) a) => Variable a -> IExp i a -> ProgramT i m () -setVariable v = singleE . SetVariable v +setVariable :: (VariableCMD :<: instr, pred a) => Variable a -> exp a -> ProgramT instr (Param2 exp pred) m () +setVariable v = singleInj . SetVariable v -- | Unsafe version of fetching the contents of a variable. -unsafeFreezeVariable :: (VariableCMD (IExp i) :<: i, PredicateExp (IExp i) a) => Variable a -> ProgramT i m (IExp i a) -unsafeFreezeVariable = singleE . UnsafeFreezeVariable +unsafeFreezeVariable :: (VariableCMD :<: instr, pred a, PredicateExp exp a, FreeExp exp, Monad m) + => Variable a -> ProgramT instr (Param2 exp pred) m (exp a) +unsafeFreezeVariable = fmap valToExp . singleInj . UnsafeFreezeVariable +-- | Read the value of a reference without the monad in a very unsafe fashion. +veryUnsafeFreezeVariable :: (PredicateExp exp a, FreeExp exp) => Variable a -> exp a +veryUnsafeFreezeVariable (VariableE r) = litE $! unsafePerformIO $! readIORef r +veryUnsafeFreezeVariable (VariableC v) = varE v + +-------------------------------------------------------------------------------- +-- short-hands. + +variable :: (VariableCMD :<: instr, pred a) => String -> ProgramT instr (Param2 exp pred) m (Variable a) +variable = newNamedVariable + -- | Short-hand for 'setVariable'. -(==:) :: (VariableCMD (IExp i) :<: i, PredicateExp (IExp i) a) => Variable a -> IExp i a -> ProgramT i m () +(==:) :: (VariableCMD :<: instr, pred a) => Variable a -> exp a -> ProgramT instr (Param2 exp pred) m () (==:) = 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 uninitialized array. -newArray - :: ( PredicateExp (IExp instr) a - , PredicateExp (IExp instr) i - , Integral i, Ix i - , ArrayCMD (IExp instr) :<: instr ) - => IExp instr i -> ProgramT instr m (Array i a) -newArray = singleE . NewArray +-- | 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 name = singleInj . InitArray (Base name) --- | Create an initialized array. -initArray - :: ( PredicateExp (IExp instr) a - , PredicateExp (IExp instr) i - , Integral i, Ix i - , ArrayCMD (IExp instr) :<: instr ) - => [a] -> ProgramT instr m (Array i a) -initArray = singleE . InitArray +-- | 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 = 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 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 = 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 + +-- | 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 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. + -> ProgramT instr (Param2 exp pred) m () +copyArray dest src = singleInj . CopyArray dest src + +-- | ... +resetArray :: (ArrayCMD :<: instr, pred a, Integral i, Ix i) + => Array i 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 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 = 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 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 = newNamedVArray "a" + -- | Get an element of an array. -getArray - :: ( PredicateExp (IExp instr) a - , PredicateExp (IExp instr) i - , Integral i, Ix i - , ArrayCMD (IExp instr) :<: instr ) - => IExp instr i -> Array i a -> ProgramT instr m (IExp instr a) -getArray i = singleE . GetArray i +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 -- | Set an element of an array. -setArray - :: ( PredicateExp (IExp instr) a - , PredicateExp (IExp instr) i - , Integral i, Ix i - , ArrayCMD (IExp instr) :<: instr ) - => IExp instr i -> IExp instr a -> Array i a -> ProgramT instr m () -setArray i a = singleE . SetArray i a +setVArray :: (VArrayCMD :<: instr, pred a, Integral i, Ix i) + => VArray i a -> exp i -> exp a -> ProgramT instr (Param2 exp pred) m () +setVArray a i = singleInj . SetVArray a i --- | Unsafe version of fetching the contents of an array's index. -unsafeGetArray - :: ( PredicateExp (IExp instr) a - , PredicateExp (IExp instr) i - , Integral i, Ix i - , ArrayCMD (IExp instr) :<: instr ) - => IExp instr i -> Array i a -> ProgramT instr m (IExp instr a) -unsafeGetArray i = singleE . UnsafeGetArray 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. + -> 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 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 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) +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) +unsafeThawVArray = singleInj . UnsafeThawVArray + -------------------------------------------------------------------------------- -- ** Looping. -- | For loop. -for - :: (LoopCMD (IExp instr) :<: instr, PredicateExp (IExp instr) n, Integral n) - => IExp instr n - -> (IExp instr n -> ProgramT instr m ()) - -> ProgramT instr m () -for range = singleE . For range +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 lower upper body = singleInj $ For lower upper (body . valToExp) -- | While loop. -while - :: (LoopCMD (IExp instr) :<: instr, PredicateExp (IExp instr) Bool) - => ProgramT instr m (IExp instr Bool) - -> ProgramT instr m () - -> ProgramT instr m () -while cond = singleE . While cond +while :: (LoopCMD :<: instr, pred Bool) + => ProgramT instr (Param2 exp pred) m (exp Bool) + -> ProgramT instr (Param2 exp pred) m () + -> ProgramT instr (Param2 exp pred) m () +while cond = singleInj . While cond -------------------------------------------------------------------------------- -- ** Conditional statements. -- | Conditional statements guarded by if and then clauses with an optional else. -conditional - :: (ConditionalCMD (IExp i) :<: i, PredicateExp (IExp i) Bool) - => (IExp i Bool, ProgramT i m ()) - -> [(IExp i Bool, ProgramT i m ())] - -> Maybe (ProgramT i m ()) - -> ProgramT i m () -conditional a bs = singleE . If a bs +conditional :: (ConditionalCMD :<: instr, pred Bool) + => (exp Bool, ProgramT instr (Param2 exp pred) m ()) + -> [(exp Bool, ProgramT instr (Param2 exp pred) m ())] + -> Maybe (ProgramT instr (Param2 exp pred) m ()) + -> ProgramT instr (Param2 exp pred) m () +conditional a bs = singleInj . If a bs -- | Guarded statement. -when - :: (ConditionalCMD (IExp i) :<: i, PredicateExp (IExp i) Bool) - => IExp i Bool - -> ProgramT i m () - -> ProgramT i m () +when :: (ConditionalCMD :<: instr, pred Bool) + => exp Bool + -> ProgramT instr (Param2 exp pred) m () + -> ProgramT instr (Param2 exp pred) m () when e p = conditional (e, p) [] Nothing -- | Standard if-then-else statement. -iff - :: (ConditionalCMD (IExp i) :<: i, PredicateExp (IExp i) Bool) - => IExp i Bool - -> ProgramT i m () - -> ProgramT i m () - -> ProgramT i m () +iff :: (ConditionalCMD :<: instr, pred Bool) + => exp Bool + -> ProgramT instr (Param2 exp pred) m () + -> ProgramT instr (Param2 exp pred) m () + -> ProgramT instr (Param2 exp pred) m () iff b t e = conditional (b, t) [] (Just e) +ifE :: (ConditionalCMD :<: instr, pred Bool) + => (exp Bool, ProgramT instr (Param2 exp pred) m ()) + -> (exp Bool, ProgramT instr (Param2 exp pred) m ()) + -> ProgramT instr (Param2 exp pred) m () +ifE a b = conditional a [b] (Nothing) + -------------------------------------------------------------------------------- + +switch :: (ConditionalCMD :<: instr, pred a, Eq a, Ord a) + => exp a + -> [When a (ProgramT instr (Param2 exp pred) m)] + -> ProgramT instr (Param2 exp pred) m () +switch e choices = singleInj (Case e choices Nothing) + +switched :: (ConditionalCMD :<: instr, pred a, Eq a, Ord a) + => exp a + -> [When a (ProgramT instr (Param2 exp pred) m)] + -> ProgramT instr (Param2 exp pred) m () + -> ProgramT instr (Param2 exp pred) m () +switched e choices def = singleInj (Case e choices (Just def)) + +null :: (ConditionalCMD :<: instr) => ProgramT instr (Param2 exp pred) m () +null = singleInj (Null) + +is :: (Eq a, pred a) + => a + -> ProgramT instr (Param2 exp pred) m () + -> When a (ProgramT instr (Param2 exp pred) m) +is a = When (Is a) + +to :: (Ord a, pred a) + => a + -> a + -> ProgramT instr (Param2 exp pred) m () + -> When a (ProgramT instr (Param2 exp pred) m) +to l h = When (To l h) + +-------------------------------------------------------------------------------- +-- ** Processes. + +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. +namedComponent :: (ComponentCMD :<: instr, Monad m) + => 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 + +-- | Declare a component. +component :: (ComponentCMD :<: instr, Monad m) + => Sig instr exp pred m a + -> ProgramT instr (Param2 exp pred) m (Comp instr exp pred m a) +component = namedComponent "comp" + +-- | Call a component. +portmap :: (ComponentCMD :<: instr) + => Comp instr exp pred m a + -> Argument pred a + -> ProgramT instr (Param2 exp pred) m () +portmap pro arg = singleInj $ PortMap pro arg + +-------------------------------------------------------------------------------- + +exactInput :: (pred a, Inhabited a, Sized a) => String -> (Signal a -> Sig instr exp pred m b) -> Sig instr exp pred m (Signal a -> b) +exactInput n = SSig (Exact n) In + +namedInput :: (pred a, Inhabited a, Sized a) => String -> (Signal a -> Sig instr exp pred m b) -> Sig instr exp pred m (Signal a -> b) +namedInput n = SSig (Base n) In + +input :: (pred a, Inhabited a, Sized a) => (Signal a -> Sig instr exp pred m b) -> Sig instr exp pred m (Signal a -> b) +input = namedInput "in" + +exactInputArr :: (pred a, Inhabited a, Sized 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, 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 + +inputArr :: (pred a, Inhabited a, Sized 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" + +exactOutput :: (pred a, Inhabited a, Sized a) => String -> (Signal a -> Sig instr exp pred m b) -> Sig instr exp pred m (Signal a -> b) +exactOutput n = SSig (Exact n) Out + +namedOutput :: (pred a, Inhabited a, Sized a) => String -> (Signal a -> Sig instr exp pred m b) -> Sig instr exp pred m (Signal a -> b) +namedOutput n = SSig (Base n) Out + +output :: (pred a, Inhabited a, Sized a) => (Signal a -> Sig instr exp pred m b) -> Sig instr exp pred m (Signal a -> b) +output = namedOutput "out" + +exactOutputArr :: (pred a, Inhabited a, Sized 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, 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 + +outputArr :: (pred a, Inhabited a, pred i, Sized a, 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" + +ret :: (ProgramT instr (Param2 exp pred) m) () -> Signature (Param3 (ProgramT instr (Param2 exp pred) m) exp pred) () +ret = Ret + +-------------------------------------------------------------------------------- -- ** Structural entities. -- | Declare a new entity by wrapping the program to declare ports & generics. -entity :: (StructuralCMD (IExp i) :<: i) => String -> ProgramT i m a -> ProgramT i m a -entity e = singleE . Entity e +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 (IExp i) :<: i) => String -> String -> ProgramT i m a -> ProgramT i m a -architecture e a = singleE . Architecture e a +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 (IExp i) :<: i) => [SignalX] -> ProgramT i m () -> ProgramT i m () -process is = singleE . Process is +process :: (StructuralCMD :<: instr) + => [Ident] + -> ProgramT instr (Param2 exp pred) m () + -> ProgramT instr (Param2 exp pred) m () +process is = singleInj . StructProcess is +-------------------------------------------------------------------------------- + +-- | Construct the untyped signal list for processes. +(.:) :: ToIdent a => a -> [Ident] -> [Ident] +(.:) 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) + -- | ... -hideSig :: Signal a -> SignalX -hideSig = SignalX +copyBits :: (VHDLCMD :<: instr, pred a, pred b, Integral i, Ix i) + => (Signal a, exp i) + -> (Signal b, exp i) + -> exp i + -> 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 + -> 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) +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 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 a l u = fmap valToExp $ singleInj $ GetBits a l u -------------------------------------------------------------------------------- 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 @@ -2,8 +2,11 @@ ( HExp , HType , module Language.Embedded.Hardware.Expression.Frontend + , module Language.Embedded.Hardware.Expression.Represent.Bit ) where -import Language.Embedded.Hardware.Expression.Syntax (HExp, HType) +import Language.Embedded.Hardware.Expression.Syntax (HExp) import Language.Embedded.Hardware.Expression.Frontend +import Language.Embedded.Hardware.Expression.Represent (HType) +import Language.Embedded.Hardware.Expression.Represent.Bit import Language.Embedded.Hardware.Expression.Backend.VHDL () diff --git a/src/Language/Embedded/Hardware/Expression/Backend/VHDL.hs b/src/Language/Embedded/Hardware/Expression/Backend/VHDL.hs --- a/src/Language/Embedded/Hardware/Expression/Backend/VHDL.hs +++ b/src/Language/Embedded/Hardware/Expression/Backend/VHDL.hs @@ -1,4 +1,5 @@ {-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -8,7 +9,7 @@ import Language.Syntactic.Functional (Denotation, evalSym) import Language.Embedded.Hardware.Expression.Syntax -import Language.Embedded.Hardware.Expression.Frontend (value, variable) +import Language.Embedded.Hardware.Expression.Frontend (value, var) import Language.Embedded.Hardware.Expression.Represent import Language.Embedded.Hardware.Expression.Hoist (Kind) import Language.Embedded.Hardware.Interface @@ -18,15 +19,24 @@ import qualified Language.VHDL as VHDL import qualified Language.Embedded.VHDL as VHDL +import Data.Proxy (Proxy(..)) + import Control.Applicative -------------------------------------------------------------------------------- -- * Compilation and evaluation of hardware expressions for VHDL. -------------------------------------------------------------------------------- +instance FreeExp HExp + where + type PredicateExp HExp = HType + litE = value + varE = var + +-------------------------------------------------------------------------------- + instance EvaluateExp HExp where - litE = value evalE = evalHExp evalHExp :: HExp a -> a @@ -40,23 +50,29 @@ instance CompileExp HExp where - varE v = variable ('v' : show v) - compT = compHType compE = compHExp -compHType :: forall a. HType a => HExp a -> VHDL VHDL.Type -compHType _ = declare (undefined :: a) >> return (unTag (typed :: Tagged a VHDL.Type)) +compHType :: forall a . HType a => HExp a -> VHDL VHDL.Type +compHType _ = declare (undefined :: proxy a) -compHExp :: forall a. HType a => HExp a -> VHDL VHDL.Expression -compHExp e = Hoist.lift <$> compSimple e +compHTypeFun :: forall a b . (HType a, HType b) => (a -> b) -> VHDL VHDL.Type +compHTypeFun _ = declare (undefined :: proxy a) + +compHExp :: forall a . HExp a -> VHDL VHDL.Expression +compHExp e = Hoist.lift <$> compSimple e where compSimple :: HExp b -> VHDL Kind compSimple = simpleMatch (\(T s) -> compDomain s) . unHExp - compLoop :: ASTF T b -> VHDL Kind - compLoop = compSimple . HExp + compLoop :: ASTF T b -> VHDL Kind + compLoop = compSimple . HExp - compDomain :: forall sig. HType (DenResult sig) => Dom sig -> Args (AST T) sig -> VHDL Kind + compDomain + :: forall sig + . HType (DenResult sig) + => Dom sig + -> Args (AST T) sig + -> VHDL Kind compDomain expr (x :* y :* _) | Just And <- prj expr = go $ \a b -> VHDL.and [a, b] | Just Or <- prj expr = go $ \a b -> VHDL.or [a, b] @@ -70,6 +86,7 @@ x' <- Hoist.lift <$> compLoop x y' <- Hoist.lift <$> compLoop y return $ Hoist.E $ f x' y' + compDomain relate (x :* y :* _) | Just Eq <- prj relate = go VHDL.eq | Just Neq <- prj relate = go VHDL.neq @@ -83,6 +100,7 @@ x' <- Hoist.lift <$> compLoop x y' <- Hoist.lift <$> compLoop y return $ Hoist.R $ f x' y' + compDomain shift (x :* y :* _) | Just Sll <- prj shift = go $ VHDL.sll | Just Srl <- prj shift = go $ VHDL.srl @@ -96,6 +114,7 @@ x' <- Hoist.lift <$> compLoop x y' <- Hoist.lift <$> compLoop y return $ Hoist.Sh $ f x' y' + compDomain simple (x :* y :* _) | Just Add <- prj simple = go VHDL.add | Just Sub <- prj simple = go VHDL.sub @@ -113,6 +132,7 @@ | Just Pos <- prj simple = do x' <- Hoist.lift <$> compLoop x return $ Hoist.Si x' + compDomain term (x :* y :* _) | Just Mul <- prj term = go VHDL.mul | Just Div <- prj term = go VHDL.div @@ -124,6 +144,7 @@ x' <- Hoist.lift <$> compLoop x y' <- Hoist.lift <$> compLoop y return $ Hoist.T $ f [x', y'] + compDomain factor (x :* y :* _) | Just Exp <- prj factor = do x' <- Hoist.lift <$> compLoop x @@ -136,24 +157,27 @@ | Just Not <- prj factor = do x' <- Hoist.lift <$> compLoop x return $ Hoist.F $ VHDL.not x' + compDomain primary (x :* Nil) | Just (Qualified t) <- prj primary = do f <- compHType (undefined :: HExp (DenResult sig)) x' <- Hoist.lift <$> compLoop x return $ Hoist.P $ VHDL.qualified f x' + | Just (Others) <- prj primary = do + x' <- Hoist.lift <$> compLoop x + return $ Hoist.P $ VHDL.aggregate $ VHDL.others x' | Just (Conversion f) <- prj primary = do - t <- compHType (undefined :: HExp (DenResult sig)) + tt <- compHType (undefined :: HExp (DenResult sig)) + tf <- compHTypeFun (f) x' <- Hoist.lift <$> compLoop x - return $ Hoist.P $ VHDL.cast t x' + return $ Hoist.E $ VHDL.uCast x' tf tt compDomain primary args | Just (Name n) <- prj primary = return $ Hoist.P $ VHDL.name n - | Just (Literal i) <- prj primary = return $ Hoist.P $ VHDL.lit $ format i - | Just (Aggregate xs) <- prj primary = - let maps = fmap (Hoist.lift . VHDL.lit . format) - in return $ Hoist.P $ VHDL.aggregate $ maps xs + | Just (Literal i) <- prj primary = return $ Hoist.P $ VHDL.literal $ VHDL.number $ printVal i + | Just (Aggregate a) <- prj primary = return $ Hoist.P $ VHDL.aggregate a | Just (Function f _) <- prj primary = do as <- sequence $ listArgs compLoop args - return $ Hoist.P $ VHDL.function (VHDL.Ident f) (fmap Hoist.lift as) - | Just (Allocator) <- prj primary = undefined + return $ Hoist.P $ VHDL.function (VHDL.simple f) (fmap Hoist.lift as) + | Just (Allocator) <- prj primary = error "expression-backend: todo" -------------------------------------------------------------------------------- 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 @@ -1,91 +1,187 @@ +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} + module Language.Embedded.Hardware.Expression.Frontend where -import Language.Embedded.Hardware.Expression.Syntax +import qualified Language.VHDL as V -import Data.Bits (Bits) +import Language.Embedded.Hardware.Interface +import Language.Embedded.Hardware.Expression.Syntax hiding (Term, Factor, Primary) +import Language.Embedded.Hardware.Expression.Hoist +import Language.Embedded.Hardware.Expression.Represent +import Language.Embedded.Hardware.Expression.Represent.Bit +import qualified Language.Embedded.VHDL.Monad.Expression as V +import Data.Typeable (Typeable) +import qualified Data.Bits as B (Bits) + import Prelude hiding (not, and, or, abs, rem, div, mod, exp) import qualified Prelude as P +import GHC.TypeLits + -------------------------------------------------------------------------------- --- * +-- * ... -------------------------------------------------------------------------------- --- | Lifts a typed value to an expression. -value :: HType a => a -> HExp a -value i = sugarT (Literal i) +type Hardware exp = + ( Expr exp + , Rel exp + , Shift exp + , Simple exp + , Term exp + , Factor exp + , Primary exp) --- | Creates a variable from a string. -variable :: HType a => String -> HExp a -variable = sugarT . Name +-------------------------------------------------------------------------------- --- | Casts an expression using supplied conversion function. -cast :: (HType a, HType b) => (a -> b) -> HExp a -> HExp b -cast f = sugarT (Conversion f) +-- | Logical operators. +class Expr exp where + true :: exp Bool + false :: exp Bool + and :: exp Bool -> exp Bool -> exp Bool + or :: exp Bool -> exp Bool -> exp Bool + xor :: exp Bool -> exp Bool -> exp Bool + xnor :: exp Bool -> exp Bool -> exp Bool + nand :: exp Bool -> exp Bool -> exp Bool + nor :: exp Bool -> exp Bool -> exp Bool +instance Expr HExp where + true = value True + false = value False + and = sugarT And + or = sugarT Or + xor = sugarT Xor + xnor = sugarT Xnor + nand = sugarT Nand + nor = sugarT Nor + -------------------------------------------------------------------------------- -true, false :: HExp Bool -true = value True -false = value False +-- | Relational operators. +class Rel exp where + eq :: (HType a, Eq a) => exp a -> exp a -> exp Bool + neq :: (HType a, Eq a) => exp a -> exp a -> exp Bool + lt :: (HType a, Ord a) => exp a -> exp a -> exp Bool + lte :: (HType a, Ord a) => exp a -> exp a -> exp Bool + gt :: (HType a, Ord a) => exp a -> exp a -> exp Bool + gte :: (HType a, Ord a) => exp a -> exp a -> exp Bool --- logical operators -and, or, xor, xnor, nand, nor :: HExp Bool -> HExp Bool -> HExp Bool -and = sugarT And -or = sugarT Or -xor = sugarT Xor -xnor = sugarT Xnor -nand = sugarT Nand -nor = sugarT Nor +instance Rel HExp where + eq = sugarT Eq + neq = sugarT Neq + lt = sugarT Lt + lte = sugarT Lte + gt = sugarT Gt + gte = sugarT Gte --- relational operators -eq, neq :: (HType a, Eq a) => HExp a -> HExp a -> HExp Bool -eq = sugarT Eq -neq = sugarT Neq +-------------------------------------------------------------------------------- -lt, lte, gt, gte :: (HType a, Ord a) => HExp a -> HExp a -> HExp Bool -lt = sugarT Lt -lte = sugarT Lte -gt = sugarT Gt -gte = sugarT Gte +-- | Shift operators. +class Shift exp where + sll :: (HType a, B.Bits a) => exp a -> exp Integer -> exp a + srl :: (HType a, B.Bits a) => exp a -> exp Integer -> exp a + sla :: (HType a, B.Bits a) => exp a -> exp Integer -> exp a + sra :: (HType a, B.Bits a) => exp a -> exp Integer -> exp a + rol :: (HType a, B.Bits a) => exp a -> exp Integer -> exp a + ror :: (HType a, B.Bits a) => exp a -> exp Integer -> exp a --- shift operators -sll, srl, sla, sra, rol, ror :: (HType a, Bits a, HType b, Integral b) => HExp a -> HExp b -> HExp a -sll = sugarT Sll -srl = sugarT Srl -sla = sugarT Sla -sra = sugarT Sra -rol = sugarT Rol -ror = sugarT Ror +instance Shift HExp where + sll = sugarT Sll + srl = sugarT Srl + sla = sugarT Sla + sra = sugarT Sra + rol = sugarT Rol + ror = sugarT Ror --- adding operators -add, sub :: (HType a, Num a) => HExp a -> HExp a -> HExp a -add = sugarT Add -sub = sugarT Sub +-------------------------------------------------------------------------------- -cat :: (HType a, Read a, Show a) => HExp a -> HExp a -> HExp a -cat = sugarT Cat +-- | Adding operators. +class Simple exp where + neg :: (HType a, Num a) => exp a -> exp a + add :: (HType a, Num a) => exp a -> exp a -> exp a + sub :: (HType a, Num a) => exp a -> exp a -> exp a + cat :: ( KnownNat n, KnownNat m, KnownNat (n + m), Typeable (n + m)) + => exp (Bits n) -> exp (Bits m) -> exp (Bits (n + m)) --- multiplying operators -mul :: (HType a, Num a) => HExp a -> HExp a -> HExp a -mul = sugarT Mul +instance Simple HExp where + neg = sugarT Neg + add = sugarT Add + sub = sugarT Sub + cat = sugarT Cat -div, mod, rem :: (HType a, Integral a) => HExp a -> HExp a -> HExp a -div = sugarT Div -mod = sugarT Mod -rem = sugarT Rem +-------------------------------------------------------------------------------- --- miscellaneous operators -exp :: (HType a, Num a, HType b, Integral b) => HExp a -> HExp b -> HExp a -exp = sugarT Exp +-- | Multiplying operators. +class Term exp where + mul :: (HType a, Num a) => exp a -> exp a -> exp a + div :: (HType a, Integral a) => exp a -> exp a -> exp a + mod :: (HType a, Integral a) => exp a -> exp a -> exp a + rem :: (HType a, Integral a) => exp a -> exp a -> exp a -abs :: (HType a, Num a) => HExp a -> HExp a -abs = sugarT Abs +instance Term HExp where + mul = sugarT Mul + div = sugarT Div + mod = sugarT Mod + rem = sugarT Rem -not :: HExp Bool -> HExp Bool -not = sugarT Not +-------------------------------------------------------------------------------- +-- | Miscellaneous operators. +class Factor exp where + exp :: (HType a, Num a, HType b, Integral b) => exp a -> exp b -> exp a + abs :: (HType a, Num a) => exp a -> exp a + not :: exp Bool -> exp Bool + +instance Factor HExp where + exp = sugarT Exp + abs = sugarT Abs + not = sugarT Not + -------------------------------------------------------------------------------- + +-- | Primary operations. +class Primary exp where + value :: HType a => a -> exp a + name :: HType a => String -> exp a + cast :: (HType a, HType b) => (a -> b) -> exp a -> exp b + +instance Primary HExp where + value = sugarT . Literal + name n = sugarT (Name (V.NSimple (V.Ident n))) + cast f = sugarT (Conversion f) + +-- | Creates a variable from a string. +var :: (Primary exp, HType a) => String -> exp a +var = name + +-- | Converts an integral (signed/unsigned/integer) to an integer. +toInteger :: (Primary exp, HType a, Integral a) => exp a -> exp Integer +toInteger = cast (fromIntegral) + +-- | Converts an integral to a signed value. +toSigned :: (Primary exp, HType a, HType b, Integral a, Num b) => exp a -> exp b +toSigned = cast (fromIntegral) + +-- | Converts an integral to a unsigned value. +toUnsigned :: (Primary exp, HType a, HType b, Integral a, Num b) => exp a -> exp b +toUnsigned = cast (fromIntegral) + +-- | Converts an integral to its bit representation. +toBits :: (Primary exp, HType a, HType (Bits b), Integral a, KnownNat b) => exp a -> exp (Bits b) +toBits = cast (bitFromInteger . fromIntegral) + +-------------------------------------------------------------------------------- + +fromBits :: (Primary exp, HType (Bits a), HType b, Num b, KnownNat a) => exp (Bits a) -> exp b +fromBits = cast (fromIntegral . bitToInteger) + +-------------------------------------------------------------------------------- +-- I should probably not support most of these, as they can't implement the +-- interfaces fully. Would perhaps be better to implement my own versions +-- of the type classes. instance (HType a, Eq a) => Eq (HExp a) where 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 @@ -1,161 +1,194 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} + module Language.Embedded.Hardware.Expression.Represent - ( Tagged (..) - , Rep (..) + ( Rep(..) + , Inhabited(..) + , Sized(..) + , HType(..) + + , declareBoolean + , declareNumeric + , declareFloating + + , module Data.Int + , module Data.Word ) where -import Language.Embedded.VHDL (VHDL) -import Language.Embedded.VHDL.Monad (newLibrary, newImport) +import qualified Language.VHDL as V + +import Language.VHDL (Expression) + +import Language.Embedded.VHDL (VHDL) +import Language.Embedded.VHDL.Monad (newSym, newLibrary, newImport) import Language.Embedded.VHDL.Monad.Type +import qualified Language.Embedded.VHDL.Monad.Util as Util (printBits) +import Language.Embedded.Hardware.Expression.Hoist (lift) + +import Data.Char (isDigit) import Data.Int import Data.Word - -import Data.Char (intToDigit) -import Data.Bits (shiftR) -import Text.Printf (printf) -import Numeric (showIntAtBase) - -import Data.ByteString (ByteString) -import qualified Data.ByteString as B +import Data.Typeable +import Text.Printf -------------------------------------------------------------------------------- --- * Representable types (until I come up with a solution free of VHDL stuff). +-- * Representation of types. -------------------------------------------------------------------------------- --- | Tag a value with some (possibly) interesting information -newtype Tagged s b = Tag { unTag :: b } +-- | Collection of required classes for hardware expressions. +class (Typeable a, Rep a, Eq a) => HType a +instance (Typeable a, Rep a, Eq a) => HType a --- | A 'rep'resentable value. +-------------------------------------------------------------------------------- +-- ** Representable types. + +-- | 'Rep'resentable types. class Rep a where - width :: Tagged a Int - typed :: Tagged a Type - declare :: a -> VHDL () - format :: a -> String - -declareBoolean :: VHDL () -declareBoolean = - do newLibrary "IEEE" - newImport "IEEE.std_logic_1164" - -declareNumeric :: VHDL () -declareNumeric = - do newLibrary "IEEE" - newImport "IEEE.std_logic_1164" - newImport "IEEE.numeric_std" - -declareFloating :: VHDL () -declareFloating = - do newLibrary "IEEE" - newImport "IEEE.float_pkg" - --------------------------------------------------------------------------------- --- ** Boolean + declare :: proxy a -> VHDL Type + printVal :: a -> String + printBits :: a -> String instance Rep Bool where - width = Tag 1 - typed = Tag std_logic - declare _ = declareBoolean - format True = "1" - format False = "0" - --------------------------------------------------------------------------------- --- ** Signed + declare _ = declareBoolean >> return std_logic + printVal True = "\'1\'" + printVal False = "\'0\'" + printBits = printVal instance Rep Int8 where - width = Tag 8 - typed = Tag signed8 - declare _ = declareNumeric - format = convert + declare _ = declareNumeric >> return signed8 + printVal = show + printBits = Util.printBits 8 instance Rep Int16 where - width = Tag 16 - typed = Tag signed16 - declare _ = declareNumeric - format = convert + declare _ = declareNumeric >> return signed16 + printVal = show + printBits = Util.printBits 16 instance Rep Int32 where - width = Tag 32 - typed = Tag signed32 - declare _ = declareNumeric - format = convert + declare _ = declareNumeric >> return signed32 + printVal = show + printBits = Util.printBits 32 instance Rep Int64 where - width = Tag 64 - typed = Tag signed64 - declare _ = declareNumeric - format = convert - --------------------------------------------------------------------------------- --- ** Unsigned + declare _ = declareNumeric >> return signed64 + printVal = show + printBits = Util.printBits 64 instance Rep Word8 where - width = Tag 8 - typed = Tag usigned8 - declare _ = declareNumeric - format = convert + declare _ = declareNumeric >> return usigned8 + printVal = show + printBits = Util.printBits 8 instance Rep Word16 where - width = Tag 16 - typed = Tag usigned16 - declare _ = declareNumeric - format = convert + declare _ = declareNumeric >> return usigned16 + printVal = show + printBits = Util.printBits 16 instance Rep Word32 where - width = Tag 32 - typed = Tag usigned32 - declare _ = declareNumeric - format = convert + declare _ = declareNumeric >> return usigned32 + printVal = show + printBits = Util.printBits 32 instance Rep Word64 where - width = Tag 64 - typed = Tag usigned64 - declare _ = declareNumeric - format = convert + declare _ = declareNumeric >> return usigned64 + printVal = show + printBits = Util.printBits 64 --------------------------------------------------------------------------------- --- ** Floating point. +instance Rep Int where + declare _ = return (integer Nothing) + printVal = show + printBits = error "hardware-edsl.printBits: int." +instance Rep Integer where + declare _ = return (integer Nothing) + printVal = show + printBits = error "hardware-edsl.printBits: integer." + instance Rep Float where - width = Tag 32 - typed = Tag float - declare _ = declareFloating - format = error "todo: format float." + declare _ = declareFloating >> return float + printVal = show + printBits = error "hardware-edsl.printBits: float." instance Rep Double where - width = Tag 64 - typed = Tag double - declare _ = declareFloating - format = error "todo: format double." + declare _ = declareFloating >> return double + printVal = show + printBits = error "hardware-edsl.printBits: double." --------------------------------------------------------------------------------- --- * Converting Integers to their Binrary representation +-- | Declare the necessary libraries to support boolean operations. +declareBoolean :: VHDL () +declareBoolean = + do newLibrary "IEEE" + newImport "IEEE.std_logic_1164" + +-- | Declare the necessary libraries to support numerical operations. +declareNumeric :: VHDL () +declareNumeric = + do newLibrary "IEEE" + newImport "IEEE.std_logic_1164" + newImport "IEEE.numeric_std" + +-- | Declare the necessary libraries to support floating point operations. +declareFloating :: VHDL () +declareFloating = + do newLibrary "IEEE" + newImport "IEEE.float_pkg" + -------------------------------------------------------------------------------- +-- ** Inhabited types. --- | Convert an Integral to its binary representation -convert :: Integral a => a -> String -convert = foldr1 (++) . fmap w2s . B.unpack . i2bs . toInteger +-- | Inhabited types, that is, types with a base element. +class Inhabited a + where + -- | Ground value. + reset :: a --- | Go over an Integer and convert it into a bytestring containing its --- binary representation -i2bs :: Integer -> ByteString -i2bs x = B.reverse . B.unfoldr (fmap chunk) . Just $ sign x +instance Inhabited Bool where reset = False +instance Inhabited Int8 where reset = 0 +instance Inhabited Int16 where reset = 0 +instance Inhabited Int32 where reset = 0 +instance Inhabited Int64 where reset = 0 +instance Inhabited Word8 where reset = 0 +instance Inhabited Word16 where reset = 0 +instance Inhabited Word32 where reset = 0 +instance Inhabited Word64 where reset = 0 +instance Inhabited Int where reset = 0 +instance Inhabited Integer where reset = 0 +instance Inhabited Float where reset = 0 +instance Inhabited Double where reset = 0 + +-------------------------------------------------------------------------------- +-- ** Sized types. + +-- | Types with a known size. +class Sized a where - sign :: (Num a, Ord a) => a -> a - sign | x < 0 = subtract 1 . negate - | otherwise = id + -- | Bits required to represent values of type 'a'. + bits :: proxy a -> Integer - chunk :: Integer -> (Word8, Maybe Integer) - chunk x = (b, i) - where - b = sign (fromInteger x) - i | x >= 128 = Just (x `shiftR` 8) - | otherwise = Nothing +instance Sized Bool where bits _ = 1 +instance Sized Int8 where bits _ = 8 +instance Sized Int16 where bits _ = 16 +instance Sized Int32 where bits _ = 32 +instance Sized Int64 where bits _ = 64 +instance Sized Word8 where bits _ = 8 +instance Sized Word16 where bits _ = 16 +instance Sized Word32 where bits _ = 32 +instance Sized Word64 where bits _ = 64 --- | Shows a word with zero padding --- --- I assum the negative numbers to already be padded with ones -w2s :: Word8 -> String -w2s w = printf "%08s" $ showIntAtBase 2 intToDigit w "" +-------------------------------------------------------------------------------- +-- ** Hmm... + +instance Num Bool where + (+) = error "(+) not implemented for Bool" + (-) = error "(-) not implemented for Bool" + (*) = error "(*) not implemented for Bool" + abs = id + signum = id + fromInteger 0 = False + fromInteger 1 = True + fromInteger _ = error "bool-num: >1" -------------------------------------------------------------------------------- diff --git a/src/Language/Embedded/Hardware/Expression/Represent/Bit.hs b/src/Language/Embedded/Hardware/Expression/Represent/Bit.hs new file mode 100644 --- /dev/null +++ b/src/Language/Embedded/Hardware/Expression/Represent/Bit.hs @@ -0,0 +1,338 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Language.Embedded.Hardware.Expression.Represent.Bit + ( Bit + , Bits + , ni + , bitFromInteger + , bitToInteger + , bitAdd + , bitAdd' + , bitSub + , bitSub' + , bitMul + , bitMul' + , bitQuotRem + , bitNeg + , bitReadsPrec + , bitMinBound + , bitMaxBound + , bitSigNum + , bitAnd + , bitOr + , bitXor + , bitComplement + , bitSplit + , bitJoin + , bitCoerce + , bitShiftR + , bitShiftL + , bitTestBit + , bitRotate + , bitToList + , bitShowBin + , bitShowHex + + , UBits + , forgetBits + , recallBits + ) + where + +import Language.Embedded.Hardware.Expression.Represent + +import Language.Embedded.VHDL (VHDL) +import Language.Embedded.VHDL.Monad (newSym, newLibrary, newImport) +import Language.Embedded.VHDL.Monad.Type + +import Data.Ix +import Data.Typeable +import Data.Bits hiding (Bits) +import qualified Data.Bits as Bit (Bits) + +import Control.Monad (guard) +import Control.DeepSeq (NFData(..)) + +import Data.Char (intToDigit) +import qualified Numeric as N + +import GHC.TypeLits + +-------------------------------------------------------------------------------- +-- * ... +-------------------------------------------------------------------------------- + +-------------------------------------------------------------------------------- +-- ** Single bit. + +type Bit = Bool + +-------------------------------------------------------------------------------- +-- These aren't great to have.. + +instance Real Bool + where + toRational = error "toRational not implemented for bit." + +instance Integral Bool + where + toInteger True = 1 + toInteger False = 0 + quotRem = error "quotRem not implemented for bit." + +-------------------------------------------------------------------------------- +-- ** Bit vectors of known lenght. + +newtype Bits (n :: Nat) = B Integer + +instance forall n. KnownNat n => Inhabited (Bits n) + where + reset = bitFromInteger 0 + +instance forall n. KnownNat n => Rep (Bits n) + where + declare = declareBits + printVal = show . bitToInteger + printBits b = '\"' : (tail $ bitShowBin b) ++ ['\"'] -- *** why tail? + +instance forall n. KnownNat n => Sized (Bits n) + where + bits _ = ni (Proxy::Proxy n) + +deriving instance Typeable (Bits n) + +declareBits :: forall proxy n. KnownNat n => proxy (Bits n) -> VHDL Type +declareBits _ = declareBoolean >> return (std_logic_vector size) + where size = fromInteger (ni (undefined :: Bits n)) + +-------------------------------------------------------------------------------- +-- *** ... + +ni :: KnownNat n => proxy n -> Integer +ni = fromIntegral . natVal + +norm :: KnownNat n => Bits n -> Bits n +norm b@(B n) = B (n .&. ((1 `shiftL` fromInteger (ni b)) - 1)) + +bitFromInteger :: KnownNat n => Integer -> Bits n +bitFromInteger i = norm (B i) + +bitToInteger :: Bits n -> Integer +bitToInteger (B i) = i + +-------------------------------------------------------------------------------- +-- *** ... + +lift1 :: KnownNat n => (Integer -> Integer) -> Bits n -> Bits n +lift1 f (B i) = norm (B (f i)) + +lift2 :: KnownNat n => (Integer -> Integer -> Integer) -> Bits n -> Bits n -> Bits n +lift2 f (B i) (B j) = norm (B (f i j)) + +-------------------------------------------------------------------------------- +-- *** ... + +bitAdd :: KnownNat n => Bits n -> Bits n -> Bits n +bitAdd = lift2 (+) + +bitSub :: KnownNat n => Bits n -> Bits n -> Bits n +bitSub = lift2 (-) + +bitMul :: KnownNat n => Bits n -> Bits n -> Bits n +bitMul = lift2 (*) + +bitAdd' :: Bits n -> Bits n -> Bits (n + 1) +bitAdd' (B i) (B j) = B (i + j) + +bitSub' :: Bits n -> Bits n -> Bits (n + 1) +bitSub' (B i) (B j) = B (i - j) + +bitMul' :: Bits n -> Bits n -> Bits (n + n) +bitMul' (B i) (B j) = B (i * j) + +bitQuotRem :: Bits n -> Bits n -> (Bits n, Bits n) +bitQuotRem (B i) (B j) = let (a, b) = quotRem i j in (B a, B b) + +bitNeg :: KnownNat n => Bits n -> Bits n +bitNeg = lift1 negate + +bitMinBound :: Bits n +bitMinBound = B 0 + +bitMaxBound :: KnownNat n => Bits n +bitMaxBound = norm (B (-1)) + +bitSigNum :: Bits n -> Bits n +bitSigNum (B i) = B (signum i) + +bitAnd :: Bits n -> Bits n -> Bits n +bitAnd (B i) (B j) = B (i .&. j) + +bitOr :: Bits n -> Bits n -> Bits n +bitOr (B i) (B j) = B (i .|. j) + +bitXor :: Bits n -> Bits n -> Bits n +bitXor (B i) (B j) = B (i .|. j) + +bitComplement :: KnownNat n => Bits n -> Bits n +bitComplement = lift1 complement + +bitSplit :: (KnownNat m, KnownNat n) => proxy m -> Bits (m + n) -> (Bits m, Bits n) +bitSplit m (B i) = (a, b) + where a = B (i `shiftR` fromInteger (ni m)) + b = bitFromInteger i + +bitJoin :: KnownNat n => Bits m -> Bits n -> Bits (m + n) +bitJoin (B i) b@(B j) = B (shiftL i (fromInteger (ni b)) .|. j) + +bitCoerce :: forall n m. (KnownNat n, KnownNat m) => Bits n -> Maybe (Bits m) +bitCoerce b@(B i) = guard (ni b == ni d) >> return (B i) + where d = undefined :: Bits m + +bitShiftR :: Bits n -> Int -> Bits n +bitShiftR (B i) n = B (shiftR i n) + +bitShiftL :: KnownNat n => Bits n -> Int -> Bits n +bitShiftL b n = lift1 (`shiftL` n) b + +bitTestBit :: Bits n -> Int -> Bool +bitTestBit (B i) n = testBit i n + +bitRotate :: KnownNat n => Bits n -> Int -> Bits n +bitRotate b@(B i) n + | si < 2 = b + | otherwise = bitOr (bitFromInteger (shiftL i n)) (bitFromInteger (shiftR i (si - n))) + where n' = mod n si + si = fromInteger (ni b) + +bitToList :: KnownNat n => Bits n -> [Bool] +bitToList b = map (bitTestBit b) [start, start - 1 .. 0] + where start = fromInteger (ni b) + +bitReadsPrec :: KnownNat n => Int -> ReadS (Bits n) +bitReadsPrec p txt = [ (bitFromInteger b, cs) | (b, cs) <- readsPrec p txt ] + +bitShowBin :: KnownNat n => Bits n -> String +bitShowBin = map sh . bitToList + where sh x = if x then '1' else '0' + +bitShowHex :: KnownNat n => Bits n -> String +bitShowHex b@(B i) = zeros (N.showHex i "") + where zeros n = replicate (len - length n) '0' ++ n + len = div (fromInteger (ni b) + 3) 4 + +-------------------------------------------------------------------------------- + +instance Show (Bits n) where + showsPrec p (B x) = showsPrec p x + +instance KnownNat n => Read (Bits n) where + readsPrec = bitReadsPrec + +instance Eq (Bits n) where + B i == B j = i == j + +instance NFData (Bits n) where + rnf (B i) = seq i () + +instance Ord (Bits n) where + compare (B i) (B j) = compare i j + +instance KnownNat n => Bounded (Bits n) where + minBound = bitMinBound + maxBound = bitMaxBound + +instance KnownNat n => Num (Bits n) where + (+) = bitAdd + (-) = bitSub + (*) = bitMul + negate = bitNeg + abs = id + signum = bitSigNum + fromInteger = bitFromInteger + +instance KnownNat n => Bit.Bits (Bits n) where + isSigned _ = False + bit = bitFromInteger . (2 ^) + bitSize = fromInteger . ni + bitSizeMaybe = Just . fromInteger . ni + (.&.) = bitAnd + (.|.) = bitOr + xor = bitXor + complement = bitComplement + shiftR = bitShiftR + shiftL = bitShiftL + testBit = bitTestBit + rotate = bitRotate + popCount = length . filter id . bitToList + +instance KnownNat n => Real (Bits n) where + toRational (B i) = toRational i + +instance KnownNat n => Enum (Bits n) where + toEnum i = norm $ B $ toEnum i + fromEnum (B i) = fromEnum i + succ i = i + 1 + pred i = if i == minBound then maxBound else i - 1 + enumFrom i = enumFromTo i maxBound + enumFromTo i j + | i < j = enumFromThenTo i (succ i) j + | i == j = [i] + | otherwise = [] + + enumFromThen x y = enumFromThenTo x y bound + where + bound | x <= y = maxBound + | otherwise = minBound + + enumFromThenTo (B i) (B j) (B k) = map B (enumFromThenTo i j k) + +instance KnownNat n => Integral (Bits n) where + toInteger = bitToInteger + quotRem = bitQuotRem + +instance KnownNat n => Ix (Bits n) where + range = undefined + index = undefined + inRange = undefined + +-------------------------------------------------------------------------------- +-- ** Bit vectors of unknown lenght. + +newtype UBits = UB Integer + deriving (Eq, Enum, Ord, Num, Real, Integral) + +instance Rep UBits + where + declare = declareUBits + printVal = show + -- *** This is bad and produces a warning in vhdl as there's no guarantee + -- that the lenght of the printed binary will be the expected one. + -- Give UB an extra 'Maybe Integer' for storing the length whenever its + -- available. + printBits (UB i) = '\"' : (N.showIntAtBase 2 intToDigit i "") ++ ['\"'] + + +declareUBits :: proxy UBits -> VHDL Type +declareUBits _ = declareBoolean >> return std_logic + +-------------------------------------------------------------------------------- + +forgetBits :: Bits n -> UBits +forgetBits b = UB (bitToInteger b) + +recallBits :: KnownNat n => UBits -> Bits n +recallBits (UB i) = (B i) + +-------------------------------------------------------------------------------- + +instance Show UBits where + showsPrec p (UB x) = showsPrec p x + +-------------------------------------------------------------------------------- diff --git a/src/Language/Embedded/Hardware/Expression/Syntax.hs b/src/Language/Embedded/Hardware/Expression/Syntax.hs --- a/src/Language/Embedded/Hardware/Expression/Syntax.hs +++ b/src/Language/Embedded/Hardware/Expression/Syntax.hs @@ -1,40 +1,39 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DataKinds #-} module Language.Embedded.Hardware.Expression.Syntax where import Language.Syntactic import Language.Syntactic.Functional (Denotation, Eval(..), EvalEnv) -import Language.Embedded.Hardware.Command +import qualified Language.VHDL as V (Name, Aggregate) + +import Language.Embedded.Hardware.Command (CompArrayIx) import Language.Embedded.Hardware.Interface import Language.Embedded.Hardware.Expression.Represent +import Language.Embedded.Hardware.Expression.Represent.Bit -import Data.Bits (Bits) import Data.Typeable (Typeable) -import qualified Data.Bits as Bits +import qualified Data.Bits as B +import GHC.TypeLits hiding (Symbol) + -------------------------------------------------------------------------------- -- * Syntax of hardware expressions. -------------------------------------------------------------------------------- --- | Collection of required classes for hardware expressions. -class (Typeable a, Rep a, Eq a) => HType a -instance (Typeable a, Rep a, Eq a) => HType a - -type instance PredicateExp HExp = HType - -- | Domain of expressions. type Dom = Expression :+: Relational - :+: Shift - :+: Simple + :+: ShiftExpression + :+: SimpleExpression :+: Term :+: Factor :+: Primary @@ -64,7 +63,7 @@ type Internal (HExp a) = a desugar = unHExp - sugar = HExp + sugar = HExp -------------------------------------------------------------------------------- -- ** Syntax. @@ -90,23 +89,24 @@ Gte :: (HType a, Ord a) => Relational (a :-> a :-> Full Bool) -- | Bit vector expressions. -data Shift sig +data ShiftExpression sig where - Sll :: (HType a, Bits a, HType b, Integral b) => Shift (a :-> b :-> Full a) - Srl :: (HType a, Bits a, HType b, Integral b) => Shift (a :-> b :-> Full a) - Sla :: (HType a, Bits a, HType b, Integral b) => Shift (a :-> b :-> Full a) - Sra :: (HType a, Bits a, HType b, Integral b) => Shift (a :-> b :-> Full a) - Rol :: (HType a, Bits a, HType b, Integral b) => Shift (a :-> b :-> Full a) - Ror :: (HType a, Bits a, HType b, Integral b) => Shift (a :-> b :-> Full a) + Sll :: (HType a, B.Bits a) => ShiftExpression (a :-> Integer :-> Full a) + Srl :: (HType a, B.Bits a) => ShiftExpression (a :-> Integer :-> Full a) + Sla :: (HType a, B.Bits a) => ShiftExpression (a :-> Integer :-> Full a) + Sra :: (HType a, B.Bits a) => ShiftExpression (a :-> Integer :-> Full a) + Rol :: (HType a, B.Bits a) => ShiftExpression (a :-> Integer :-> Full a) + Ror :: (HType a, B.Bits a) => ShiftExpression (a :-> Integer :-> Full a) -- | Numerical expressions. -data Simple sig +data SimpleExpression sig where - Neg :: (HType a, Num a) => Simple (a :-> Full a) - Pos :: (HType a, Num a) => Simple (a :-> Full a) - Add :: (HType a, Num a) => Simple (a :-> a :-> Full a) - Sub :: (HType a, Num a) => Simple (a :-> a :-> Full a) - Cat :: (HType a, Show a, Read a) => Simple (a :-> a :-> Full a) + Neg :: (HType a, Num a) => SimpleExpression (a :-> Full a) + Pos :: (HType a, Num a) => SimpleExpression (a :-> Full a) + Add :: (HType a, Num a) => SimpleExpression (a :-> a :-> Full a) + Sub :: (HType a, Num a) => SimpleExpression (a :-> a :-> Full a) + Cat :: (KnownNat n, KnownNat m) + => SimpleExpression (Bits n :-> Bits m :-> Full (Bits (n + m))) -- | Integral expressions. data Term sig @@ -126,14 +126,16 @@ -- | ... data Primary sig where - Name :: (HType a) => String -> Primary (Full a) - Literal :: (HType a) => a -> Primary (Full a) - Aggregate :: (HType a) => [a] -> Primary (Full [a]) + Name :: (HType a) => V.Name -> Primary (Full a) + Literal :: (HType a) => a -> Primary (Full a) + Aggregate :: (HType a) => V.Aggregate -> Primary (Full a) Function :: (Signature sig) => String -> Denotation sig -> Primary sig Qualified :: (HType a, HType b) => b -> Primary (a :-> Full a) Conversion :: (HType a, HType b) => (a -> b) -> Primary (a :-> Full b) Allocator :: (HType a) => Primary (Full a) - + -- *** todo: expanded aggregate + Others :: Primary (Bit :-> Full (Bits n)) + -------------------------------------------------------------------------------- -- ** Syntactic instances. @@ -221,10 +223,10 @@ instance EvalEnv Relational env -instance Equality Shift -instance StringTree Shift +instance Equality ShiftExpression +instance StringTree ShiftExpression -instance Symbol Shift +instance Symbol ShiftExpression where symSig Sll = signature symSig Srl = signature @@ -233,7 +235,7 @@ symSig Rol = signature symSig Ror = signature -instance Render Shift +instance Render ShiftExpression where renderSym Sll = "sll" renderSym Srl = "srl" @@ -242,27 +244,27 @@ renderSym Rol = "rol" renderSym Ror = "ror" -instance Eval Shift +instance Eval ShiftExpression where - evalSym Sll = \x i -> Bits.shiftL x (fromIntegral i) + evalSym Sll = \x i -> B.shiftL x (fromIntegral i) evalSym Srl = \x i -> shiftLR x (fromIntegral i) where - shiftLR :: Bits a => a -> Int -> a - shiftLR x n = let y = Bits.shiftR x n in - case Bits.bitSizeMaybe x of - Just i -> foldr (flip Bits.clearBit) y [i - n `Prelude.mod` i .. i] + shiftLR :: B.Bits a => a -> Int -> a + shiftLR x n = let y = B.shiftR x n in + case B.bitSizeMaybe x of + Just i -> foldr (flip B.clearBit) y [i - n `Prelude.mod` i .. i] Nothing -> y - evalSym Sla = \x i -> Bits.shiftL x (fromIntegral i) - evalSym Sra = \x i -> Bits.shiftR x (fromIntegral i) - evalSym Rol = \x i -> Bits.rotateL x (fromIntegral i) - evalSym Ror = \x i -> Bits.rotateR x (fromIntegral i) + evalSym Sla = \x i -> B.shiftL x (fromIntegral i) + evalSym Sra = \x i -> B.shiftR x (fromIntegral i) + evalSym Rol = \x i -> B.rotateL x (fromIntegral i) + evalSym Ror = \x i -> B.rotateR x (fromIntegral i) -instance EvalEnv Shift env +instance EvalEnv ShiftExpression env -instance Equality Simple -instance StringTree Simple +instance Equality SimpleExpression +instance StringTree SimpleExpression -instance Symbol Simple +instance Symbol SimpleExpression where symSig Neg = signature symSig Pos = signature @@ -270,7 +272,7 @@ symSig Sub = signature symSig Cat = signature -instance Render Simple +instance Render SimpleExpression where renderSym Neg = "(-)" renderSym Pos = "id" @@ -278,15 +280,15 @@ renderSym Sub = "(-)" renderSym Cat = "(&)" -instance Eval Simple +instance Eval SimpleExpression where evalSym Neg = negate evalSym Pos = id evalSym Add = (+) evalSym Sub = (-) - evalSym Cat = \x y -> read (show x ++ show y) + evalSym Cat = bitJoin -instance EvalEnv Simple env +instance EvalEnv SimpleExpression env instance Equality Term instance StringTree Term @@ -344,7 +346,8 @@ where symSig (Name _) = signature symSig (Literal _) = signature - symSig (Aggregate _) = undefined + symSig (Aggregate _) = signature + symSig (Others) = signature symSig (Function _ _) = signature symSig (Qualified _) = signature symSig (Conversion _) = signature @@ -355,6 +358,7 @@ renderSym (Name _) = "name" renderSym (Literal _) = "lit" renderSym (Aggregate _) = "agg" + renderSym (Others) = "others" renderSym (Function _ _) = "fun" renderSym (Qualified _) = "qual" renderSym (Conversion _) = "conv" @@ -364,11 +368,12 @@ where evalSym (Name _) = error "cannot eval open names!" evalSym (Literal i) = i - evalSym (Aggregate xs) = xs + evalSym (Aggregate _) = error "primary-todo: eval aggregate names." + evalSym (Others) = error "primary-todo: eval others" evalSym (Function _ f) = f - evalSym (Qualified _) = error "todo: eval qualified names." + evalSym (Qualified _) = error "primary-todo: eval qualified names." evalSym (Conversion f) = f - evalSym (Allocator) = undefined + evalSym (Allocator) = error "primary-todo: eval allocator" instance EvalEnv Primary env diff --git a/src/Language/Embedded/Hardware/Interface.hs b/src/Language/Embedded/Hardware/Interface.hs --- a/src/Language/Embedded/Hardware/Interface.hs +++ b/src/Language/Embedded/Hardware/Interface.hs @@ -1,38 +1,47 @@ {-# LANGUAGE KindSignatures #-} {-# LANGUAGE TypeFamilies #-} -module Language.Embedded.Hardware.Interface where +module Language.Embedded.Hardware.Interface + ( VHDL + , module Language.Embedded.Hardware.Interface + ) where import Language.VHDL (Expression) import Language.Embedded.VHDL (VHDL, Type) import Data.Constraint +import Data.String -------------------------------------------------------------------------------- -- * Interface for evaluation and compilation of pure expressions into VHDL. -------------------------------------------------------------------------------- --- | Constraint on the types of variables in a given expression language. -type family PredicateExp (exp :: * -> *) :: * -> Constraint +-- | Variable identifier. +type VarId = String --- | General interface for evaluating expressions. -class EvaluateExp exp +-------------------------------------------------------------------------------- + +-- | Expressions that support injection of values and named variables. +class FreeExp exp where + -- | Constraint on the types of variables in a given expression language. + type PredicateExp exp :: * -> Constraint + -- | Literal expressions. - litE :: PredicateExp exp a => a -> exp a + litE :: PredicateExp exp a => a -> exp a + -- | Variable expressions. + varE :: PredicateExp exp a => VarId -> exp a + +-- | General interface for evaluating expressions. +class FreeExp exp => EvaluateExp exp + where -- | Evaluation of (closed) expressions. - evalE :: PredicateExp exp a => exp a -> a + evalE :: exp a -> a -- | General interface for compiling expressions. -class CompileExp exp +class FreeExp exp => CompileExp exp where - -- | Variable expressions. - varE :: PredicateExp exp a => Integer -> exp a - - -- | Compilation of type kind. - compT :: PredicateExp exp a => exp a -> VHDL Type - -- | Compilation of expressions. - compE :: PredicateExp exp a => exp a -> VHDL Expression + compE :: exp a -> VHDL Expression -------------------------------------------------------------------------------- diff --git a/src/Language/Embedded/VHDL.hs b/src/Language/Embedded/VHDL.hs --- a/src/Language/Embedded/VHDL.hs +++ b/src/Language/Embedded/VHDL.hs @@ -3,6 +3,7 @@ , module Language.Embedded.VHDL.Monad , module Language.Embedded.VHDL.Monad.Expression , module Language.Embedded.VHDL.Monad.Type + , module Language.Embedded.VHDL.Monad.Util ) where import Language.VHDL as VHDL (Identifier(..), Mode(..), Direction(..)) @@ -10,3 +11,4 @@ import Language.Embedded.VHDL.Monad import Language.Embedded.VHDL.Monad.Expression import Language.Embedded.VHDL.Monad.Type +import Language.Embedded.VHDL.Monad.Util 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 @@ -23,49 +23,61 @@ -- ^ imports , newLibrary, newImport - -- ^ declarations - , addPort, addGeneric - , addGlobal, addLocal + -- ^ ... +--, addPort, addGeneric + , addConstant, addSignal, addVariable , addConcurrent, addSequential , addType, addComponent + -- ^ ... + , findType + , inheritContext + + -- ^ declarations + , declareComponent + -- ^ statements , inProcess, inFor, inWhile, inConditional, inCase - , exit + , exit, null -- ^ structures - , entity, architecture, package + , entity, architecture, package, component -- ^ common things - , interfaceConstant, interfaceSignal, interfaceVariable - , declareConstant, declareSignal, declareVariable - , assignSignal, assignSignalS, assignVariable, assignArray - - , unconstrainedArray, constrainedArray + , constant, signal, variable, array + , assignSignal, assignVariable, assignArray + , concurrentSignal, concurrentArray + , portMap ) where import Language.VHDL +import Language.Embedded.VHDL.Monad.Util (maybePrimary) + import Control.Applicative ((<$>)) import Control.Monad.Identity (Identity) import Control.Monad.State (StateT, MonadState, MonadIO) import qualified Control.Monad.Identity as CMI import qualified Control.Monad.State as CMS +import Data.Either (partitionEithers) import Data.Maybe (catMaybes) import Data.Foldable (toList) import Data.Functor (fmap) -import Data.List (groupBy) +import Data.List (groupBy, isPrefixOf, stripPrefix, find) import Data.Set (Set) import Data.Map (Map) import qualified Data.Set as Set import qualified Data.Map as Map import Text.PrettyPrint (Doc) +import qualified Text.PrettyPrint as Text import Prelude hiding (null, not, abs, exp, rem, mod, div, and, or) import qualified Prelude as P +import Debug.Trace + -------------------------------------------------------------------------------- -- * VHDL monad and environment. -------------------------------------------------------------------------------- @@ -73,14 +85,14 @@ -- | Code generation state data VHDLEnv = VHDLEnv { _unique :: !Integer - , _designs :: [DesignUnit] + , _designs :: [DesignFile] + , _units :: [DesignUnit] , _context :: Set ContextItem , _types :: Set TypeDeclaration - , _ports :: [InterfaceDeclaration] - , _generics :: [InterfaceDeclaration] , _components :: Set ComponentDeclaration - , _global :: [BlockDeclarativeItem] - , _local :: [BlockDeclarativeItem] + , _constants :: [InterfaceDeclaration] + , _signals :: [InterfaceDeclaration] + , _variables :: [InterfaceDeclaration] , _concurrent :: [ConcurrentStatement] , _sequential :: [SequentialStatement] } @@ -89,13 +101,13 @@ emptyVHDLEnv = VHDLEnv { _unique = 0 , _designs = [] + , _units = [] , _context = Set.empty , _types = Set.empty , _components = Set.empty - , _ports = [] - , _generics = [] - , _global = [] - , _local = [] + , _constants = [] + , _signals = [] + , _variables = [] , _concurrent = [] , _sequential = [] } @@ -145,8 +157,8 @@ return u -- | Generates a fresh and unique identifier. -newSym :: MonadV m => m Identifier -newSym = do i <- freshUnique; return (Ident $ 'v' : show i) +newSym :: MonadV m => String -> m String +newSym n = do i <- freshUnique; return (n ++ show i) -- | Generates a fresh and unique label. newLabel :: MonadV m => m Label @@ -169,14 +181,6 @@ item :: ContextItem item = ContextUse (UseClause [SelectedName (PName (NSimple (Ident i))) (SAll)]) --- | Adds a port declaration to the entity. -addPort :: MonadV m => InterfaceDeclaration -> m () -addPort p = CMS.modify $ \s -> s { _ports = p : (_ports s) } - --- | Adds a generic declaration to the entity. -addGeneric :: MonadV m => InterfaceDeclaration -> m () -addGeneric g = CMS.modify $ \s -> s { _generics = g : (_generics s) } - -- | Adds a type declaration. addType :: MonadV m => TypeDeclaration -> m () addType t = CMS.modify $ \s -> s { _types = Set.insert t (_types s) } @@ -185,13 +189,18 @@ addComponent :: MonadV m => ComponentDeclaration -> m () addComponent c = CMS.modify $ \s -> s { _components = Set.insert c (_components s) } +-- | ... +addConstant :: MonadV m => InterfaceDeclaration -> m () +addConstant c = CMS.modify $ \s -> s { _constants = c : (_constants s) } + -- | Adds a global declaration. -addGlobal :: MonadV m => BlockDeclarativeItem -> m () -addGlobal g = CMS.modify $ \s -> s { _global = g : (_global s) } +addSignal :: MonadV m => InterfaceDeclaration -> m () +addSignal v = CMS.modify $ \s -> s { _signals = v : (_signals s) } -- | Adds a local declaration. -addLocal :: MonadV m => BlockDeclarativeItem -> m () -addLocal l = CMS.modify $ \s -> s { _local = l : (_local s) } +--addVariable :: MonadV m => BlockDeclarativeItem -> m () +addVariable :: MonadV m => InterfaceDeclaration -> m () +addVariable v = CMS.modify $ \s -> s { _variables = v : (_variables s) } -- | Adds a concurrent statement. addConcurrent :: MonadV m => ConcurrentStatement -> m () @@ -202,31 +211,164 @@ 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 + +-------------------------------------------------------------------------------- -- * Concurrent and sequential statements -------------------------------------------------------------------------------- +-- | Extract block declaration from interface declaration. +translateInterface :: InterfaceDeclaration -> BlockDeclarativeItem +translateInterface (InterfaceConstantDeclaration is t e) = + BDIConstant (ConstantDeclaration is t e) +translateInterface (InterfaceSignalDeclaration is m t b e) = + BDISignal (SignalDeclaration is t (Just (if b then Bus else Register)) e) +translateInterface (InterfaceVariableDeclaration is m t e) = + BDIShared (VariableDeclaration False is t e) +translateInterface (InterfaceFileDeclaration is t) = + BDIFile (FileDeclaration is t Nothing) + +-- | ... +translateSequential :: SequentialStatement -> ConcurrentStatement +translateSequential (SSignalAss (SignalAssignmentStatement _ name _ e)) = + ConSignalAss (CSASCond Nothing False (ConditionalSignalAssignment name (Options False Nothing) (ConditionalWaveforms [] (e, Nothing)))) + +-- | ... +translateConcurrent :: ConcurrentStatement -> SequentialStatement +translateConcurrent (ConSignalAss (CSASCond _ _ (ConditionalSignalAssignment name _ (ConditionalWaveforms _ (e, _))))) = + SSignalAss (SignalAssignmentStatement Nothing name Nothing e) + +-- | Run monadic actions in a contained environment. +contain :: MonadV m => m () -> m [SequentialStatement] +contain m = + do m -- do + new <- reverse <$> CMS.gets _sequential -- get + CMS.modify $ \e -> e { _sequential = [] } -- reset + return new -- return + +-- | Exit loop. +exit :: MonadV m => Label -> Expression -> m () +exit label e = addSequential $ SExit $ ExitStatement (Nothing) (Just label) (Just e) + +-------------------------------------------------------------------------------- + -- | Runs the given action inside a process. inProcess :: MonadV m => Label -> [Identifier] -> m a -> m (a, ProcessStatement) inProcess l is m = - do oldLocals <- CMS.gets _local + do oldLocals <- CMS.gets _variables oldSequential <- CMS.gets _sequential - CMS.modify $ \e -> e { _local = [] + CMS.modify $ \e -> e { _variables = [] , _sequential = [] } result <- m - newLocals <- reverse <$> CMS.gets _local + newLocals <- reverse <$> CMS.gets _variables newSequential <- reverse <$> CMS.gets _sequential - CMS.modify $ \e -> e { _local = oldLocals + CMS.modify $ \e -> e { _variables = oldLocals , _sequential = oldSequential } return ( result - , ProcessStatement - (Just l) -- label - (False) -- postponed - (sensitivity) -- sensitivitylist - (translate $ merge $ newLocals) -- declarativepart - (newSequential)) -- statementpart + , ProcessStatement (Just l) (False) + (sensitivity is) + (fmap (translate . translateInterface) $ merge $ newLocals) + (newSequential)) where - sensitivity | P.null is = Nothing - | otherwise = Just $ SensitivityList $ fmap NSimple is + sensitivity :: [Identifier] -> Maybe SensitivityList + sensitivity [] = Nothing + sensitivity xs = Just $ SensitivityList $ fmap NSimple xs -- | Run program in for loop. inFor :: MonadV m => Identifier -> Range -> m () -> m (LoopStatement) @@ -261,10 +403,6 @@ iter :: Maybe Expression -> Maybe IterationScheme iter = maybe (Nothing) (Just . IterWhile) --- | Exit loop. -exit :: MonadV m => Label -> Expression -> m () -exit label e = addSequential $ SExit $ ExitStatement (Nothing) (Just label) (Just e) - -- | Conditional statements. inConditional :: MonadV m => (Condition, m ()) -> [(Condition, m ())] -> m () -> m (IfStatement) inConditional (c, m) os e = @@ -276,55 +414,55 @@ e' <- contain e CMS.modify $ \e -> e { _sequential = oldSequential } return $ - IfStatement - (Nothing) + IfStatement Nothing (c, m') (zip cs ns') (maybeList e') where maybeList :: [SequentialStatement] -> Maybe [SequentialStatement] - maybeList xs - | P.null xs = Nothing - | otherwise = Just xs + maybeList [] = Nothing + maybeList xs = Just xs -- | Case statements. -inCase :: MonadV m => Expression -> [(Choices, m ())] -> m (CaseStatement) -inCase e choices = +inCase :: MonadV m => Expression -> [(Choices, m ())] -> m () -> m (CaseStatement) +inCase e choices d = do let (cs, ns) = unzip choices oldSequential <- CMS.gets _sequential CMS.modify $ \e -> e { _sequential = [] } ns' <- mapM contain ns - CMS.modify $ \e -> e { _sequential = oldSequential } + d' <- contain d + CMS.modify $ \e -> e { _sequential = oldSequential } + let xs = zipWith CaseStatementAlternative cs ns' return $ - CaseStatement - (Nothing) - (e) - (zipWith CaseStatementAlternative cs ns') - -contain :: MonadV m => m () -> m [SequentialStatement] -contain m = do - m -- do - new <- reverse <$> CMS.gets _sequential -- get - CMS.modify $ \e -> e { _sequential = [] } -- reset - return new -- return + CaseStatement Nothing e + (xs ++ maybeList d') + where + maybeList :: [SequentialStatement] -> [CaseStatementAlternative] + maybeList [] = [] + maybeList xs = [CaseStatementAlternative (Choices [ChoiceOthers]) xs] + -------------------------------------------------------------------------------- -- * Design units -------------------------------------------------------------------------------- --- ... design unit with context -addDesign :: MonadV m => LibraryUnit -> m () -addDesign lib = +-- | Design file. +addDesign :: MonadV m => DesignFile -> m () +addDesign d = CMS.modify $ \s -> s { _designs = d : (_designs s) } + +-- | Design unit with context. +addUnit :: MonadV m => LibraryUnit -> m () +addUnit lib = do ctxt <- CMS.gets _context - dsig <- CMS.gets _designs + dsig <- CMS.gets _units let item = DesignUnit (ContextClause (Set.toList ctxt)) lib - CMS.modify $ \s -> s { _designs = item : dsig + CMS.modify $ \s -> s { _units = item : dsig , _context = Set.empty } --- .. design unit ignoring context -addDesign_ :: MonadV m => LibraryUnit -> m () -addDesign_ lib = CMS.modify $ \s -> s { _designs = (DesignUnit (ContextClause []) lib) : (_designs s)} +-- | Design unit ignoring context. +addUnit_ :: MonadV m => LibraryUnit -> m () +addUnit_ lib = CMS.modify $ \s -> s { _units = (DesignUnit (ContextClause []) lib) : (_units s)} -------------------------------------------------------------------------------- -- ** Architectures @@ -333,23 +471,47 @@ -- identifiers and concurrent statements it produces. Strings are its entity -- and architecture names, respectively. architecture :: MonadV m => Identifier -> Identifier -> m a -> m a -architecture entity name m = - do oldGlobal <- CMS.gets _global +architecture entity@(Ident n) name@(Ident e) m = + do oldConstants <- CMS.gets _constants + oldGlobal <- CMS.gets _signals oldConcurrent <- CMS.gets _concurrent - CMS.modify $ \e -> e { _global = [] - , _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 } result <- m - newGlobal <- reverse <$> CMS.gets _global + newConstants <- reverse <$> CMS.gets _constants + newGlobal <- reverse <$> CMS.gets _signals newConcurrent <- reverse <$> CMS.gets _concurrent - addDesign_ $ LibrarySecondary $ SecondaryArchitecture $ - ArchitectureBody - (name) + newSequential <- reverse . filter isSignal <$> CMS.gets _sequential + newTypes <- fmap BDIType . Set.toList <$> CMS.gets _types + newComponents <- fmap BDIComp . Set.toList <$> CMS.gets _components + let signals = fmap translateSequential newSequential + addUnit_ $ LibrarySecondary $ SecondaryArchitecture $ + ArchitectureBody (name) (NSimple entity) - (merge newGlobal) - (newConcurrent) - CMS.modify $ \e -> e { _global = oldGlobal - , _concurrent = oldConcurrent } + (newTypes -- merge + ++ newComponents + ++ fmap translateInterface newGlobal + ++ fmap translateInterface newConstants) + (signals ++ newConcurrent) + CMS.modify $ \e -> e { _constants = oldConstants + , _signals = oldGlobal + , _concurrent = oldConcurrent + , _sequential = oldSequential + , _types = oldTypes + , _components = oldComponents } + extendContext entity return result + where + isSignal :: SequentialStatement -> Bool + isSignal (SSignalAss _) = True + isSignal _ = False -------------------------------------------------------------------------------- -- ** Entities @@ -357,30 +519,43 @@ -- | Declares an entity with the given name by consuming all port-level -- declaraions and context items produced by running the monadic action. entity :: MonadV m => Identifier -> m a -> m a -entity name m = - do oldPorts <- CMS.gets _ports - oldGenerics <- CMS.gets _generics - CMS.modify $ \e -> e { _ports = [] - , _generics = [] } +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 = [] } result <- m - newPorts <- reverse <$> CMS.gets _ports - newGenerics <- reverse <$> CMS.gets _generics - addDesign $ LibraryPrimary $ PrimaryEntity $ - EntityDeclaration - (name) + 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 { _ports = oldPorts - , _generics = oldGenerics } + CMS.modify $ \e -> e { _types = oldTypes + , _signals = oldPorts + , _variables = oldGenerics } return result - where - maybeNull :: [InterfaceDeclaration] -> Maybe InterfaceList - maybeNull [] = Nothing - maybeNull xs = Just $ InterfaceList $ merge xs +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 @@ -392,14 +567,26 @@ CMS.modify $ \e -> e { _types = Set.empty } result <- m newTypes <- CMS.gets _types - addDesign $ LibraryPrimary $ PrimaryPackage $ - PackageDeclaration - (Ident name) - (fmap PHDIType $ Set.toList newTypes) + addUnit $ packageTypes name newTypes CMS.modify $ \e -> e { _types = oldTypes } return result -------------------------------------------------------------------------------- +-- ** Component. + +-- | Declares an entire component, with entity declaration and a body. +component :: MonadV m => m () -> m () +component m = + do oldEnv <- CMS.get + oldFiles <- CMS.gets _designs + CMS.put (emptyVHDLEnv { _designs = oldFiles }) + m + newUnits <- CMS.gets _units + newFiles <- CMS.gets _designs + CMS.put (oldEnv { _designs = newFiles }) + addDesign $ DesignFile newUnits + +-------------------------------------------------------------------------------- -- * Pretty printing VHDL programs -------------------------------------------------------------------------------- @@ -414,30 +601,36 @@ -------------------------------------------------------------------------------- -- | Pretty print a VHDL environment. --- --- *** Shouldn't use revers to fix ordering issues! Pair architectures/bodies --- with their respective entities. prettyVEnv :: VHDLEnv -> Doc -prettyVEnv env = pp (DesignFile $ types ++ archi) +prettyVEnv env = Text.vcat (pp main : fmap pp files) where - archi = reverse $ _designs env - types = reverse $ designTypes (_types env) + main = DesignFile units + units = reverse $ _units env + files = reverse $ map reorderDesign $ _designs env --- *** Scan type declarations for necessary imports instead. --- *** Types are added in an ugly manner. -designTypes :: Set TypeDeclaration -> [DesignUnit] -designTypes set - | Set.null set = [] - | otherwise = _designs . snd $ runVHDL pack emptyVHDLEnv +-------------------------------------------------------------------------------- + +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 - pack :: MonadV m => m () - pack = package "types" $ do - -- *** Instead of importing every library possible the correct ones - -- should be declared when adding a type through 'addType'. - newLibrary "IEEE" - newImport "IEEE.STD_LOGIC_1164" - newImport "IEEE.NUMERIC_STD" - CMS.modify $ \e -> e { _types = set } + reorder :: [ContextItem] -> [ContextItem] -> [ContextItem] + reorder [] rs = rs + reorder (lib@(ContextLibrary _) : cs) rs = lib : (rs ++ cs) + reorder (use@(ContextUse _) : cs) rs = reorder (use : rs) cs -------------------------------------------------------------------------------- -- * Common things @@ -446,77 +639,70 @@ -------------------------------------------------------------------------------- -- ** Ports/Generic declarations -interfaceConstant :: Identifier -> SubtypeIndication -> Maybe Expression -> InterfaceDeclaration -interfaceConstant i t e = InterfaceConstantDeclaration [i] t e +constant :: MonadV m => Identifier -> SubtypeIndication -> Expression -> m () +constant i t e = addConstant $ InterfaceConstantDeclaration [i] t (Just e) -interfaceSignal :: Identifier -> Mode -> SubtypeIndication -> Maybe Expression -> InterfaceDeclaration -interfaceSignal i m t e = InterfaceSignalDeclaration [i] (Just m) t False e +signal :: MonadV m => Identifier -> Mode -> SubtypeIndication -> Maybe Expression -> m () +signal i m t e = addSignal $ InterfaceSignalDeclaration [i] (Just m) t False e -interfaceVariable :: Identifier -> Mode -> SubtypeIndication -> Maybe Expression -> InterfaceDeclaration -interfaceVariable i m t e = InterfaceVariableDeclaration [i] (Just m) t e +variable :: MonadV m => Identifier -> SubtypeIndication -> Maybe Expression -> m () +variable i t e = addVariable $ InterfaceVariableDeclaration [i] Nothing t e +array :: MonadV m => Identifier -> Mode -> SubtypeIndication -> Maybe Expression -> m () +array = signal + -------------------------------------------------------------------------------- --- ** Array Declarations. +-- ** Assign Signal/Variable. -compositeTypeDeclaration :: Identifier -> CompositeTypeDefinition -> TypeDeclaration -compositeTypeDeclaration name t = TDFull (FullTypeDeclaration name (TDComposite t)) +assignSignal :: MonadV m => Name -> Expression -> m () +assignSignal n e = addSequential $ SSignalAss $ + SignalAssignmentStatement + (Nothing) + (TargetName n) + (Nothing) + (WaveElem [WaveEExp e Nothing]) -unconstrainedArray :: Identifier -> SubtypeIndication -> TypeDeclaration -unconstrainedArray name typ = compositeTypeDeclaration name $ - CTDArray (ArrU (UnconstrainedArrayDefinition [] typ)) +assignVariable :: MonadV m => Name -> Expression -> m () +assignVariable n e = addSequential $ SVarAss $ + VariableAssignmentStatement + (Nothing) + (TargetName n) + (e) -constrainedArray :: Identifier -> SubtypeIndication -> Range -> TypeDeclaration -constrainedArray name typ range = compositeTypeDeclaration name $ - CTDArray (ArrC (ConstrainedArrayDefinition - (IndexConstraint [DRRange range]) typ)) +assignArray :: MonadV m => Name -> Expression -> m () +assignArray = assignSignal -------------------------------------------------------------------------------- --- ** Global/Local Declarations. -declareConstant :: Identifier -> SubtypeIndication -> Maybe Expression -> BlockDeclarativeItem -declareConstant i t e = BDIConstant $ ConstantDeclaration [i] t e - -declareSignal :: Identifier -> SubtypeIndication -> Maybe Expression -> BlockDeclarativeItem -declareSignal i t e = BDISignal $ SignalDeclaration [i] t Nothing e +concurrentSignal :: MonadV m => Name -> Expression -> m () +concurrentSignal n e = addConcurrent $ ConSignalAss $ + CSASCond Nothing False $ + ConditionalSignalAssignment (TargetName n) (Options False Nothing) $ + ConditionalWaveforms [] (WaveElem [WaveEExp e Nothing], Nothing) -declareVariable :: Identifier -> SubtypeIndication -> Maybe Expression -> BlockDeclarativeItem -declareVariable i t e = BDIShared $ VariableDeclaration False [i] t e +concurrentArray :: MonadV m => Name -> Expression -> m () +concurrentArray = concurrentSignal -------------------------------------------------------------------------------- --- ** Assign Signal/Variable. +-- Portmap. -assignSignal :: Identifier -> Expression -> ConcurrentStatement -assignSignal i e = ConSignalAss $ CSASCond Nothing False $ - ConditionalSignalAssignment - (TargetName (NSimple i)) - (Options False Nothing) - (ConditionalWaveforms - ([]) - ( WaveElem [WaveEExp e Nothing] - , Nothing)) +portMap :: MonadV m => Label -> Identifier -> [(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) -assignSignalS :: Identifier -> Expression -> SequentialStatement -assignSignalS i e = SSignalAss $ - SignalAssignmentStatement - (Nothing) - (TargetName (NSimple i)) - (Nothing) - (WaveElem [WaveEExp e Nothing]) +declareComponent :: MonadV m => Identifier -> [InterfaceDeclaration] -> m () +declareComponent name is = addComponent $ ComponentDeclaration name Nothing + (Just (PortClause (InterfaceList is))) + (Nothing) -assignVariable :: Identifier -> Expression -> SequentialStatement -assignVariable i e = SVarAss $ - VariableAssignmentStatement - (Nothing) - (TargetName (NSimple i)) - (e) +-------------------------------------------------------------------------------- +-- .... -assignArray :: Name -> Expression -> SequentialStatement -assignArray i e = SSignalAss $ - SignalAssignmentStatement - (Nothing) - (TargetName i) - (Nothing) - (WaveElem [WaveEExp e Nothing]) +null :: MonadV m => m () +null = addSequential $ SNull $ NullStatement Nothing -------------------------------------------------------------------------------- -- Some helper classes and their instances @@ -549,6 +735,23 @@ -------------------------------------------------------------------------------- +class Declarative a + where + translate :: BlockDeclarativeItem -> a + +instance Declarative ProcessDeclarativeItem + where + translate = processBlock + +-- | Try to transform the declarative item into a process item +processBlock :: BlockDeclarativeItem -> ProcessDeclarativeItem +processBlock (BDIConstant c) = PDIConstant c +processBlock (BDIShared v) = PDIVariable v +processBlock (BDIFile f) = PDIFile f +processBlock b = error $ "Unknown block item: " ++ show b + +-------------------------------------------------------------------------------- + setBlockIds :: BlockDeclarativeItem -> [Identifier] -> BlockDeclarativeItem setBlockIds (BDIConstant c) is = BDIConstant $ c { const_identifier_list = is } setBlockIds (BDISignal s) is = BDISignal $ s { signal_identifier_list = is } @@ -562,27 +765,11 @@ getBlockIds (BDIShared v) = var_identifier_list v getBlockIds (BDIFile f) = fd_identifier_list f -class Declarative a - where - -- lists are used so we can fail without having to throw errors - translate :: [BlockDeclarativeItem] -> [a] - -instance Declarative ProcessDeclarativeItem - where - translate = catMaybes . fmap tryProcess - --- | Try to transform the declarative item into a process item -tryProcess :: BlockDeclarativeItem -> Maybe (ProcessDeclarativeItem) -tryProcess (BDIConstant c) = Just $ PDIConstant c -tryProcess (BDIShared v) = Just $ PDIVariable v -tryProcess (BDIFile f) = Just $ PDIFile f -tryProcess _ = Nothing - -------------------------------------------------------------------------------- -- Ord instance for use in sets -------------------------------------------------------------------------------- -- --- *** These break the Ord rules but seems to be needed for Set. +-- todo: don't rely on these too much. deriving instance Ord ContextItem deriving instance Ord LibraryClause @@ -591,24 +778,48 @@ instance Ord TypeDeclaration where - compare (TDFull l) (TDFull r) = compare (ftd_identifier l) (ftd_identifier r) - compare (TDPartial l) (TDPartial r) = compare l r - compare (TDFull l) _ = GT - compare (TDPartial l) _ = LT + 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 l r = compare (comp_identifier l) (comp_identifier r) + 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 b) = compare a b - compare _ _ = error "Ord not supported for index constraints" + compare (CRange a) (CRange x) = compare a x + compare _ _ = error "Ord not supported for index constraints." deriving instance Ord RangeConstraint @@ -637,8 +848,39 @@ instance Ord Primary where - compare (PrimName a) (PrimName x) = compare a x + 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 @@ -678,5 +920,16 @@ 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/Expression.hs b/src/Language/Embedded/VHDL/Monad/Expression.hs --- a/src/Language/Embedded/VHDL/Monad/Expression.hs +++ b/src/Language/Embedded/VHDL/Monad/Expression.hs @@ -5,19 +5,22 @@ , add, sub, cat, neg , mul, div, mod, rem , exp, abs, not - , name, string, indexed, selected, slice - , lit, null - , aggregate, associate + , name, simple, indexed, selected, slice, attribute + , literal, number, string + , aggregate, aggregated, associated, others , function , qualified , cast - , resize + -- utility. + , resize, asBits, asSigned, asUnsigned, toSigned, toUnsigned, toInteger , range, downto, to + , point, upper, lower, zero + , choices, is, between ) where import Language.VHDL -import Prelude hiding (and, or, div, mod, rem, exp, abs, not, null) +import Prelude hiding (and, or, div, mod, rem, exp, abs, not, null, toInteger) -------------------------------------------------------------------------------- -- * Expressions and their sub-layers. @@ -101,67 +104,139 @@ not = FacNot -------------------------------------------------------------------------------- --- ** Primaries +-- ** Primaries. --- names -name :: String -> Primary -name = PrimName . NSimple . Ident +-------------------------------------------------------------------------------- +-- *** Names. -string :: String -> Primary -string = PrimLit . LitString . SLit +name :: Name -> Primary +name = PrimName -indexed :: Identifier -> Expression -> Name -indexed i l = NIndex $ IndexedName (PName $ NSimple i) [l] +simple :: String -> Name +simple = NSimple . Ident -selected :: Identifier -> Identifier -> Primary -selected p s = PrimName $ NSelect $ SelectedName (PName $ NSimple p) (SSimple s) +selected :: Name -> Identifier -> Name +selected i s = NSelect $ SelectedName (PName i) (SSimple s) -slice :: Identifier -> (SimpleExpression, SimpleExpression) -> Primary -slice i (f, t) = PrimName $ NSlice $ SliceName (PName $ NSimple i) (DRRange $ RSimple f DownTo t) +indexed :: Name -> Expression -> Name +indexed i l = NIndex $ IndexedName (PName i) [l] --- literals -lit :: Show i => i -> Primary -lit = PrimLit . LitNum . NLitPhysical . PhysicalLiteral Nothing . NSimple . Ident . show +slice :: Name -> Range -> Name +slice i r = NSlice $ SliceName (PName i) (DRRange r) -null :: Primary -null = PrimLit LitNull +attribute :: String -> Name -> Primary +attribute s n = PrimName $ NAttr $ AttributeName (PName n) Nothing (Ident s) Nothing --- aggregates -aggregate :: [Expression] -> Primary -aggregate = PrimAgg . Aggregate . fmap (ElementAssociation Nothing) +-------------------------------------------------------------------------------- +-- *** Literals. -associate :: [(Maybe Choices, Expression)] -> Primary -associate es = PrimAgg $ Aggregate $ map (uncurry ElementAssociation) es +literal :: Literal -> Primary +literal = PrimLit --- function calls -function :: Identifier -> [Expression] -> Primary -function i [] = PrimFun $ FunctionCall (NSimple i) Nothing +number :: String -> Literal +number = LitNum . NLitPhysical . PhysicalLiteral Nothing . NSimple . Ident + +string :: String -> Literal +string = LitString . SLit + +-------------------------------------------------------------------------------- +-- *** Aggregates. + +aggregate :: Aggregate -> Primary +aggregate = PrimAgg + +aggregated :: [Expression] -> Aggregate +aggregated = Aggregate . fmap (ElementAssociation Nothing) + +associated :: [(Maybe Choices, Expression)] -> Aggregate +associated es = Aggregate $ map (uncurry ElementAssociation) es + +others :: Expression -> Aggregate +others = Aggregate . (:[]) . ElementAssociation (Just (Choices [ChoiceOthers])) + +-------------------------------------------------------------------------------- +-- *** Functions. + +function :: Name -> [Expression] -> Primary +function i [] = PrimFun $ FunctionCall i Nothing function i xs = PrimFun - . FunctionCall (NSimple i) . Just . AssociationList + . FunctionCall i . Just . AssociationList $ fmap (AssociationElement Nothing . APDesignator . ADExpression) xs --- qualified expressions +-------------------------------------------------------------------------------- +-- *** Qualified. + qualified :: SubtypeIndication -> Expression -> Primary qualified (SubtypeIndication _ t _) = PrimQual . QualExp t --- type conversions +-------------------------------------------------------------------------------- +-- *** Type conversion. + cast :: SubtypeIndication -> Expression -> Primary -cast (SubtypeIndication _ t _) = PrimTCon . TypeConversion t +cast (SubtypeIndication _ t _) = PrimTCon . TypeConversion (unrange t) + where + unrange :: TypeMark -> TypeMark + unrange (TMType (NSlice (SliceName (PName (NSimple (Ident typ))) _))) = TMType (NSimple (Ident typ)) + unrange (TMType (NSimple (Ident typ))) = TMType (NSimple (Ident typ)) -------------------------------------------------------------------------------- --- ** Utility +-- ... resize :: Expression -> Expression -> Primary -resize size exp = PrimFun $ FunctionCall name $ Just $ AssociationList [assoc size, assoc exp] - where - name = NSimple $ Ident "resize" - assoc = AssociationElement Nothing . APDesignator . ADExpression +resize exp size = function (simple "resize") [exp, size] +asBits :: Expression -> Primary +asBits exp = function (simple "std_logic_vector") [exp] + +asSigned :: Expression -> Primary +asSigned exp = function (simple "signed") [exp] + +asUnsigned :: Expression -> Primary +asUnsigned exp = function (simple "unsigned") [exp] + +toSigned :: Expression -> Expression -> Primary +toSigned exp size = function (simple "to_signed") [exp, size] + +toUnsigned :: Expression -> Expression -> Primary +toUnsigned exp size = function (simple "to_unsigned") [exp, size] + +toInteger :: Expression -> Primary +toInteger exp = function (simple "to_integer") [exp] + +-------------------------------------------------------------------------------- +-- ... + range :: SimpleExpression -> Direction -> SimpleExpression -> Range -range = RSimple +range = RSimple downto, to :: Direction downto = DownTo to = To + +-------------------------------------------------------------------------------- +-- ... + +point :: Show i => i -> SimpleExpression +point i = SimpleExpression Nothing (Term (FacPrim (literal (number (show i))) (Nothing)) []) [] + +upper, lower :: Integer -> SimpleExpression +upper 0 = point 0 +upper n = point (n-1) +lower n = point n + +zero :: SimpleExpression +zero = point 0 + +-------------------------------------------------------------------------------- +-- ... + +choices :: [Choice] -> Choices +choices = Choices + +is :: SimpleExpression -> Choice +is = ChoiceSimple + +between :: Range -> Choice +between = ChoiceRange . DRRange -------------------------------------------------------------------------------- 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 @@ -1,16 +1,26 @@ module Language.Embedded.VHDL.Monad.Type ( Type , Kind(..) - - , std_logic - , signed8, signed16, signed32, signed64 - , usigned8, usigned16, usigned32, usigned64 + , std_logic, std_logic_vector + , signed2, signed4, signed8, signed16, signed32, signed64 + , usigned2, usigned4, usigned8, usigned16, usigned32, usigned64 + , integer , float, double + , unconstrainedArray, constrainedArray + -- utility. + , typeName, typeRange, typeWidth + , isBit, isBits, isSigned, isUnsigned, isInteger ) where import Language.VHDL -import Language.Embedded.VHDL.Monad.Expression (lit) +import Language.Embedded.VHDL.Monad.Expression + ( literal + , number + , range + , point + , upper + , zero ) -------------------------------------------------------------------------------- -- * VHDL Types. @@ -26,32 +36,42 @@ -- ** Standard logic types. std_logic :: Type -std_logic = SubtypeIndication Nothing (TMType (NSimple (Ident "std_logic"))) Nothing +std_logic = SubtypeIndication Nothing + (TMType (NSimple (Ident "std_logic"))) + (Nothing) +std_logic_vector :: Integer -> Type +std_logic_vector range = SubtypeIndication Nothing + (TMType (NSlice (SliceName + (PName (NSimple (Ident "std_logic_vector"))) + (DRRange (RSimple (upper range) DownTo zero))))) + (Nothing) + -------------------------------------------------------------------------------- -- ** Signed & unsigned numbers. -arith :: String -> Int -> Type +arith :: String -> Integer -> Type arith typ range = SubtypeIndication Nothing - (TMType (NSlice (SliceName - (PName (NSimple (Ident typ))) - (DRRange (RSimple (point (range - 1)) DownTo (point 0)))))) - (Nothing) - where - point :: Int -> SimpleExpression - point i = SimpleExpression Nothing (Term (FacPrim (lit i) (Nothing)) []) [] + (TMType (NSlice (SliceName + (PName (NSimple (Ident typ))) + (DRRange (RSimple (upper range) DownTo zero))))) + (Nothing) -signed, usigned :: Int -> Type +signed, usigned :: Integer -> Type signed = arith "signed" usigned = arith "unsigned" -signed8, signed16, signed32, signed64 :: Type +signed2, signed4, signed8, signed16, signed32, signed64 :: Type +signed2 = signed 2 +signed4 = signed 4 signed8 = signed 8 signed16 = signed 16 signed32 = signed 32 signed64 = signed 64 -usigned8, usigned16, usigned32, usigned64 :: Type +usigned2, usigned4, usigned8, usigned16, usigned32, usigned64 :: Type +usigned2 = usigned 2 +usigned4 = usigned 4 usigned8 = usigned 8 usigned16 = usigned 16 usigned32 = usigned 32 @@ -69,5 +89,75 @@ float = floating 32 double = floating 64 --- .. add more .. +-------------------------------------------------------------------------------- +-- ** Integers. + +integer :: Maybe Range -> Type +integer r = SubtypeIndication Nothing + (TMType (NSimple (Ident "integer"))) + (fmap (CRange . RangeConstraint) r) + +-------------------------------------------------------------------------------- +-- ** Array Declarations. + +compositeTypeDeclaration :: Identifier -> CompositeTypeDefinition -> TypeDeclaration +compositeTypeDeclaration name t = TDFull (FullTypeDeclaration name (TDComposite t)) + +unconstrainedArray :: Identifier -> SubtypeIndication -> TypeDeclaration +unconstrainedArray name typ = compositeTypeDeclaration name $ + CTDArray (ArrU (UnconstrainedArrayDefinition [] typ)) + +constrainedArray :: Identifier -> SubtypeIndication -> Range -> TypeDeclaration +constrainedArray name typ range = compositeTypeDeclaration name $ + CTDArray (ArrC (ConstrainedArrayDefinition + (IndexConstraint [DRRange range]) typ)) + +-------------------------------------------------------------------------------- +-- Utility. + +typeName :: Type -> String +typeName (SubtypeIndication _ (TMType (NSimple (Ident n))) _) = n +typeName (SubtypeIndication _ (TMType (NSlice (SliceName (PName (NSimple (Ident n))) _))) _) = n + +typeRange :: Type -> Maybe Range +typeRange (SubtypeIndication _ (TMType (NSlice (SliceName _ (DRRange r)))) _) = Just r +typeRange _ = Nothing + +-- 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 + unrange (TMType (NSlice (SliceName _ (DRRange (RSimple l To u))))) = + unliteral u - unliteral l + 1 + + unconstraint :: Constraint -> Integer + unconstraint (CRange (RangeConstraint (RSimple u DownTo l))) = + unliteral u - unliteral l + 1 + unconstraint (CRange (RangeConstraint (RSimple l To u))) = + unliteral u - unliteral l + 1 + +-------------------------------------------------------------------------------- + +isBit :: Type -> Bool +isBit t = "std_logic" == typeName t + +isBits :: Type -> Bool +isBits t = "std_logic_vector" == typeName t + +isSigned :: Type -> Bool +isSigned t = "signed" == typeName t + +isUnsigned :: Type -> Bool +isUnsigned t = "unsigned" == typeName t + +isInteger :: Type -> Bool +isInteger t = "integer" == typeName t + -------------------------------------------------------------------------------- diff --git a/src/Language/Embedded/VHDL/Monad/Util.hs b/src/Language/Embedded/VHDL/Monad/Util.hs new file mode 100644 --- /dev/null +++ b/src/Language/Embedded/VHDL/Monad/Util.hs @@ -0,0 +1,191 @@ +module Language.Embedded.VHDL.Monad.Util + ( uType, uCast, uResize, uResizeBits + -- utility. + , maybePrimary, maybeLit, maybeVar, maybeFun, maybeExp + , printPrimary + , printBits + ) where + +import Language.VHDL +import Language.Embedded.VHDL.Monad.Expression +import Language.Embedded.VHDL.Monad.Type + +import Text.Printf + +import Prelude hiding (toInteger) + +-------------------------------------------------------------------------------- +-- * Temp (still working on these). +-------------------------------------------------------------------------------- + +uType :: Expression -> SubtypeIndication -> Expression +uType exp to = uCast exp to to + +-- todo: handle bit case better. +-- todo: add naturals for unsigned integers. +uCast :: Expression -> SubtypeIndication -> SubtypeIndication -> Expression +uCast exp from to | isInteger from = go + where + -- Integer -> X + go | isInteger to = exp + | isUnsigned to = expr $ toUnsigned exp $ expr $ width to + | isSigned to = expr $ toSigned exp $ expr $ width to + | isBits to = expr $ asBits + $ expr $ toSigned exp + $ expr $ width to + | otherwise = exp +uCast exp from to | isUnsigned from = go + where + -- Unsigned -> X + go | isInteger to, Just lit <- maybeLit exp = exp + | isInteger to = expr $ toInteger exp + | isUnsigned to = uResize exp from to + | isSigned to = expr $ asSigned $ uResize exp from to + | isBits to = expr $ asBits $ uResize exp from to + | otherwise = exp +uCast exp from to | isSigned from = go + where + -- Signed -> X + go | isInteger to , Just lit <- maybeLit exp = exp + | isInteger to = expr $ toInteger exp + | isUnsigned to = expr $ asUnsigned $ uResize exp from to + | isSigned to = uResize exp from to + | isBits to = expr $ asBits $ uResize exp from to + | otherwise = exp +uCast exp from to | isBits from = go + where + -- Bits n -> X + go | isInteger to, Just lit <- maybeLit exp = exp + | isInteger to = expr $ toInteger $ expr $ asSigned exp + | isUnsigned to = uResize (expr $ asUnsigned exp) from to + | isSigned to = uResize (expr $ asSigned exp) from to + | isBits to = uResizeBits exp from to + | otherwise = exp +uCast exp from to | isBit from, isBit to = exp +uCast exp from to = + error $ "hardware-edsl.todo: missing type cast from (" + ++ show (typeName from) ++ ") to (" + ++ show (typeName to) ++ ")." + +uResize :: Expression -> SubtypeIndication -> SubtypeIndication -> Expression +uResize exp from to + -- if literal, simply resize it. + | Just p <- maybeLit exp = expr $ literal $ number $ printPrimary p to + -- if variable, and types are equal, disregard resize. + | Just v <- maybeVar exp, typeWidth from == typeWidth to = exp + -- if already resized, disregard new resize. + | Just w <- castWidth exp, w == typeWidth to = exp + -- otherwise, resize. + | otherwise = expr $ resize exp $ expr $ width to + where + + +uResizeBits :: Expression -> SubtypeIndication -> SubtypeIndication -> Expression +uResizeBits exp from to + -- if literal, simply resize it. + | Just p <- maybeLit exp = expr $ literal $ number $ printPrimary p to + -- if variable, and same size, disregard resize. + | typeWidth from == typeWidth to = exp + -- if target is smaller, slice source. + | typeWidth from > typeWidth to + , Just r <- typeRange to = expr $ name $ slice prefix r + -- if target is larger, append zeroes. + | typeWidth from < typeWidth to = + 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]) + | otherwise = error $ show exp + where + prefix :: Name + prefix | Just (PrimName n) <- maybeVar exp = n + | Just (PrimFun f) <- maybeFun exp = fc_function_name f + | otherwise = error "hardware-edsl.slice: prefix of slice not var/fun." + +-------------------------------------------------------------------------------- + +expr :: Primary -> Expression +expr (PrimExp e) = e +expr (primary) = ENand (Relation (ShiftExpression (SimpleExpression Nothing (Term (FacPrim primary Nothing) []) []) Nothing) Nothing) Nothing + +term :: Primary -> Term +term primary = Term (FacPrim primary Nothing) [] + +width :: SubtypeIndication -> Primary +width = literal . number . show . typeWidth + +-------------------------------------------------------------------------------- + +maybePrimary :: Expression -> Maybe Primary +maybePrimary (ENand (Relation (ShiftExpression (SimpleExpression Nothing (Term (FacPrim p Nothing) []) []) Nothing) Nothing) Nothing) = Just p +maybePrimary _ = Nothing + +maybeLit :: Expression -> Maybe Primary +maybeLit e | Just p@(PrimLit _) <- maybePrimary e = Just p + | otherwise = Nothing + +maybeVar :: Expression -> Maybe Primary +maybeVar e | Just p@(PrimName _) <- maybePrimary e = Just p + | otherwise = Nothing + +maybeFun :: Expression -> Maybe Primary +maybeFun e | Just p@(PrimFun _) <- maybePrimary e = Just p + | otherwise = Nothing + +maybeCast :: Expression -> Maybe Primary +maybeCast e | Just p@(PrimTCon _) <- maybePrimary e = Just p + | otherwise = Nothing + +maybeExp :: Expression -> Maybe Expression +maybeExp e | Just (PrimExp p) <- maybePrimary e = Just p + | otherwise = Nothing + +-------------------------------------------------------------------------------- + +castWidth :: Expression -> Maybe Integer +castWidth e + | Just f <- maybeFun e + , Just (n, as) <- stripFun f = widthOf n as + where + widthOf :: String -> [Expression] -> Maybe Integer + widthOf "resize" [e, size] = stripNum =<< maybeLit size + widthOf "to_signed" [e, size] = stripNum =<< maybeLit size + widthOf "to_unsigned" [e, size] = stripNum =<< maybeLit size + widthOf "to_integer" [e] = Nothing -- todo: hmm? + widthOf "signed" [e] = castWidth e + widthOf "unsigned" [e] = castWidth e + widthOf "std_logic_vector" [e] = castWidth e + widthOf _ _ = Nothing +castWidth _ = Nothing + +-------------------------------------------------------------------------------- + +stripNum :: Primary -> Maybe Integer +stripNum (PrimLit (LitNum (NLitPhysical (PhysicalLiteral Nothing (NSimple (Ident i)))))) = Just (read i) +stripNum _ = Nothing + +stripFun :: Primary -> Maybe (String, [Expression]) +stripFun (PrimFun (FunctionCall (NSimple (Ident i)) Nothing)) = Just (i, []) +stripFun (PrimFun (FunctionCall (NSimple (Ident i)) (Just (AssociationList as)))) = Just (i, stripArgs as) + where + stripArgs :: [AssociationElement] -> [Expression] + stripArgs [] = [] + stripArgs ((AssociationElement Nothing (APDesignator (ADExpression a))):as) = a : stripArgs as +stripFun _ = Nothing + +stripPrimary :: Primary -> Maybe Expression +stripPrimary (PrimExp e) = Just e +stripPrimary _ = Nothing + +-------------------------------------------------------------------------------- + +-- todo: this assumes i>0? and i<2^(width t)? +printPrimary :: Primary -> SubtypeIndication -> String +printPrimary p t = case (stripNum p) of + Just i -> printBits (typeWidth t) i + Nothing -> error "hardware-edsl.printPrimary: not a literal." + +printBits :: (PrintfArg a, PrintfType b) => Integer -> a -> b +printBits zeroes = printf ("\"%0" ++ show zeroes ++ "b\"") + +--------------------------------------------------------------------------------