imperative-edsl-vhdl 0.2.0.1 → 0.3.2
raw patch · 11 files changed
+1304/−725 lines, 11 filesdep +syntacticdep ~language-vhdl
Dependencies added: syntactic
Dependency ranges changed: language-vhdl
Files
- imperative-edsl-vhdl.cabal +5/−4
- src/Language/Embedded/VHDL.hs +0/−4
- src/Language/Embedded/VHDL/Command.hs +157/−90
- src/Language/Embedded/VHDL/Expression.hs +557/−246
- src/Language/Embedded/VHDL/Expression/Format.hs +0/−127
- src/Language/Embedded/VHDL/Expression/Represent.hs +143/−0
- src/Language/Embedded/VHDL/Expression/Type.hs +0/−75
- src/Language/Embedded/VHDL/Interface.hs +6/−6
- src/Language/Embedded/VHDL/Monad.hs +350/−172
- src/Language/Embedded/VHDL/Monad/Expression.hs +11/−1
- src/Language/Embedded/VHDL/Monad/Type.hs +75/−0
imperative-edsl-vhdl.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: imperative-edsl-vhdl-version: 0.2.0.1+version: 0.3.2 synopsis: Deep embedding of VHDL programs with code generation. description: Deep embedding of VHDL programs with code generation. license: BSD3@@ -19,11 +19,11 @@ exposed-modules: Language.Embedded.VHDL, Language.Embedded.VHDL.Monad, Language.Embedded.VHDL.Monad.Expression,+ Language.Embedded.VHDL.Monad.Type, Language.Embedded.VHDL.Interface, Language.Embedded.VHDL.Expression, Language.Embedded.VHDL.Expression.Hoist,- Language.Embedded.VHDL.Expression.Format,- Language.Embedded.VHDL.Expression.Type,+ Language.Embedded.VHDL.Expression.Represent, Language.Embedded.VHDL.Command -- other-modules: @@ -42,8 +42,9 @@ bytestring, constraints, containers >=0.1 && <1,+ syntactic >=3.2, operational-alacarte >=0.1.1,- language-vhdl >=0.1.1.0,+ language-vhdl >=0.1.2.3, pretty >=1.0 hs-source-dirs: .,src default-language: Haskell2010
src/Language/Embedded/VHDL.hs view
@@ -2,8 +2,6 @@ ( Mode(..) , module Language.Embedded.VHDL.Interface , module Language.Embedded.VHDL.Expression- , module Language.Embedded.VHDL.Expression.Type- , module Language.Embedded.VHDL.Expression.Format , module Language.Embedded.VHDL.Command ) where @@ -11,6 +9,4 @@ import Language.Embedded.VHDL.Interface import Language.Embedded.VHDL.Expression-import Language.Embedded.VHDL.Expression.Type-import Language.Embedded.VHDL.Expression.Format import Language.Embedded.VHDL.Command
src/Language/Embedded/VHDL/Command.hs view
@@ -7,21 +7,45 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} -module Language.Embedded.VHDL.Command where+module Language.Embedded.VHDL.Command+ ( SequentialCMD+ , ConcurrentCMD+ , HeaderCMD+ , compile + -- sequential statements+ , constantL, variableL, fileL+ , (<==), (==:)+ , iff, switch, when, ifThen++ -- concurrent statements+ , constantG, signalG, variableG, fileG+ , process++ -- header statements+ , constantPort, constantGeneric+ , signalPort, signalGeneric+ , variablePort, variableGeneric+ , filePort, fileGeneric+ , entity+ , architecture+ , library+ , imports+ ) where+ import Language.VHDL (Identifier(..), Label, Expression, Mode(..)) import qualified Language.VHDL as V -import Language.Embedded.VHDL.Monad (VHDLT, VHDL)+import Language.Embedded.VHDL.Monad (VHDLT, VHDL)+import Language.Embedded.VHDL.Monad.Type (Type, Kind) import Language.Embedded.VHDL.Interface-import Language.Embedded.VHDL.Expression.Type (Type, Kind)-import qualified Language.Embedded.VHDL.Monad as M-import qualified Language.Embedded.VHDL.Expression.Type as T+import qualified Language.Embedded.VHDL.Monad as M+import qualified Language.Embedded.VHDL.Monad.Type as T import qualified Language.Embedded.VHDL.Expression.Hoist as H import Control.Arrow (second)-import Control.Monad.Identity-import Control.Monad.Operational.Higher+import Control.Monad.Identity hiding (when)+import Control.Monad.Operational.Higher hiding (when) import Control.Applicative import Data.Typeable import Data.ALaCarte@@ -49,11 +73,21 @@ -------------------------------------------------------------------------------- -- | Compile if 'exp' is set-compEM :: CompileExp exp => Maybe (exp a) -> VHDL (Maybe Expression)+compEM+ :: forall exp a.+ ( PredicateExp exp a+ , CompileExp exp)+ => Maybe (exp a)+ -> VHDL (Maybe Expression) compEM = maybe (return Nothing) (>>= return . Just) . fmap compE -- | Compile hidden type-compTM :: forall exp a. (PredicateExp exp a, CompileExp exp) => Maybe (exp a) -> VHDL Type+compTM+ :: forall exp a.+ ( PredicateExp exp a+ , CompileExp exp)+ => Maybe (exp a)+ -> VHDL Type compTM _ = compT (undefined :: exp a) --------------------------------------------------------------------------------@@ -63,10 +97,9 @@ where Local :: PredicateExp exp a- => Identifier- -> Kind+ => Kind -> Maybe (exp a)- -> SequentialCMD exp prog ()+ -> SequentialCMD exp prog Identifier Assignment :: PredicateExp exp a@@ -76,8 +109,9 @@ -> SequentialCMD exp prog () If- :: (exp Bool, prog ()) -- if- -> [(exp Bool, prog ())] -- elseif*+ :: PredicateExp exp Bool+ => (exp Bool, prog ()) -- if+ -> [(exp Bool, prog ())] -- else-ifs -> prog () -- else -> SequentialCMD exp prog () @@ -90,7 +124,7 @@ instance HFunctor (SequentialCMD exp) where- hfmap _ (Local i k e) = Local i k e+ hfmap _ (Local k e ) = Local k e hfmap _ (Assignment i k e) = Assignment i k e hfmap f (If (b, t) os e) = If (b, f t) (map (second f) os) (f e) hfmap f (Case e cs d) = Case e (map (second f) cs) (fmap f d)@@ -103,12 +137,11 @@ -- | Declare local constands/variables/files constantL, variableL, fileL :: (SequentialCMD (IExp instr) :<: instr, PredicateExp (IExp instr) a)- => Identifier- -> Maybe (IExp instr a)- -> ProgramT instr m ()-constantL i = singleE . Local i T.Constant-variableL i = singleE . Local i T.Variable-fileL i = singleE . Local i T.File+ => Maybe (IExp instr a)+ -> ProgramT instr m Identifier+constantL = singleE . Local T.Constant+variableL = singleE . Local T.Variable+fileL = singleE . Local T.File -- | Assign a signal to some expression (<==) :: (SequentialCMD (IExp instr) :<: instr, PredicateExp (IExp instr) a)@@ -125,8 +158,8 @@ (==:) i = singleE . Assignment i T.Variable -- | Conventional if statement-iff- :: (SequentialCMD (IExp instr) :<: instr)+iff + :: (SequentialCMD (IExp instr) :<: instr, PredicateExp (IExp instr) Bool) => (IExp instr Bool, ProgramT instr m ()) -> [(IExp instr Bool, ProgramT instr m ())] -> ProgramT instr m ()@@ -146,7 +179,9 @@ -- | Guards a program by some predicate when- :: (SequentialCMD (IExp instr) :<: instr, Monad m)+ :: ( SequentialCMD (IExp instr) :<: instr+ , PredicateExp (IExp instr) Bool+ , Monad m) => IExp instr Bool -> ProgramT instr m () -> ProgramT instr m ()@@ -154,23 +189,26 @@ -- | Standard 'if .. then .. else ..' statement ifThen- :: (SequentialCMD (IExp instr) :<: instr)+ :: ( SequentialCMD (IExp instr) :<: instr+ , PredicateExp (IExp instr) Bool) => IExp instr Bool -> ProgramT instr m () -> ProgramT instr m () -> ProgramT instr m () ifThen b th el = singleE $ If (b, th) [] el- + -------------------------------------------------------------------------------- compileSequential :: CompileExp exp => SequentialCMD exp VHDL a -> VHDL a-compileSequential (Local i k e) =+compileSequential (Local k e) = do v <- compEM e t <- compTM e+ i <- M.newSym M.addLocal $ case k of T.Constant -> M.declConstant i t v T.Signal -> M.declSignal i t v T.Variable -> M.declVariable i t v+ return i compileSequential (Assignment i k e) = do v <- compE e M.addSequential $ case k of@@ -217,10 +255,9 @@ where Global :: PredicateExp exp a - => Identifier- -> Kind+ => Kind -> Maybe (exp a)- -> ConcurrentCMD exp prog ()+ -> ConcurrentCMD exp prog (Identifier) Process :: Label@@ -229,15 +266,13 @@ -> ConcurrentCMD exp prog () PortMap- :: Identifier- -> [Identifier]- -> ConcurrentCMD exp prog ()+ :: [Identifier] -> ConcurrentCMD exp prog (Identifier) instance HFunctor (ConcurrentCMD exp) where- hfmap _ (Global i k e) = Global i k e+ hfmap _ (Global k e) = Global k e hfmap f (Process l is p) = Process l is (f p)- hfmap _ (PortMap n is) = PortMap n is+ hfmap _ (PortMap is) = PortMap is type instance IExp (ConcurrentCMD e) = e type instance IExp (ConcurrentCMD e :+: i) = e@@ -245,15 +280,15 @@ -------------------------------------------------------------------------------- -- | Declare global constands/variables/files-constantG, signalG, variableG, fileG - :: (ConcurrentCMD (IExp instr) :<: instr, PredicateExp (IExp instr) a)- => Identifier- -> Maybe (IExp instr a)- -> ProgramT instr m ()-constantG i = singleE . Global i T.Constant-signalG i = singleE . Global i T.Signal-variableG i = singleE . Global i T.Variable-fileG i = singleE . Global i T.File+constantG, signalG, variableG, fileG+ :: ( ConcurrentCMD (IExp instr) :<: instr+ , PredicateExp (IExp instr) a)+ => Maybe (IExp instr a)+ -> ProgramT instr m Identifier+constantG = singleE . Global T.Constant+signalG = singleE . Global T.Signal+variableG = singleE . Global T.Variable+fileG = singleE . Global T.File -- | Declare a process process@@ -267,121 +302,153 @@ -------------------------------------------------------------------------------- compileConcurrent :: CompileExp exp => ConcurrentCMD exp VHDL a -> VHDL a-compileConcurrent (Global i k e) =+compileConcurrent (Global k e) = do v <- compEM e t <- compTM e+ i <- M.newSym M.addGlobal $ case k of T.Constant -> M.declConstant i t v T.Signal -> M.declSignal i t v T.Variable -> M.declVariable i t v+ return i compileConcurrent (Process l is p) = do (a, process) <- M.inProcess l is p M.addConcurrent (V.ConProcess process) return a-compileConcurrent (PortMap n is) =+compileConcurrent (PortMap is) = do let ads = fmap (V.ADSignal . V.NSimple) is+ n <- M.newSym lbl <- M.newLabel M.addConcurrent (M.portMap lbl n ads)+ return n -------------------------------------------------------------------------------- -- ** Entity declaration related commands offered by VHDL data DeclKind = Port | Generic +data Record a = Record Identifier++data Array a = Array Identifier+ data HeaderCMD exp (prog :: * -> *) a where- Declare+ DeclarePort :: PredicateExp exp a => DeclKind- -> Identifier -> Kind -> Mode -> Maybe (exp a) -> HeaderCMD exp prog Identifier+ + DeclareRecord+ :: [(Identifier, Type)]+ -> HeaderCMD exp prog (Record a)+ + DeclareArray+ :: HeaderCMD exp prog (Array a) - Architecture- :: String+ -- ^ ...+ Entity+ :: Identifier -> prog a -> HeaderCMD exp prog a - Record- :: String- -> [(String, Type)]+ -- ^ ...+ Architecture+ :: Identifier -- architecture's name+ -> Identifier -- entity's name+ -> prog a -> HeaderCMD exp prog a + Library :: String -> HeaderCMD exp prog ()+ Import :: String -> HeaderCMD exp prog ()+ instance HFunctor (HeaderCMD exp) where- hfmap _ (Declare d i k m e) = Declare d i k m e- hfmap f (Architecture s p) = Architecture s (f p)- hfmap _ (Record s es) = Record s es+ hfmap _ (DeclarePort d k m e) = DeclarePort d k m e+ hfmap _ (DeclareRecord rs) = DeclareRecord rs+ hfmap _ (DeclareArray) = DeclareArray+ hfmap f (Entity e p) = Entity e (f p)+ hfmap f (Architecture a e p) = Architecture a e (f p)+ hfmap _ (Library s) = Library s+ hfmap _ (Import s) = Import s type instance IExp (HeaderCMD e) = e type instance IExp (HeaderCMD e :+: i) = e -------------------------------------------------------------------------------- --- | Declare constands/signal/variables/files ports and generics+-- | Declare constands/signal/variables/files ports and generics. constantPort, constantGeneric, signalPort, signalGeneric, variablePort, variableGeneric, filePort, fileGeneric :: (HeaderCMD (IExp instr) :<: instr, PredicateExp (IExp instr) a)- => Identifier- -> Mode+ => Mode -> Maybe (IExp instr a) -> ProgramT instr m Identifier-constantPort i m = singleE . Declare Port i T.Constant m-constantGeneric i m = singleE . Declare Generic i T.Constant m-signalPort i m = singleE . Declare Port i T.Signal m-signalGeneric i m = singleE . Declare Generic i T.Signal m-variablePort i m = singleE . Declare Port i T.Variable m-variableGeneric i m = singleE . Declare Generic i T.Variable m-filePort i m = singleE . Declare Port i T.File m-fileGeneric i m = singleE . Declare Generic i T.File m---- | Declares a clock input port-clock- :: forall instr m.- ( HeaderCMD (IExp instr) :<: instr- , PredicateExp (IExp instr) Bool)- => ProgramT instr m Identifier-clock = signalPort (Ident "clk") In (Nothing :: Maybe ((IExp instr) Bool))+constantPort m = singleE . DeclarePort Port T.Constant m+constantGeneric m = singleE . DeclarePort Generic T.Constant m+signalPort m = singleE . DeclarePort Port T.Signal m+signalGeneric m = singleE . DeclarePort Generic T.Signal m+variablePort m = singleE . DeclarePort Port T.Variable m+variableGeneric m = singleE . DeclarePort Generic T.Variable m+filePort m = singleE . DeclarePort Port T.File m+fileGeneric m = singleE . DeclarePort Generic T.File m --- | Declares a reset input port-reset- :: forall instr m.- ( HeaderCMD (IExp instr) :<: instr- , PredicateExp (IExp instr) Bool)- => ProgramT instr m Identifier-reset = signalPort (Ident "reset") In (Nothing :: Maybe ((IExp instr) Bool))+-- | Declare an entity.+entity+ :: (HeaderCMD (IExp instr) :<: instr)+ => String+ -> ProgramT instr m a+ -> ProgramT instr m a+entity name = singleE . Entity (Ident name) --- | Declare an architecture+-- | Declare an architecture. architecture :: (HeaderCMD (IExp instr) :<: instr) => String+ -> String -> ProgramT instr m a -> ProgramT instr m a-architecture name = singleE . Architecture name+architecture name entity = singleE . Architecture (Ident name) (Ident entity) +-- | Imports a library.+library :: (HeaderCMD (IExp instr) :<: instr) => String -> ProgramT instr m ()+library = singleE . Library++-- | Imports a library module.+imports :: (HeaderCMD (IExp instr) :<: instr) => String -> ProgramT instr m ()+imports = singleE . Import+ -------------------------------------------------------------------------------- compileHeader :: CompileExp exp => HeaderCMD exp VHDL a -> VHDL a-compileHeader (Declare Port i k m e) =+compileHeader (DeclarePort Port k m e) = do v <- compEM e t <- compTM e+ i <- M.newSym M.addPort $ case k of T.Constant -> M.interfaceConstant i t v T.Signal -> M.interfaceSignal i m t v T.Variable -> M.interfaceVariable i m t v return i-compileHeader (Declare Generic i k m e) =+compileHeader (DeclarePort Generic k m e) = do v <- compEM e t <- compTM e+ i <- M.newSym M.addGeneric $ case k of T.Constant -> M.interfaceConstant i t v T.Signal -> M.interfaceSignal i m t v T.Variable -> M.interfaceVariable i m t v return i-compileHeader (Architecture name prg) =- do M.inArchitecture name prg-compileHeader (Record name es) =- do undefined+compileHeader (DeclareRecord rs) =+ do i <- M.newSym+ r <- return $ M.declRecord i rs+ undefined+compileHeader (DeclareArray) =+ do error "imperative-vhdl: arrays are not yet supported."+compileHeader (Entity name prg) = M.entity name prg+compileHeader (Architecture name entity prg) = M.architecture name entity prg+compileHeader (Library s) = M.newLibrary s+compileHeader (Import s) = M.newImport s --------------------------------------------------------------------------------
src/Language/Embedded/VHDL/Expression.hs view
@@ -1,11 +1,18 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables #-} module Language.Embedded.VHDL.Expression- ( Expr+ ( VHDLDomain+ , Data+ , Type++ -- expressions , not, and, or, xor, xnor, nand, nor , eq, neq , lt, lte, gt, gte@@ -13,344 +20,648 @@ , add, sub, cat , mul , div, mod, rem- , neg , exp, abs- , name, lit+ , value, force, share++ -- types+ , std_logic+ , signed, usigned+ , signed8, signed16, signed32, signed64+ , usigned8, usigned16, usigned32, usigned64 ) where -import Language.VHDL (Identifier(..), Expression)+import Language.VHDL (Identifier(..))+import qualified Language.VHDL as V import Language.Embedded.VHDL.Interface-import Language.Embedded.VHDL.Monad (VHDL)+import Language.Embedded.VHDL.Monad (VHDL) import Language.Embedded.VHDL.Expression.Hoist-import Language.Embedded.VHDL.Expression.Format-import Language.Embedded.VHDL.Expression.Type hiding (Kind)-import qualified Language.Embedded.VHDL.Monad as M+import Language.Embedded.VHDL.Expression.Represent+import qualified Language.Embedded.VHDL.Monad as M+import qualified Language.Embedded.VHDL.Expression.Hoist as Hoist -import Data.Bits hiding (xor)-import Data.Dynamic-import Data.Maybe (fromJust)-import Data.Typeable+import Language.Embedded.VHDL.Monad.Type (+ std_logic+ , signed, usigned+ , signed8, signed16, signed32, signed64+ , usigned8, usigned16, usigned32, usigned64+ )+import qualified Language.Embedded.VHDL.Monad.Type as T -import Prelude hiding (not, and, or, div, mod, rem, exp, abs, null)-import qualified Prelude as P+import Language.Syntactic hiding (fold, printExpr, showAST, drawAST, writeHtmlAST)+import Language.Syntactic.Functional+import Language.Syntactic.Functional.Sharing+import Language.Syntactic.Functional.Tuple+import Language.Syntactic.Sugar.BindingTyped ()+import Language.Syntactic.Sugar.TupleTyped ()+import qualified Language.Syntactic as Syntactic +import Control.Arrow+import Control.Applicative (liftA)++import Data.Bits (Bits)+import Data.Maybe (fromJust)+import Data.Typeable (Typeable)+import Data.Word (Word8)+import qualified Data.Bits as Bits++import Prelude hiding (not, and, or, abs, rem, div, mod, exp)+import qualified Prelude+ ----------------------------------------------------------------------------------- * VHDL Expression Type - a union of VHDLs' types + variables+-- * ... -------------------------------------------------------------------------------- -data Expr a+class (Typeable a, Rep a, Eq a) => Type a+instance (Typeable a, Rep a, Eq a) => Type a++--------------------------------------------------------------------------------+-- ** ...++data Expression sig where- -- ^ ...- Val :: Rep a => a -> Expr a- Var :: Rep a => Identifier -> Expr a+ And :: Expression (Bool :-> Bool :-> Full Bool)+ Or :: Expression (Bool :-> Bool :-> Full Bool)+ Xor :: Expression (Bool :-> Bool :-> Full Bool)+ Xnor :: Expression (Bool :-> Bool :-> Full Bool)+ Nand :: Expression (Bool :-> Bool :-> Full Bool)+ Nor :: Expression (Bool :-> Bool :-> Full Bool) - -- ^ ...- Pair :: Expr a -> Expr b -> Expr (a, b)- Fst :: Expr (a, b) -> Expr a- Snd :: Expr (a, b) -> Expr b+instance Equality Expression+instance StringTree Expression - -- ^ VHDL Expressions- - -- expression operators (plus Not)- Not :: Expr Bool -> Expr Bool- And :: Expr Bool -> Expr Bool -> Expr Bool- Or :: Expr Bool -> Expr Bool -> Expr Bool- Xor :: Expr Bool -> Expr Bool -> Expr Bool- Xnor :: Expr Bool -> Expr Bool -> Expr Bool- Nand :: Expr Bool -> Expr Bool -> Expr Bool- Nor :: Expr Bool -> Expr Bool -> Expr Bool+instance Symbol Expression+ where+ symSig And = signature+ symSig Or = signature+ symSig Xor = signature+ symSig Xnor = signature+ symSig Nand = signature+ symSig Nor = signature - -- relational operators- Eq :: Eq a => Expr a -> Expr a -> Expr Bool- Neq :: Eq a => Expr a -> Expr a -> Expr Bool- Lt :: Ord a => Expr a -> Expr a -> Expr Bool- Lte :: Ord a => Expr a -> Expr a -> Expr Bool- Gt :: Ord a => Expr a -> Expr a -> Expr Bool- Gte :: Ord a => Expr a -> Expr a -> Expr Bool+instance Render Expression+ where+ renderSym And = "and"+ renderSym Or = "or"+ renderSym Xor = "xor"+ renderSym Xnor = "xnor"+ renderSym Nand = "nand"+ renderSym Nor = "nor" - -- shift operators- Sll :: (Bits a, Integral b) => Expr a -> Expr b -> Expr a- Srl :: (Bits a, Integral b) => Expr a -> Expr b -> Expr a- Sla :: (Bits a, Integral b) => Expr a -> Expr b -> Expr a- Sra :: (Bits a, Integral b) => Expr a -> Expr b -> Expr a- Rol :: (Bits a, Integral b) => Expr a -> Expr b -> Expr a- Ror :: (Bits a, Integral b) => Expr a -> Expr b -> Expr a+instance Eval Expression+ where+ evalSym And = (&&)+ evalSym Or = (||)+ evalSym Xor = \x y -> (x && Prelude.not y) || (Prelude.not x && y)+ evalSym Xnor = \x y -> (Prelude.not x && Prelude.not y) || (x && y)+ evalSym Nand = \x y -> Prelude.not (x && y)+ evalSym Nor = \x y -> Prelude.not (x || y) - -- adding operators- Neg :: Num a => Expr a -> Expr a- Add :: Num a => Expr a -> Expr a -> Expr a- Sub :: Num a => Expr a -> Expr a -> Expr a- Cat :: Num a => Expr a -> Expr a -> Expr a+instance EvalEnv Expression env - -- multiplying operators- Mul :: (Rep a, Num a) => Expr a -> Expr a -> Expr a- Dif :: Fractional a => Expr a -> Expr a -> Expr a -- floating point division- Div :: Integral a => Expr a -> Expr a -> Expr a -- integer division- Mod :: Integral a => Expr a -> Expr a -> Expr a- Rem :: Integral a => Expr a -> Expr a -> Expr a+--------------------------------------------------------------------------------+-- ** ... - -- misc. operators (minus Not)- Exp :: Floating a => Expr a -> Expr a -> Expr a- Abs :: Num a => Expr a -> Expr a+data Relational sig+ where+ Eq :: Type a => Relational (a :-> a :-> Full Bool)+ Neq :: Type a => Relational (a :-> a :-> Full Bool)+ Lt :: (Type a, Ord a) => Relational (a :-> a :-> Full Bool)+ Lte :: (Type a, Ord a) => Relational (a :-> a :-> Full Bool)+ Gt :: (Type a, Ord a) => Relational (a :-> a :-> Full Bool)+ Gte :: (Type a, Ord a) => Relational (a :-> a :-> Full Bool) -type instance PredicateExp Expr = Rep+instance Equality Relational+instance StringTree Relational +instance Symbol Relational+ where+ symSig Eq = signature+ symSig Neq = signature+ symSig Lt = signature+ symSig Lte = signature+ symSig Gt = signature+ symSig Gte = signature++instance Render Relational+ where+ renderSym Eq = "(==)"+ renderSym Neq = "(/=)"+ renderSym Lt = "(<)"+ renderSym Lte = "(<=)"+ renderSym Gt = "(>)"+ renderSym Gte = "(>=)"++instance Eval Relational+ where+ evalSym Eq = (==)+ evalSym Neq = (/=)+ evalSym Lt = (<)+ evalSym Lte = (<=)+ evalSym Gt = (>)+ evalSym Gte = (>=)++instance EvalEnv Relational env+ ----------------------------------------------------------------------------------- ** Sugared constructs+-- ** ... -class Rep (Internal a) => Syntactic a+data Shift sig where- type Internal a+ Sll :: (Type a, Bits a, Type b, Integral b) => Shift (a :-> b :-> Full a)+ Srl :: (Type a, Bits a, Type b, Integral b) => Shift (a :-> b :-> Full a)+ Sla :: (Type a, Bits a, Type b, Integral b) => Shift (a :-> b :-> Full a)+ Sra :: (Type a, Bits a, Type b, Integral b) => Shift (a :-> b :-> Full a)+ Rol :: (Type a, Bits a, Type b, Integral b) => Shift (a :-> b :-> Full a)+ Ror :: (Type a, Bits a, Type b, Integral b) => Shift (a :-> b :-> Full a) - sugar :: a -> Expr (Internal a)- desugar :: Expr (Internal a) -> a+instance Equality Shift+instance StringTree Shift -instance Rep a => Syntactic (Expr a)+instance Symbol Shift where- type Internal (Expr a) = a+ symSig Sll = signature+ symSig Srl = signature+ symSig Sla = signature+ symSig Sra = signature+ symSig Rol = signature+ symSig Ror = signature - sugar = id- desugar = id+instance Render Shift+ where+ renderSym Sll = "sll"+ renderSym Srl = "srl"+ renderSym Sla = "sla"+ renderSym Sra = "sra"+ renderSym Rol = "rol"+ renderSym Ror = "ror" -instance (Syntactic a, Syntactic b) => Syntactic (a, b)+instance Eval Shift where- type Internal (a, b) = (Internal a, Internal b)+ evalSym Sll = \x i -> Bits.shiftL x (fromIntegral i)+ evalSym Srl = \x i -> shiftLR x (fromIntegral i)+ 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) - sugar (a, b) = Pair (sugar a) (sugar b)- desugar p = (desugar (Fst p), desugar (Snd p))+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]+ Nothing -> y --- ...+instance EvalEnv Shift env ----------------------------------------------------------------------------------- ** Useful Expr Instances+-- ** ... -instance (Rep a, Bounded a) => Bounded (Expr a)+data Simple sig where- minBound = Val minBound- maxBound = Val maxBound+ Neg :: (Type a, Num a) => Simple (a :-> Full a)+ Pos :: (Type a, Num a) => Simple (a :-> Full a)+ Add :: (Type a, Num a) => Simple (a :-> a :-> Full a)+ Sub :: (Type a, Num a) => Simple (a :-> a :-> Full a)+ Cat :: (Type a, Show a, Read a) => Simple (a :-> a :-> Full a) -instance (Rep a, Enum a) => Enum (Expr a) -- needed for integral+instance Equality Simple+instance StringTree Simple++instance Symbol Simple where- toEnum = error "toEnum not supported"- fromEnum = error "fromEnum not supported"+ symSig Neg = signature+ symSig Pos = signature+ symSig Add = signature+ symSig Sub = signature+ symSig Cat = signature -instance (Rep a, Num a) => Num (Expr a)+instance Render Simple where- fromInteger = Val . fromInteger- (+) = Add- (-) = Sub- (*) = Mul- abs = Abs- signum = error "signum not implemented for Expr"+ renderSym Neg = "(-)"+ renderSym Pos = "id"+ renderSym Add = "(+)"+ renderSym Sub = "(-)"+ renderSym Cat = "(&)" ------------------------------------------------------------------------------------ * User interface---------------------------------------------------------------------------------+instance Eval Simple+ where+ evalSym Neg = negate+ evalSym Pos = id+ evalSym Add = (+)+ evalSym Sub = (-)+ evalSym Cat = \x y -> read (show x ++ show y) +instance EvalEnv Simple env+ ----------------------------------------------------------------------------------- ** Logical operators+-- ** ... -and, or, xor, xnor, nand, nor :: Expr Bool -> Expr Bool -> Expr Bool+data Term sig+ where+ Mul :: (Type a, Num a) => Term (a :-> a :-> Full a)+ Div :: (Type a, Integral a) => Term (a :-> a :-> Full a)+ Mod :: (Type a, Integral a) => Term (a :-> a :-> Full a)+ Rem :: (Type a, Integral a) => Term (a :-> a :-> Full a) -and = And-or = Or-xor = Xor-xnor = Xnor-nand = Nand-nor = Nor+instance Equality Term+instance StringTree Term ------------------------------------------------------------------------------------ ** Relational operators+instance Symbol Term+ where+ symSig Mul = signature+ symSig Div = signature+ symSig Mod = signature+ symSig Rem = signature -eq, neq :: Eq a => Expr a -> Expr a -> Expr Bool-lt, lte, gt, gte :: Ord a => Expr a -> Expr a -> Expr Bool+instance Render Term+ where+ renderSym Mul = "(*)"+ renderSym Div = "(/)"+ renderSym Mod = "(%)"+ renderSym Rem = "rem" -eq = Eq-neq = Neq-lt = Lt-lte = Lte-gt = Gt-gte = Gte+instance Eval Term+ where+ evalSym Mul = (*)+ evalSym Div = Prelude.div+ evalSym Mod = Prelude.mod+ evalSym Rem = Prelude.rem +instance EvalEnv Term env+ ----------------------------------------------------------------------------------- ** Shift operators+-- ** ... -sll, srl, sra, sla, rol, ror :: (Bits a, Integral b) => Expr a -> Expr b -> Expr a+data Factor sig+ where+ Exp :: (Type a, Num a, Type b, Integral b) => Factor (a :-> b :-> Full a)+ Abs :: (Type a, Num a) => Factor (a :-> Full a)+ Not :: Factor (Bool :-> Full Bool) -sll = Sll-srl = Srl-sra = Sra-sla = Sla-rol = Rol-ror = Ror+instance Equality Factor+instance StringTree Factor ------------------------------------------------------------------------------------ ** Adding operators+instance Symbol Factor+ where+ symSig Exp = signature+ symSig Abs = signature+ symSig Not = signature -add, sub, cat :: Num a => Expr a -> Expr a -> Expr a+instance Render Factor+ where+ renderSym Exp = "(**)"+ renderSym Abs = "abs"+ renderSym Not = "not" -add = Add-sub = Sub-cat = Cat+instance Eval Factor+ where+ evalSym Exp = (^)+ evalSym Abs = Prelude.abs+ evalSym Not = Prelude.not +instance EvalEnv Factor env+ ----------------------------------------------------------------------------------- ** Multiplying operators+-- ** ... -mul :: (Num a, Rep a) => Expr a -> Expr a -> Expr a-div, mod, rem :: Integral a => Expr a -> Expr a -> Expr a+data Primary sig+ where+ Lit :: Type a => a -> Primary (Full a) -mod = Mod-rem = Rem-mul = Mul-div = Div+instance Equality Primary+instance StringTree Primary ------------------------------------------------------------------------------------ ** Sign operators+instance Symbol Primary+ where+ symSig (Lit _) = signature -neg :: Num a => Expr a -> Expr a-neg = Neg+instance Render Primary+ where+ renderSym (Lit _) = "lit" +instance Eval Primary+ where+ evalSym (Lit i) = i++instance EvalEnv Primary env+ ----------------------------------------------------------------------------------- ** Miscellaneous operators -not :: Expr Bool -> Expr Bool-not = Not+type VHDLDomain = Typed Dom -exp :: Floating a => Expr a -> Expr a -> Expr a-exp = Exp+type Dom = + -- Syntactic+ BindingT+ :+: Let+ :+: Tuple+ :+: Construct+ -- VHDL constructs+ :+: Expression+ :+: Relational+ :+: Shift+ :+: Simple+ :+: Term+ :+: Factor+ :+: Primary -abs :: Num a => Expr a -> Expr a-abs = Abs+newtype Data a = Data { unData :: ASTF VHDLDomain a } ------------------------------------------------------------------------------------ ** Naming operators+instance Type a => Syntactic (Data a)+ where+ type Domain (Data a) = VHDLDomain+ type Internal (Data a) = a -name :: Rep a => Identifier -> Expr a-name = Var+ desugar = unData+ sugar = Data -lit :: Rep a => a -> Expr a-lit = Val+class (Syntactic a, Domain a ~ VHDLDomain, Type (Internal a)) => Syntax a+instance (Syntactic a, Domain a ~ VHDLDomain, Type (Internal a)) => Syntax a +type instance PredicateExp Data = Type+ ----------------------------------------------------------------------------------- * Compilation of expressions+-- * Backend -------------------------------------------------------------------------------- -instance CompileExp Expr+codeMotionInterface :: CodeMotionInterface VHDLDomain+codeMotionInterface = defaultInterface VarT LamT sharable (const True) where- varE = Var- compT = compileT- compE = compileE+ sharable :: ASTF VHDLDomain a -> ASTF VHDLDomain b -> Bool+ sharable (Sym _) _ = False+ sharable (lam :$ _) _+ | Just _ <- prLam lam = False+ sharable _ (lam :$ _)+ | Just _ <- prLam lam = False+ sharable (sel :$ _) _+ | Just Sel1 <- prj sel = False+ | Just Sel2 <- prj sel = False+ | Just Sel3 <- prj sel = False+ | Just Sel4 <- prj sel = False+ sharable _ _ = True -compileT :: forall a. Rep a => Expr a -> VHDL Type-compileT _ = return $ unTag $ (typed :: Tagged a Type)+showExpr :: (Syntactic a, Domain a ~ VHDLDomain) => a -> String+showExpr = render . codeMotion codeMotionInterface . desugar -compileE :: Expr a -> VHDL Expression-compileE = return . lift . go- where- go :: forall a. Expr a -> Kind- go exp = case exp of- Var (Ident i) -> P $ M.name i- Val v -> P $ M.string $ format v+showAST :: (Syntactic a, Domain a ~ VHDLDomain) => a -> String+showAST = Syntactic.showAST . codeMotion codeMotionInterface . desugar - And x y -> E $ M.and [lift (go x), lift (go y)]- Or x y -> E $ M.or [lift (go x), lift (go y)]- Xor x y -> E $ M.xor [lift (go x), lift (go y)]- Xnor x y -> E $ M.xnor [lift (go x), lift (go y)]- Nand x y -> E $ M.nand (lift (go x)) (lift (go y))- Nor x y -> E $ M.nor (lift (go x)) (lift (go y))+eval :: (Syntactic a, Domain a ~ VHDLDomain) => a -> Internal a+eval = evalClosed . desugar - Eq x y -> R $ M.eq (lift (go x)) (lift (go y))- Neq x y -> R $ M.neq (lift (go x)) (lift (go y))- Lt x y -> R $ M.lt (lift (go x)) (lift (go y))- Lte x y -> R $ M.lte (lift (go x)) (lift (go y))- Gt x y -> R $ M.gt (lift (go x)) (lift (go y))- Gte x y -> R $ M.gte (lift (go x)) (lift (go y))+--------------------------------------------------------------------------------+-- * Frontend+-------------------------------------------------------------------------------- - Sll x y -> Sh $ M.sll (lift (go x)) (lift (go y))- Srl x y -> Sh $ M.srl (lift (go x)) (lift (go y))- Sla x y -> Sh $ M.sla (lift (go x)) (lift (go y))- Sra x y -> Sh $ M.sra (lift (go x)) (lift (go y))- Rol x y -> Sh $ M.rol (lift (go x)) (lift (go y))- Ror x y -> Sh $ M.ror (lift (go x)) (lift (go y))+value :: Syntax a => Internal a -> a+value = sugar . injT . Lit - Neg x -> Si $ M.neg (lift (go x))- Add x y -> Si $ M.add [lift (go x), lift (go y)]- Sub x y -> Si $ M.sub [lift (go x), lift (go y)]- Cat x y -> Si $ M.cat [lift (go x), lift (go y)]+force :: Syntax a => a -> a+force = resugar - Mul x y -> P $ resize (unTag (width :: Tagged a Int))- $ M.mul [lift (go x), lift (go y)]- Div x y -> T $ M.div [lift (go x), lift (go y)]- Mod x y -> T $ M.mod [lift (go x), lift (go y)]- Rem x y -> T $ M.rem [lift (go x), lift (go y)]+share :: (Syntax a, Syntax b) => a -> (a -> b) -> b+share = sugarSymTyped Let - Exp x y -> F $ M.exp (lift (go x)) (lift (go y))- Abs x -> F $ M.abs (lift (go x))- Not x -> F $ M.not (lift (go x))+--------------------------------------------------------------------------------+-- ** ... - -- todo ...- Dif x y -> error "compilation of floating point division is not yet supported"+-- logical operators+and, or, xor, xnor, nand, nor :: Data Bool -> Data Bool -> Data Bool+and = sugarSymTyped And+or = sugarSymTyped Or+xor = sugarSymTyped Xor+xnor = sugarSymTyped Xnor+nand = sugarSymTyped Nand+nor = sugarSymTyped Nor +-- relational operators+eq, neq :: (Type a, Eq a) => Data a -> Data a -> Data Bool+eq = sugarSymTyped Eq+neq = sugarSymTyped Neq++lt, lte, gt, gte :: (Type a, Ord a) => Data a -> Data a -> Data Bool+lt = sugarSymTyped Lt+lte = sugarSymTyped Lte+gt = sugarSymTyped Gt+gte = sugarSymTyped Gte++-- shift operators+sll, srl, sla, sra, rol, ror :: (Type a, Bits a, Type b, Integral b) => Data a -> Data b -> Data a+sll = sugarSymTyped Sll+srl = sugarSymTyped Srl+sla = sugarSymTyped Sla+sra = sugarSymTyped Sra+rol = sugarSymTyped Rol+ror = sugarSymTyped Ror++-- adding operators+add, sub :: (Type a, Num a) => Data a -> Data a -> Data a+add = sugarSymTyped Add+sub = sugarSymTyped Sub++cat :: (Type a, Read a, Show a) => Data a -> Data a -> Data a+cat = sugarSymTyped Cat++-- multiplying operators+mul :: (Type a, Num a) => Data a -> Data a -> Data a+mul = sugarSymTyped Mul++div, mod, rem :: (Type a, Integral a) => Data a -> Data a -> Data a+div = sugarSymTyped Div+mod = sugarSymTyped Mod+rem = sugarSymTyped Rem++-- miscellaneous operators+exp :: (Type a, Num a, Type b, Integral b) => Data a -> Data b -> Data a+exp = sugarSymTyped Exp++abs :: (Type a, Num a) => Data a -> Data a+abs = sugarSymTyped Abs++not :: Data Bool -> Data Bool+not = sugarSymTyped Not+ --------------------------------------------------------------------------------+-- ** ...++instance (Type a, Eq a) => Eq (Data a)+ where+ (==) = error "VHDL: equality checking is not supported"++instance (Type a, Ord a) => Ord (Data a)+ where+ compare = error "VHDL: compare is not supported"+ max = error "VHDL: max is not supported"+ min = error "VHDL: min is not supported"++instance (Type a, Bounded a) => Bounded (Data a)+ where+ minBound = value minBound+ maxBound = value maxBound++instance (Type a, Enum a) => Enum (Data a)+ where+ toEnum = error "VHDL: toEnum is not supported"+ fromEnum = error "VHDL: fromEnum is not supported"++instance (Type a, Real a) => Real (Data a)+ where+ toRational = error "VHDL: toRational is not supported"++instance (Type a, Num a) => Num (Data a)+ where+ fromInteger = value . fromInteger+ (+) = add+ (-) = sub+ (*) = mul+ abs = abs+ signum = error "VHDL: signum is not supported"++instance (Type a, Integral a) => Integral (Data a)+ where+ quot = error "VHDL: quotient is not supported"+ rem = rem+ div = div+ mod = mod+ quotRem a b = (quot a b, rem a b)+ divMod a b = (div a b, mod a b)+ toInteger = error "VHDL: toInteger is not supported"++instance (Type a, Fractional a) => Fractional (Data a)+ where+ (/) = error "VHDL: floating point division is not _yet_ supported"+ recip = (/) (value 1)+ fromRational = error "VHDL: fromRational is not supported"+ +-------------------------------------------------------------------------------- -- * Evaluation of Expressions -------------------------------------------------------------------------------- -instance EvaluateExp Expr+instance EvaluateExp Data where- litE = Val- evalE = evaluate+ litE = value+ evalE = eval -evaluate :: Expr a -> a-evaluate exp = case exp of- Var v -> error "eval: free variable"- Val v -> v- - Not x -> un P.not x- And x y -> bin (&&) x y- Or x y -> bin (||) x y- Xor x y -> bin xor x y- Xnor x y -> P.not $ bin xor x y- Nand x y -> P.not $ bin (&&) x y- Nor x y -> P.not $ bin (||) x y+--------------------------------------------------------------------------------+-- * Compilation of expressions+-------------------------------------------------------------------------------- - Eq x y -> bin (==) x y- Neq x y -> bin (/=) x y- Lt x y -> bin (<) x y- Lte x y -> bin (<=) x y- Gt x y -> bin (>) x y- Gte x y -> bin (>=) x y+instance CompileExp Data+ where+ varE i = sugarSymTyped ((VarT (Name i)))+ + compT = compileT - Sll x y -> bin (\a b -> shiftL a (fromIntegral b) `clearBit` msb a) x y- Srl x y -> bin (\a b -> shiftR a (fromIntegral b) `clearBit` msb a) x y - Sla x y -> bin (\a -> shiftL a . fromIntegral) x y- Sra x y -> bin (\a -> shiftR a . fromIntegral) x y- Rol x y -> bin (\a -> rotateL a . fromIntegral) x y- Ror x y -> bin (\a -> rotateR a . fromIntegral) x y+ compE = liftA lift+ . compileE+ . mapAST (\(Typed s) -> s)+ . codeMotion codeMotionInterface+ . desugar - Neg x -> un negate x- Add x y -> bin (+) x y- Sub x y -> bin (-) x y- Cat x y -> error "evaluation of bit concatenation not yet implemented" +--------------------------------------------------------------------------------+-- ** ... - Mul x y -> bin (*) x y- Dif x y -> bin (/) x y- Div x y -> bin P.div x y- Mod x y -> bin P.mod x y- Rem x y -> bin P.rem x y+compileT :: forall a. Rep a => Data a -> VHDL T.Type+compileT _ =+ do let t = unTag (typed :: Tagged a T.Type)+ declare (undefined :: a)+ return t - Exp x y -> bin (**) x y- Abs x -> un P.abs x+compileE :: ASTF Dom a -> VHDL Kind+compileE var+ | Just (Var v) <- prj var = return $ P $ M.name $ vars v+ | Just (VarT v) <- prj var = return $ P $ M.name $ vars v+compileE val+ | Just (Lit v) <- prj val = return $ P $ M.string $ format v+compileE (lets :$ a :$ (lam :$ body))+ | Just (Let) <- prj lets+ , Just (LamT v) <- prj lam+ = do let v' = Ident $ vars v+ a' <- lift <$> compileE a+ M.addSequential $ M.assignVariable v' a'+ compileE body+ -- that we pick variable assignment might be a problem+compileE (expr :$ x :$ y)+ | Just And <- prj expr = go $ \a b -> M.and [a, b]+ | Just Or <- prj expr = go $ \a b -> M.or [a, b]+ | Just Xor <- prj expr = go $ \a b -> M.xor [a, b]+ | Just Xnor <- prj expr = go $ \a b -> M.xnor [a, b]+ | Just Nand <- prj expr = go $ M.nand+ | Just Nor <- prj expr = go $ M.nor where- xor a b = (a || b) && P.not (a && b)- - un :: (a -> b) -> Expr a -> b- un f x = f (evaluate x)+ go :: (V.Relation -> V.Relation -> V.Expression) -> VHDL Kind+ go f = bin (\a b -> Hoist.E $ f (lift a) (lift b)) x y+compileE (relate :$ x :$ y)+ | Just Eq <- prj relate = go $ M.eq+ | Just Neq <- prj relate = go $ M.neq+ | Just Lt <- prj relate = go $ M.lt+ | Just Lte <- prj relate = go $ M.lte+ | Just Gt <- prj relate = go $ M.gt+ | Just Gte <- prj relate = go $ M.gte+ where+ go :: (V.ShiftExpression -> V.ShiftExpression -> V.Relation) -> VHDL Kind+ go f = bin (\a b -> Hoist.R $ f (lift a) (lift b)) x y+compileE (shift :$ x :$ y)+ | Just Sll <- prj shift = go $ M.sll+ | Just Srl <- prj shift = go $ M.srl+ | Just Sla <- prj shift = go $ M.sla+ | Just Sra <- prj shift = go $ M.sra+ | Just Rol <- prj shift = go $ M.rol+ | Just Ror <- prj shift = go $ M.ror+ where+ go :: (V.SimpleExpression -> V.SimpleExpression -> V.ShiftExpression) -> VHDL Kind+ go f = bin (\a b -> Hoist.Sh $ f (lift a) (lift b)) x y+compileE (simple :$ x)+ | Just Neg <- prj simple = go $ M.neg+ | Just Pos <- prj simple = go $ lift+ where+ go :: (V.Term -> V.SimpleExpression) -> VHDL Kind+ go f = un (\a -> Hoist.Si $ f (lift a)) x+compileE (simple :$ x :$ y)+ | Just Add <- prj simple = go $ \a b -> M.add [a, b]+ | Just Sub <- prj simple = go $ \a b -> M.sub [a, b]+ | Just Cat <- prj simple = go $ \a b -> M.cat [a, b]+ where+ go :: (V.Term -> V.Term -> V.SimpleExpression) -> VHDL Kind+ go f = bin (\a b -> Hoist.Si $ f (lift a) (lift b)) x y+compileE (term :$ x :$ y)+ | Just Mul <- prj term = go $ \a b -> M.mul [a, b]+ | Just Div <- prj term = go $ \a b -> M.div [a, b]+ | Just Mod <- prj term = go $ \a b -> M.mod [a, b]+ | Just Rem <- prj term = go $ \a b -> M.rem [a, b]+ where+ go :: (V.Factor -> V.Factor -> V.Term) -> VHDL Kind+ go f = bin (\a b -> Hoist.T $ f (lift a) (lift b)) x y+compileE (factor :$ x :$ y)+ | Just Exp <- prj factor = go $ M.exp+ where+ go :: (V.Primary -> V.Primary -> V.Factor) -> VHDL Kind+ go f = bin (\a b -> Hoist.F $ f (lift a) (lift b)) x y+compileE (factor :$ x)+ | Just Abs <- prj factor = go $ M.abs+ | Just Not <- prj factor = go $ M.not+ where+ go :: (V.Primary -> V.Factor) -> VHDL Kind+ go f = un (\a -> Hoist.F $ f (lift a)) x+compileE (primary)+ | Just (Lit i) <- prj primary = return $ Hoist.P $ M.lit $ format i+compileE x = error $ "imperative-edsl: missing compiler case for " ++ (Syntactic.showAST x) - bin :: (a -> b -> c) -> Expr a -> Expr b -> c- bin f x y = f (evaluate x) (evaluate y)+-------------------------------------------------------------------------------- - msb :: Bits a => a -> Int- msb = fromJust . bitSizeMaybe+-- | ...+vars :: Name -> String+vars v = 'v' : show v++-- | ...+un :: (Kind -> Kind) -> ASTF Dom a -> VHDL Kind+un f x = compileE x >>= return . f++-- | ...+bin :: (Kind -> Kind -> Kind) -> ASTF Dom a -> ASTF Dom b -> VHDL Kind+bin f x y = do+ x' <- compileE x+ y' <- compileE y+ return $ f x' y' --------------------------------------------------------------------------------
− src/Language/Embedded/VHDL/Expression/Format.hs
@@ -1,127 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--module Language.Embedded.VHDL.Expression.Format- ( Tagged(..)- , Rep(..)- ) where--import Language.Embedded.VHDL.Expression.Type--import Data.Bits-import Data.Char (intToDigit)-import Data.Word-import Data.Int-import Text.Printf (printf)-import Numeric (showIntAtBase)-import qualified Data.ByteString as B------------------------------------------------------------------------------------- * Kludge - until I come up with a better solution------------------------------------------------------------------------------------- | Tag a value with some (possibly) interesting information-newtype Tagged s b = Tag { unTag :: b }---- | A 'rep'resentable value.-class Rep a- where- width :: Tagged a Int- typed :: Tagged a Type- format :: a -> String------------------------------------------------------------------------------------- ** Boolean--instance Rep Bool where- width = Tag 1- typed = Tag std_logic- format True = "1"- format False = "0"------------------------------------------------------------------------------------- ** Signed--instance Rep Int8 where- width = Tag 8- typed = Tag signed8- format = convert--instance Rep Int16 where- width = Tag 16- typed = Tag signed16- format = convert--instance Rep Int32 where- width = Tag 32- typed = Tag signed32- format = convert--instance Rep Int64 where- width = Tag 64- typed = Tag signed64- format = convert------------------------------------------------------------------------------------- ** Unsigned--instance Rep Word8 where- width = Tag 8- typed = Tag usigned8- format = convert--instance Rep Word16 where- width = Tag 16- typed = Tag usigned16- format = convert--instance Rep Word32 where- width = Tag 32- typed = Tag usigned32- format = convert--instance Rep Word64 where- width = Tag 64- typed = Tag usigned64- format = convert------------------------------------------------------------------------------------- ** Records--instance (Rep a, Rep b) => Rep (a, b) where- width = Tag (unTag (width :: Tagged a Int) + unTag (width :: Tagged b Int))- typed = undefined- format = undefined---- ...------------------------------------------------------------------------------------- * Converting Integers to their Binrary representation------------------------------------------------------------------------------------- | Convert an Integral to its binary representation-convert :: Integral a => a -> String-convert = foldr1 (++) . fmap w2s . B.unpack . i2bs . toInteger---- | Go over an Integer and convert it into a bytestring containing its--- binary representation-i2bs :: Integer -> B.ByteString-i2bs x = B.reverse . B.unfoldr (fmap chunk) . Just $ sign x- where- sign :: (Num a, Ord a) => a -> a- sign | x < 0 = subtract 1 . negate- | otherwise = id-- chunk :: Integer -> (Word8, Maybe Integer)- chunk x = (b, i)- where- b = sign (fromInteger x)- i | x >= 128 = Just (x `shiftR` 8)- | otherwise = Nothing---- | 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 ""----------------------------------------------------------------------------------
+ src/Language/Embedded/VHDL/Expression/Represent.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}++module Language.Embedded.VHDL.Expression.Represent+ ( Tagged(..)+ , Rep(..)+ ) where++import Language.VHDL (TypeDeclaration(..), SubtypeIndication(..))+import Language.Embedded.VHDL.Monad (VHDL)+import Language.Embedded.VHDL.Monad.Type+import qualified Language.VHDL as V+import qualified Language.Embedded.VHDL.Monad as M++import Data.Bits+import Data.Char (intToDigit)+import Data.Word+import Data.Int+import Text.Printf (printf)+import Numeric (showIntAtBase)+import qualified Data.ByteString as B++--------------------------------------------------------------------------------+-- * Kludge - until I come up with a better solution+--------------------------------------------------------------------------------++-- | Tag a value with some (possibly) interesting information+newtype Tagged s b = Tag { unTag :: b }++-- | A 'rep'resentable value.+class Rep a+ where+ width :: Tagged a Int+ typed :: Tagged a Type+ declare :: a -> VHDL ()+ format :: a -> String++declareBoolean :: VHDL ()+declareBoolean =+ do M.newLibrary "IEEE"+ M.newImport "IEEE.std_logic_1164"++declareNumeric :: VHDL ()+declareNumeric =+ do M.newLibrary "IEEE"+ M.newImport "IEEE.std_logic_1164"+ M.newImport "IEEE.numeric_std"++--------------------------------------------------------------------------------+-- ** Boolean++instance Rep Bool where+ width = Tag 1+ typed = Tag std_logic+ declare _ = declareBoolean+ format True = "1"+ format False = "0"++--------------------------------------------------------------------------------+-- ** Signed++instance Rep Int8 where+ width = Tag 8+ typed = Tag signed8+ declare _ = declareNumeric+ format = convert++instance Rep Int16 where+ width = Tag 16+ typed = Tag signed16+ declare _ = declareNumeric+ format = convert++instance Rep Int32 where+ width = Tag 32+ typed = Tag signed32+ declare _ = declareNumeric+ format = convert++instance Rep Int64 where+ width = Tag 64+ typed = Tag signed64+ declare _ = declareNumeric+ format = convert++--------------------------------------------------------------------------------+-- ** Unsigned++instance Rep Word8 where+ width = Tag 8+ typed = Tag usigned8+ declare _ = declareNumeric+ format = convert++instance Rep Word16 where+ width = Tag 16+ typed = Tag usigned16+ declare _ = declareNumeric+ format = convert++instance Rep Word32 where+ width = Tag 32+ typed = Tag usigned32+ declare _ = declareNumeric+ format = convert++instance Rep Word64 where+ width = Tag 64+ typed = Tag usigned64+ declare _ = declareNumeric+ format = convert++--------------------------------------------------------------------------------+-- * Converting Integers to their Binrary representation+--------------------------------------------------------------------------------++-- | Convert an Integral to its binary representation+convert :: Integral a => a -> String+convert = foldr1 (++) . fmap w2s . B.unpack . i2bs . toInteger++-- | Go over an Integer and convert it into a bytestring containing its+-- binary representation+i2bs :: Integer -> B.ByteString+i2bs x = B.reverse . B.unfoldr (fmap chunk) . Just $ sign x+ where+ sign :: (Num a, Ord a) => a -> a+ sign | x < 0 = subtract 1 . negate+ | otherwise = id++ chunk :: Integer -> (Word8, Maybe Integer)+ chunk x = (b, i)+ where+ b = sign (fromInteger x)+ i | x >= 128 = Just (x `shiftR` 8)+ | otherwise = Nothing++-- | 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 ""++--------------------------------------------------------------------------------
− src/Language/Embedded/VHDL/Expression/Type.hs
@@ -1,75 +0,0 @@-module Language.Embedded.VHDL.Expression.Type- ( Type- , Kind(..)- , std_logic- , signed, usigned- , signed8, signed16, signed32, signed64- , usigned8, usigned16, usigned32, usigned64- , resize- ) where--import Language.VHDL-import Language.Embedded.VHDL.Expression.Hoist hiding (Kind) -- resize-import Language.Embedded.VHDL.Monad.Expression (lit)------------------------------------------------------------------------------------- * Types------------------------------------------------------------------------------------- | Type indication for signals/variables/..-type Type = SubtypeIndication---- | The different kinds of signals/variables/.. that exist in VHDL-data Kind = Constant | Signal | Variable | File------------------------------------------------------------------------------------- ** Standard logic types--std_logic :: Type-std_logic = SubtypeIndication Nothing (TMType (NSimple (Ident "std_logic"))) Nothing------------------------------------------------------------------------------------- ** Signed / Unsigned--arith :: String -> Int -> 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 (show i)) (Nothing)) []) []--signed, usigned :: Int -> Type-signed = arith "signed"-usigned = arith "unsigned"- -signed8, signed16, signed32, signed64 :: Type-signed8 = signed 8-signed16 = signed 16-signed32 = signed 32-signed64 = signed 64--usigned8, usigned16, usigned32, usigned64 :: Type-usigned8 = usigned 8-usigned16 = usigned 16-usigned32 = usigned 32-usigned64 = usigned 64---- .. add more ..------------------------------------------------------------------------------------- ** Type conversion (and other stuff)--resize :: Int -> Term -> Primary-resize size exp =- PrimFun (FunctionCall- (NSimple (Ident "resize"))- (Just (AssociationList- [ AssociationElement Nothing (APDesignator (ADExpression (lift exp)))- , AssociationElement Nothing (APDesignator (ADExpression (lift (lit (show size)))))- ])- ))----------------------------------------------------------------------------------
src/Language/Embedded/VHDL/Interface.hs view
@@ -3,9 +3,9 @@ module Language.Embedded.VHDL.Interface where -import Language.VHDL (Expression, Identifier(..))-import Language.Embedded.VHDL.Monad (VHDL)-import Language.Embedded.VHDL.Expression.Type (Type)+import Language.VHDL (Expression, Identifier(..))+import Language.Embedded.VHDL.Monad (VHDL)+import Language.Embedded.VHDL.Monad.Type (Type) import Data.Constraint import Data.Typeable (Typeable)@@ -23,19 +23,19 @@ litE :: PredicateExp exp a => a -> exp a -- | Evaluation of (closed) expressions- evalE :: exp a -> a+ evalE :: PredicateExp exp a => exp a -> a -- | General interface for compiling expressions class CompileExp exp where -- | Variable expressions- varE :: PredicateExp exp a => Identifier -> exp a+ varE :: PredicateExp exp a => Integer -> exp a -- | Compilation of type kind compT :: PredicateExp exp a => exp a -> VHDL Type -- | Compilation of expressions- compE :: exp a -> VHDL Expression+ compE :: PredicateExp exp a => exp a -> VHDL Expression --------------------------------------------------------------------------------
src/Language/Embedded/VHDL/Monad.hs view
@@ -5,7 +5,7 @@ -- used for the Ord/Eq inst. of XDeclaration etc. {-# LANGUAGE StandaloneDeriving #-} -module Language.Embedded.VHDL.Monad ( +module Language.Embedded.VHDL.Monad ( VHDL , VHDLT , VHDLEnv@@ -14,6 +14,8 @@ -- ^ run , runVHDLT , runVHDL+ , execVHDLT+ , execVHDL -- ^ pretty , prettyVHDL@@ -21,36 +23,32 @@ -- ^ ... , freshUnique- , newVar+ , newSym , newLabel + -- ^ ...+ , newLibrary, newImport+ -- ^ declarations- , addPort- , addGeneric- , addType+ , addPort, addGeneric+ , addGlobal, addLocal+ , addConcurrent, addSequential , addComponent- , addGlobal- , addLocal -- ^ statements- , addConcurrent- , addSequential-- -- ^ key statements- , inEntity- , inArchitecture , inProcess , inConditional , inCase + -- ^ ...+ , entity+ , architecture+ , package+ -- ^ common- , interfaceConstant- , interfaceSignal- , interfaceVariable- , declRecord- , declConstant- , declSignal- , declVariable+ , interfaceConstant, interfaceSignal, interfaceVariable+ , declRecord, declConstant, declSignal, declVariable+ , portMap , assignSignal , assignVariable@@ -61,8 +59,8 @@ import Language.VHDL (Identifier(..), Mode(..), Expression, Label) import qualified Language.VHDL as V -import Language.Embedded.VHDL.Expression.Type import Language.Embedded.VHDL.Monad.Expression+import Language.Embedded.VHDL.Monad.Type import Control.Arrow (first, second) import Control.Applicative@@ -78,8 +76,11 @@ import Data.List (groupBy) import Data.Set (Set) import qualified Data.Set as Set+import Data.Map (Map)+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@@ -88,30 +89,21 @@ -- * .. -------------------------------------------------------------------------------- --- | ...-data VFile = VFile (V.EntityDeclaration) [V.ArchitectureBody]- -- | Code generation state data VHDLEnv = VHDLEnv { _unique :: !Integer- , _entity :: String- -- ..- , _parts :: [VFile]-+ , _designs :: [V.DesignUnit] -- ...+ , _context :: Set V.ContextItem , _types :: Set V.TypeDeclaration- , _components :: Set V.ComponentDeclaration- -- headers , _ports :: [V.InterfaceDeclaration] , _generics :: [V.InterfaceDeclaration]- , _architectures :: [V.ArchitectureBody]- + , _components :: Set V.ComponentDeclaration -- declarations , _global :: [V.BlockDeclarativeItem] , _local :: [V.BlockDeclarativeItem]- -- statements , _concurrent :: [V.ConcurrentStatement] , _sequential :: [V.SequentialStatement]@@ -120,13 +112,12 @@ -- | Initial state during code generation emptyVHDLEnv = VHDLEnv { _unique = 0- , _entity = "invisible"- , _parts = []+ , _designs = []+ , _context = Set.empty , _types = Set.empty , _components = Set.empty , _ports = [] , _generics = []- , _architectures = [] , _global = [] , _local = [] , _concurrent = []@@ -134,7 +125,7 @@ } ----------------------------------------------------------------------------------- *+-- * -- | Type constraints for the VHDL monads type MonadV m = (Functor m, Applicative m, Monad m, MonadState VHDLEnv m)@@ -142,7 +133,7 @@ -- | VHDL code generation monad type VHDL = VHDLT Identity --- | VHDL code genreation monad transformer+-- | VHDL code genreation monad transformer. newtype VHDLT m a = VHDLT { unVGenT :: StateT VHDLEnv m a } deriving ( Functor , Applicative@@ -151,82 +142,129 @@ , MonadIO ) --- | Run the VHDL code generation monad transformer+-- | Run the VHDL code generation monad transformer. runVHDLT :: Monad m => VHDLT m a -> VHDLEnv -> m (a, VHDLEnv) runVHDLT m = CMS.runStateT (unVGenT m) --- | Run the VHDL code generation monad-runVHDL :: VHDL a -> VHDLEnv -> (a, VHDLEnv)-runVHDL m = CMI.runIdentity . CMS.runStateT (unVGenT m)+-- | -- | Executes the VHDL code generation monad transformer, returning only its final state.+execVHDLT :: Monad m => VHDLT m a -> VHDLEnv -> m VHDLEnv+execVHDLT m = CMS.execStateT (unVGenT m) +-- | Run the VHDL code generation monad.+runVHDL :: VHDL a -> VHDLEnv -> (a, VHDLEnv)+runVHDL m = CMI.runIdentity . runVHDLT m++-- | Executes the VHDL code generation monad, returning only its final state.+execVHDL :: VHDL a -> VHDLEnv -> VHDLEnv+execVHDL m = CMI.runIdentity . execVHDLT m+ ----------------------------------------------------------------------------------- ** Unique generation+-- ** Generating uniques --- | Generates a unique integer+-- | Generates a unique integer. freshUnique :: MonadV m => m Integer freshUnique = do u <- CMS.gets _unique CMS.modify (\e -> e { _unique = u + 1 }) return u --- | Generates a fresh and unique identifier-newVar :: MonadV m => m Identifier-newVar = freshUnique >>= return . Ident . ('u' :) . show+-- | Generates a fresh and unique identifier.+newSym :: MonadV m => m Identifier+newSym = do i <- freshUnique; return (Ident $ 'v' : show i) --- | Generates a fresh and unique label+-- | Generates a fresh and unique label. newLabel :: MonadV m => m Label-newLabel = freshUnique >>= return . Ident . ('l' :) . show+newLabel = do i <- freshUnique; return (Ident $ 'l' : show i) --------------------------------------------------------------------------------+-- ** ...++-- | Adds a new library import to the context.+newLibrary :: MonadV m => String -> m ()+newLibrary l = CMS.modify $ \s -> s { _context = Set.insert item (_context s) }+ where+ item :: V.ContextItem+ item = V.ContextLibrary (V.LibraryClause (V.LogicalNameList [V.Ident l]))++-- | Adds a new library use clause to the context (with an .ALL suffix by default).+newImport :: MonadV m => String -> m ()+newImport i = CMS.modify $ \s -> s { _context = Set.insert item (_context s) }+ where+ item :: V.ContextItem+ item = V.ContextUse (V.UseClause [V.SelectedName (V.PName (V.NSimple (V.Ident i))) (V.SAll)])++-------------------------------------------------------------------------------- -- ** Header declarations -- ignores port/generic maps for now --- | Adds a port declaration to the entity+-- | Adds a port declaration to the entity. addPort :: MonadV m => V.InterfaceDeclaration -> m () addPort p = CMS.modify $ \s -> s { _ports = p : (_ports s) } --- | Adds a generic declaration to the entity+-- | Adds a generic declaration to the entity. addGeneric :: MonadV m => V.InterfaceDeclaration -> m () addGeneric g = CMS.modify $ \s -> s { _generics = g : (_generics s) } ----------------------------------------------------------------------------------- ** Component declarations+-- ** Type declarations --- | ...+-- | Adds a type declaration. addType :: MonadV m => V.TypeDeclaration -> m () addType t = CMS.modify $ \s -> s { _types = Set.insert t (_types s) } --- | Adds a component declaration to the architecture+-- | Adds a component declaration. addComponent :: MonadV m => V.ComponentDeclaration -> m () addComponent c = CMS.modify $ \s -> s { _components = Set.insert c (_components s) } -------------------------------------------------------------------------------- -- ** Item declarations --- | Adds a global declaration+-- | Adds a global declaration. addGlobal :: MonadV m => V.BlockDeclarativeItem -> m () addGlobal g = CMS.modify $ \s -> s { _global = g : (_global s) } --- | Adds a local declaration+-- | Adds a local declaration. addLocal :: MonadV m => V.BlockDeclarativeItem -> m () addLocal l = CMS.modify $ \s -> s { _local = l : (_local s) } ----------------------------------------------------------------------------------- ** Concurrent statements+-- ** Statement declarations --- | Runs the given action inside a process--- ! Due to how translate works, some local declarations might dissapear.+-- | Adds a concurrent statement.+addConcurrent :: MonadV m => V.ConcurrentStatement -> m ()+addConcurrent con = CMS.modify $ \s -> s { _concurrent = con : (_concurrent s) }++-- | Adds a sequential statement.+addSequential :: MonadV m => V.SequentialStatement -> m ()+addSequential seq = CMS.modify $ \s -> s { _sequential = seq : (_sequential s) }++--------------------------------------------------------------------------------+-- * Concurrent and sequential statements+--------------------------------------------------------------------------------++-- | ... helper ...+contain :: MonadV m => m () -> m [V.SequentialStatement]+contain m = do+ m -- do+ new <- reverse <$> CMS.gets _sequential -- get+ CMS.modify $ \e -> e { _sequential = [] } -- reset+ return new -- return++--------------------------------------------------------------------------------+-- ** Process-statements++-- | Runs the given action inside a process. inProcess :: MonadV m => Label -> [Identifier] -> m a -> m (a, V.ProcessStatement) inProcess l is m = do oldLocals <- CMS.gets _local oldSequential <- CMS.gets _sequential CMS.modify $ \e -> e { _local = [] , _sequential = [] }- a <- m+ result <- m newLocals <- reverse <$> CMS.gets _local newSequential <- reverse <$> CMS.gets _sequential CMS.modify $ \e -> e { _local = oldLocals , _sequential = oldSequential }- return ( a+ return ( result , V.ProcessStatement (Just l) -- label (False) -- postponed@@ -236,19 +274,11 @@ where sensitivity | P.null is = Nothing | otherwise = Just $ V.SensitivityList $ fmap V.NSimple is------------------------------------------------------------------------------------- ** Sequential statements--addConcurrent :: MonadV m => V.ConcurrentStatement -> m ()-addConcurrent con = CMS.modify $ \s -> s { _concurrent = con : (_concurrent s) }--addSequential :: MonadV m => V.SequentialStatement -> m ()-addSequential seq = CMS.modify $ \s -> s { _sequential = seq : (_sequential s) }-+ ----------------------------------------------------------------------------------- **+-- ** If-statements +-- | ... inConditional :: MonadV m => (V.Condition, m ()) -> [(V.Condition, m ())] -> m () -> m (V.IfStatement) inConditional (c, m) os e = do let (cs, ns) = unzip os@@ -270,16 +300,10 @@ | P.null xs = Nothing | otherwise = Just xs -contain :: MonadV m => m () -> m [V.SequentialStatement]-contain m =- do m -- do- new <- reverse <$> CMS.gets _sequential -- get- CMS.modify $ \e -> e { _sequential = [] } -- reset- return $ new- ----------------------------------------------------------------------------------- **+-- ** Case-statements +-- | ... inCase :: MonadV m => V.Expression -> [(V.Choices, m ())] -> m (V.CaseStatement) inCase e choices = do let (cs, ns) = unzip choices@@ -294,110 +318,141 @@ (zipWith V.CaseStatementAlternative cs ns') ----------------------------------------------------------------------------------- **--addArchitecture :: MonadV m => V.ArchitectureBody -> m ()-addArchitecture a = CMS.modify $ \s -> s { _architectures = a : (_architectures s)}+-- * Design units+-------------------------------------------------------------------------------- -inArchitecture :: MonadV m => String -> m a -> m a-inArchitecture name m =- do oldEntity <- CMS.gets _entity- oldComponent <- CMS.gets _components- oldGlobal <- CMS.gets _global- oldLocal <- CMS.gets _local- oldConcurrent <- CMS.gets _concurrent- CMS.modify $ \e -> e { _components = Set.empty- , _global = []- , _local = []- , _concurrent = []- }- a <- m- newComponent <- CMS.gets _components- newGlobal <- reverse <$> CMS.gets _global- newLocal <- reverse <$> CMS.gets _local- newConcurrent <- reverse <$> CMS.gets _concurrent- CMS.modify $ \e -> e { _components = oldComponent- , _global = oldGlobal- , _local = oldLocal- , _concurrent = oldConcurrent+-- | ... design unit with context+addDesign :: MonadV m => V.LibraryUnit -> m ()+addDesign lib =+ do ctxt <- CMS.gets _context+ dsig <- CMS.gets _designs+ let item = V.DesignUnit (V.ContextClause (Set.toList ctxt)) lib+ CMS.modify $ \s -> s { _designs = item : dsig+ , _context = Set.empty } - addArchitecture $ V.ArchitectureBody- (V.Ident name)- (V.NSimple (V.Ident oldEntity))- (merge $ newGlobal ++ newLocal)- (newConcurrent)- return a+-- | .. design unit ignoring context+addDesign_ :: MonadV m => V.LibraryUnit -> m ()+addDesign_ lib = CMS.modify $ \s -> s { _designs = (V.DesignUnit (V.ContextClause []) lib) : (_designs s)} ----------------------------------------------------------------------------------- **+-- ** Architectures -addPart :: MonadV m => VFile -> m ()-addPart v = CMS.modify $ \s -> s { _parts = v : (_parts s) }+-- | Wraps the given monadic action in an architecture, consuming all global+-- 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+ oldConcurrent <- CMS.gets _concurrent+ CMS.modify $ \e -> e { _global = []+ , _concurrent = [] }+ result <- m+ newGlobal <- CMS.gets _global+ newConcurrent <- CMS.gets _concurrent+ addDesign_ $ V.LibrarySecondary $ V.SecondaryArchitecture $+ V.ArchitectureBody+ (name)+ (V.NSimple entity)+ (merge newGlobal)+ (newConcurrent)+ CMS.modify $ \e -> e { _global = oldGlobal+ , _concurrent = oldConcurrent }+ return result -inEntity :: MonadV m => String -> m a -> m a-inEntity name m =- do oldUnique <- CMS.gets _unique- oldEntity <- CMS.gets _entity- oldPorts <- CMS.gets _ports- oldGenerics <- CMS.gets _generics- oldArchitectures <- CMS.gets _architectures- CMS.modify $ \e -> e { _unique = 0- , _entity = name- , _ports = []- , _generics = []- , _architectures = []- }- a <- m- newPorts <- reverse <$> CMS.gets _ports- newGenerics <- reverse <$> CMS.gets _generics- newArchitectures <- reverse <$> CMS.gets _architectures- CMS.modify $ \e -> e { _unique = oldUnique- , _entity = oldEntity- , _ports = oldPorts- , _generics = oldGenerics- , _architectures = oldArchitectures- }- addPart $ VFile- (V.EntityDeclaration- (V.Ident name)- (V.EntityHeader- (V.GenericClause <$> maybeNull newGenerics)- (V.PortClause <$> maybeNull newPorts))- ([])- (Nothing))- (newArchitectures)- return a+--------------------------------------------------------------------------------+-- ** Entities++-- | 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 = [] }+ result <- m+ newPorts <- CMS.gets _ports+ newGenerics <- CMS.gets _generics+ addDesign $ V.LibraryPrimary $ V.PrimaryEntity $+ V.EntityDeclaration+ (name)+ (V.EntityHeader+ (V.GenericClause <$> maybeNull newGenerics)+ (V.PortClause <$> maybeNull newPorts))+ ([])+ (Nothing)+ CMS.modify $ \e -> e { _ports = oldPorts+ , _generics = oldGenerics }+ return result where maybeNull :: [V.InterfaceDeclaration] -> Maybe V.InterfaceList maybeNull [] = Nothing maybeNull xs = Just $ V.InterfaceList $ merge xs --------------------------------------------------------------------------------+-- ** Packages++-- | Declares a package with the given name by consuming all type declarations+-- produced by running the monadic action.+--+-- *** package body is always empty for now (until we support VHDL functions).+package :: MonadV m => String -> m a -> m a+package name m =+ do oldTypes <- CMS.gets _types+ CMS.modify $ \e -> e { _types = Set.empty }+ result <- m+ newTypes <- CMS.gets _types+ addDesign $ V.LibraryPrimary $ V.PrimaryPackage $+ V.PackageDeclaration+ (V.Ident name)+ (fmap V.PHDIType $ Set.toList newTypes)+ addDesign_ $ V.LibrarySecondary $ V.SecondaryPackage $+ V.PackageBody+ (V.Ident name)+ ([])+ CMS.modify $ \e -> e { _types = oldTypes }+ return result++-------------------------------------------------------------------------------- -- * Pretty -------------------------------------------------------------------------------- +-- | Runs the VHDL monad and pretty prints its resulting VHDL program. prettyVHDL :: VHDL a -> Doc prettyVHDL = CMI.runIdentity . prettyVHDLT +-- | Runs the VHDL monad transformer and pretty prints its resulting VHDL program. prettyVHDLT :: Monad m => VHDLT m a -> m Doc-prettyVHDLT m = prettyVEnv . snd <$> runVHDLT (inEntity "anonymous" m) emptyVHDLEnv+prettyVHDLT m = prettyVEnv <$> execVHDLT m emptyVHDLEnv -prettyVEnv :: VHDLEnv -> Doc-prettyVEnv (VHDLEnv _ _ parts types _ _ _ _ _ _ _ _) =- stack $ (genPackage "types" $ Set.toList types) : (fmap prettyPart parts)+--------------------------------------------------------------------------------++-- | 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 = V.pp (V.DesignFile $ types ++ archi) where- stack :: [Doc] -> Doc- stack = foldr1 ($+$)- - prettyPart :: VFile -> Doc- prettyPart (VFile e as) = stack (V.pp e : fmap V.pp as)+ archi = reverse $ _designs env+ types = reverse $ designTypes (_types env) ---------------------------------------------------------------------------------+-- | ...+--+-- *** Scan type declarations for necessary imports instead.+-- *** Types are added in an ugly manner.+designTypes :: Set V.TypeDeclaration -> [V.DesignUnit]+designTypes set = _designs . snd $ runVHDL pack emptyVHDLEnv+ where+ pack :: MonadV m => m ()+ pack = package "types" $ do+ newLibrary "IEEE"+ newImport "IEEE.STD_LOGIC_1164"+ newImport "IEEE.STD_LOGIC_UNSIGNED"+ newImport "IEEE.NUMERIC_STD"+ CMS.modify $ \e -> e { _types = set } -genPackage :: String -> [V.TypeDeclaration] -> Doc-genPackage name = V.pp . V.PackageDeclaration (V.Ident name) . fmap V.PHDIType- -------------------------------------------------------------------------------- -- * Common things --------------------------------------------------------------------------------@@ -427,6 +482,15 @@ where decl (i, t) = V.ElementDeclaration [i] t +-- ... only unconstrained arrays without any index subtype definitions+declArray :: Identifier -> Type -> V.TypeDeclaration+declArray name typ = V.TDFull+ (V.FullTypeDeclaration+ (name)+ (V.TDComposite (V.CTDArray (V.ArrU (V.UnconstrainedArrayDefinition+ ([])+ (typ))))))+ -------------------------------------------------------------------------------- -- ** Global/Local Declarations @@ -535,22 +599,136 @@ tryProcess _ = Nothing ----------------------------------------------------------------------------------- Ord instance for use in Set+-- ** Ord instance for use in sets+--+-- *** These break the Ord rules but seems to be needed for Set.+-- Should be replaced.++deriving instance Ord V.ContextItem++deriving instance Ord V.LibraryClause++deriving instance Ord V.LogicalNameList++deriving instance Ord V.UseClause+ -------------------------------------------------------------------------------- -deriving instance Ord Identifier+instance Ord V.TypeDeclaration + where+ compare (V.TDFull l) (V.TDFull r) = compare (V.ftd_identifier l) (V.ftd_identifier r)+ compare (V.TDPartial l) (V.TDPartial r) = compare l r+ compare (V.TDFull l) _ = GT+ compare (V.TDPartial l) _ = LT -instance Ord V.TypeDeclaration where- compare (V.TDFull l) (V.TDFull r) = compare (V.ftd_identifier l) (V.ftd_identifier r)- compare (V.TDPartial l) (V.TDPartial r) = compare l r- -- ...- compare (V.TDFull l) _ = GT- compare (V.TDPartial l) _ = LT+deriving instance Ord V.IncompleteTypeDeclaration -instance Ord V.IncompleteTypeDeclaration where- compare (V.IncompleteTypeDeclaration l) (V.IncompleteTypeDeclaration r) = compare l r+instance Ord V.ComponentDeclaration+ where+ compare l r = compare (V.comp_identifier l) (V.comp_identifier r) -instance Ord V.ComponentDeclaration where- compare l r = compare (V.comp_identifier l) (V.comp_identifier r)+--------------------------------------------------------------------------------++deriving instance Ord V.SubtypeIndication++deriving instance Ord V.TypeMark++instance Ord V.Constraint+ where+ compare (V.CRange a) (V.CRange b) = compare a b+ compare _ _ = error "Ord not supported for index constraints"++deriving instance Ord V.RangeConstraint++instance Ord V.Range+ where+ compare (V.RSimple a b c) (V.RSimple x y z) =+ case compare a x of+ GT -> GT+ LT -> LT+ EQ -> case compare b y of+ GT -> GT+ LT -> LT+ EQ -> case compare c z of+ GT -> GT+ LT -> LT+ EQ -> EQ+ compare _ _ = error "Ord not supported for attribute ranges"++deriving instance Ord V.Direction++--------------------------------------------------------------------------------++deriving instance Ord V.Expression++deriving instance Ord V.Relation++deriving instance Ord V.ShiftExpression++deriving instance Ord V.SimpleExpression++deriving instance Ord V.Term++deriving instance Ord V.Factor++instance Ord V.Primary+ where+ compare (V.PrimName a) (V.PrimName x) = compare a x++--------------------------------------------------------------------------------++deriving instance Ord V.LogicalOperator++deriving instance Ord V.RelationalOperator++deriving instance Ord V.ShiftOperator++deriving instance Ord V.AddingOperator++deriving instance Ord V.Sign++deriving instance Ord V.MultiplyingOperator++deriving instance Ord V.MiscellaneousOperator++--------------------------------------------------------------------------------++deriving instance Ord V.Identifier++instance Ord V.Name+ where+ compare (V.NSimple a) (V.NSimple x) = compare a x+ compare (V.NSelect a) (V.NSelect x) = compare a x+ compare (V.NIndex a) (V.NIndex x) = compare a x+ compare (V.NSlice a) (V.NSlice x) = compare a x+ compare (V.NAttr a) (V.NAttr x) = compare a x++deriving instance Ord V.StringLiteral++deriving instance Ord V.SelectedName++instance Ord V.Suffix+ where+ compare (V.SSimple a) (V.SSimple x) = compare a x+ compare (V.SChar a) (V.SChar x) = compare a x+ compare (V.SAll) (V.SAll) = EQ+ compare _ _ = error "Ord not supported for operator symbols"++deriving instance Ord V.CharacterLiteral++deriving instance Ord V.IndexedName++deriving instance Ord V.SliceName++deriving instance Ord V.DiscreteRange++instance Ord V.Prefix+ where+ compare (V.PName a) (V.PName x) = compare a x+ compare _ _ = error "Ord not supported for function names"++deriving instance Ord V.AttributeName++deriving instance Ord V.Signature --------------------------------------------------------------------------------
src/Language/Embedded/VHDL/Monad/Expression.hs view
@@ -87,7 +87,7 @@ -------------------------------------------------------------------------------- -- ** Primaries ----- ! These are a bit simplified..+-- Meh.. name, string, lit :: String -> Primary name = PrimName . NSimple . Ident@@ -96,5 +96,15 @@ null :: Primary null = PrimLit LitNull++--------------------------------------------------------------------------------+-- * Record things+--------------------------------------------------------------------------------++aggregate :: [(Maybe Choices, Expression)] -> Primary+aggregate es = PrimAgg $ Aggregate $ map (uncurry ElementAssociation) es++selected :: Identifier -> Identifier -> Primary+selected p s = PrimName $ NSelect $ SelectedName (PName $ NSimple p) (SSimple s) --------------------------------------------------------------------------------
+ src/Language/Embedded/VHDL/Monad/Type.hs view
@@ -0,0 +1,75 @@+module Language.Embedded.VHDL.Monad.Type+ ( Type+ , Kind(..)+ , std_logic+ , signed, usigned+ , signed8, signed16, signed32, signed64+ , usigned8, usigned16, usigned32, usigned64+ , resize+ ) where++import Language.VHDL+import Language.Embedded.VHDL.Expression.Hoist hiding (Kind) -- resize+import Language.Embedded.VHDL.Monad.Expression (lit)++--------------------------------------------------------------------------------+-- * Types+--------------------------------------------------------------------------------++-- | Type indication for signals/variables/..+type Type = SubtypeIndication++-- | The different kinds of signals/variables/.. that exist in VHDL+data Kind = Constant | Signal | Variable | File++--------------------------------------------------------------------------------+-- ** Standard logic types++std_logic :: Type+std_logic = SubtypeIndication Nothing (TMType (NSimple (Ident "std_logic"))) Nothing++--------------------------------------------------------------------------------+-- ** Signed / Unsigned++arith :: String -> Int -> 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 (show i)) (Nothing)) []) []++signed, usigned :: Int -> Type+signed = arith "signed"+usigned = arith "unsigned"++signed8, signed16, signed32, signed64 :: Type+signed8 = signed 8+signed16 = signed 16+signed32 = signed 32+signed64 = signed 64++usigned8, usigned16, usigned32, usigned64 :: Type+usigned8 = usigned 8+usigned16 = usigned 16+usigned32 = usigned 32+usigned64 = usigned 64++-- .. add more ..++--------------------------------------------------------------------------------+-- ** Type conversion (and other stuff)++resize :: Int -> Term -> Primary+resize size exp =+ PrimFun (FunctionCall+ (NSimple (Ident "resize"))+ (Just (AssociationList+ [ AssociationElement Nothing (APDesignator (ADExpression (lift exp)))+ , AssociationElement Nothing (APDesignator (ADExpression (lift (lit (show size)))))+ ])+ ))++--------------------------------------------------------------------------------