diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2016, Markus Aronsson + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Markus Aronsson nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hardware-edsl.cabal b/hardware-edsl.cabal new file mode 100644 --- /dev/null +++ b/hardware-edsl.cabal @@ -0,0 +1,72 @@ +name: hardware-edsl +version: 0.1.0.0 +synopsis: Deep embedding of hardware descriptions with code generation. +description: Deep embedding of hardware descriptions with code generation. +license: BSD3 +license-file: LICENSE +author: Markus Aronsson +maintainer: mararon@chalmers.se +-- copyright: +homepage: https://github.com/markus-git/hardware-edsl +category: Language +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +source-repository head + type: git + location: git://github.com/markus-git/hardware-edsl + +library + exposed-modules: + Language.Embedded.Hardware, + Language.Embedded.Hardware.Expression, + Language.Embedded.Hardware.Expression.Syntax, + Language.Embedded.Hardware.Expression.Represent, + Language.Embedded.Hardware.Expression.Frontend, + Language.Embedded.Hardware.Command, + 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 + + other-modules: + Language.Embedded.Hardware.Expression.Hoist, + Language.Embedded.Hardware.Expression.Backend.VHDL, + Language.Embedded.Hardware.Command.Backend.VHDL + + other-extensions: + GADTs, + KindSignatures, + TypeFamilies, + TypeOperators, + FlexibleContexts, + FlexibleInstances, + MultiParamTypeClasses, + ScopedTypeVariables, + GeneralizedNewtypeDeriving, + ConstraintKinds, + Rank2Types, + StandaloneDeriving, + UndecidableInstances + + build-depends: + base >=4.8 && <4.9, + 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, + constraints >=0.6, + syntactic >=3.2, + operational-alacarte >=0.1.1, + language-vhdl >=0.1.2.5 + + hs-source-dirs: + src + + default-language: + Haskell2010 diff --git a/src/Language/Embedded/Hardware.hs b/src/Language/Embedded/Hardware.hs new file mode 100644 --- /dev/null +++ b/src/Language/Embedded/Hardware.hs @@ -0,0 +1,10 @@ +module Language.Embedded.Hardware + ( module Language.Embedded.Hardware.Expression + , module Language.Embedded.Hardware.Command + , module Language.Embedded.Hardware.Interface + ) where + +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 new file mode 100644 --- /dev/null +++ b/src/Language/Embedded/Hardware/Command.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Language.Embedded.Hardware.Command + ( compile + , icompile + , runIO + + , module CMD + , module Language.Embedded.Hardware.Command.CMD + , module Language.Embedded.Hardware.Command.Frontend + , module Language.Embedded.Hardware.Command.Backend.VHDL + ) where + +import Language.Embedded.Hardware.Command.CMD as CMD (Signal, Variable, Array) +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.VHDL (VHDL, prettyVHDL) + +import Control.Monad.Operational.Higher + +-------------------------------------------------------------------------------- +-- * Compilation and evaluation. +-------------------------------------------------------------------------------- + +-- | Compile a program to VHDL code represented as a string. +compile :: (Interp instr VHDL, HFunctor instr) => Program instr 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 = putStrLn . compile + +-- | Run a program in 'IO'. +runIO :: (Interp instr IO, HFunctor instr) => Program instr a -> IO a +runIO = interpret + +-------------------------------------------------------------------------------- diff --git a/src/Language/Embedded/Hardware/Command/Backend/VHDL.hs b/src/Language/Embedded/Hardware/Command/Backend/VHDL.hs new file mode 100644 --- /dev/null +++ b/src/Language/Embedded/Hardware/Command/Backend/VHDL.hs @@ -0,0 +1,295 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Language.Embedded.Hardware.Command.Backend.VHDL () where + +import Control.Monad.Operational.Higher + +import Language.Embedded.Hardware.Interface +import Language.Embedded.Hardware.Expression.Hoist +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 qualified Data.IORef as IR +import qualified Data.Array.IO as IA + +-------------------------------------------------------------------------------- +-- * 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 + +compEM :: forall exp a. (PredicateExp 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 + +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) + 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 + +-------------------------------------------------------------------------------- +-- ** Signals. + +instance CompileExp exp => Interp (SignalCMD exp) VHDL + where + interp = compileSignal + +instance EvaluateExp exp => Interp (SignalCMD exp) IO + where + interp = 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 + 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 (UnsafeFreezeSignal (SignalC s)) = + do return $ varE s + +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) + +-------------------------------------------------------------------------------- +-- ** Variables. + +instance CompileExp exp => Interp (VariableCMD exp) VHDL + where + interp = compileVariable + +instance EvaluateExp exp => Interp (VariableCMD exp) IO + where + interp = 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 + 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 (UnsafeFreezeVariable (VariableC v)) = + do return $ varE 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) + +-------------------------------------------------------------------------------- +-- ** Arrays. + +instance (CompileExp exp, EvaluateExp exp, CompArrayIx exp) => Interp (ArrayCMD exp) VHDL + where + interp = compileArray + +instance EvaluateExp exp => Interp (ArrayCMD exp) IO + where + interp = 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) + 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 + +runArray :: forall exp prog a. EvaluateExp exp => ArrayCMD exp prog a -> IO a +runArray (NewArray len) = fmap ArrayE $ IA.newArray_ $ (,) 0 $ evalE len +runArray (InitArray is) = fmap ArrayE $ IA.newListArray (0, fromIntegral $ length is) is +runArray (GetArray i (ArrayE a)) = fmap litE $ IA.readArray a $ evalE i +runArray (SetArray i e (ArrayE a)) = IA.writeArray a (evalE i) (evalE e) +runArray (UnsafeGetArray i a) = runArray (GetArray i a) + +-------------------------------------------------------------------------------- + +-- | Fresh array type identifier +freshA :: VHDL V.Identifier +freshA = toIdent . ('t' :) . show <$> V.freshUnique + +-- | 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) + +zero :: V.SimpleExpression +zero = lift (V.lit 0) + +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 + +-------------------------------------------------------------------------------- +-- ** Loops. + +instance CompileExp exp => Interp (LoopCMD exp) VHDL + where + interp = compileLoop + +instance EvaluateExp exp => Interp (LoopCMD exp) IO + where + interp = 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) + V.addSequential $ V.SLoop $ loop +compileLoop (While b step) = + do error "todo: compile while loops" + +runLoop :: forall exp prog a. EvaluateExp exp => LoopCMD exp IO a -> IO a +runLoop (For r step) = loop (evalE r) + where + loop i | i > 0 = step (litE i) >> loop (i - 1) + | otherwise = return () +runLoop (While b step) = loop + where + loop = b >>= flip when (step >> loop) . evalE + +-------------------------------------------------------------------------------- +-- ** Conditional. + +instance CompileExp exp => Interp (ConditionalCMD exp) VHDL + where + interp = compileConditional + +instance EvaluateExp exp => Interp (ConditionalCMD exp) IO + where + interp = runConditional + +compileConditional :: forall exp a. CompileExp exp => ConditionalCMD exp VHDL a -> VHDL a +compileConditional (If (a, b) cs em) = + do let (es, ds) = unzip cs + el = maybe (return ()) id em + ae <- compE a + ese <- mapM compE es + s <- V.inConditional (ae, b) (zip ese ds) el + V.addSequential $ V.SIf s + +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 + where + loop [] = maybe (return ()) id em + loop ((c, p):xs) = if (evalE c) then p else (loop xs) + +-------------------------------------------------------------------------------- +-- ** Structural. + +instance CompileExp exp => Interp (StructuralCMD exp) VHDL + where + interp = compileStructural + +instance EvaluateExp exp => Interp (StructuralCMD exp) IO + where + interp = 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) = + do label <- V.newLabel + (a, c) <- V.inProcess label (fmap reveal xs) prog + V.addConcurrent (V.ConProcess c) + return a + where + reveal :: SignalX -> V.Identifier + reveal (SignalX s) = toIdent s + +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" + +-------------------------------------------------------------------------------- diff --git a/src/Language/Embedded/Hardware/Command/CMD.hs b/src/Language/Embedded/Hardware/Command/CMD.hs new file mode 100644 --- /dev/null +++ b/src/Language/Embedded/Hardware/Command/CMD.hs @@ -0,0 +1,211 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Language.Embedded.Hardware.Command.CMD where + +import Language.Embedded.VHDL (Mode) +import Language.Embedded.Hardware.Interface (PredicateExp) + +import Control.Monad.Operational.Higher + +import Data.Ix (Ix) +import Data.IORef (IORef) +import Data.Array.IO (IOArray) + +-------------------------------------------------------------------------------- +-- * Hardware commands. +-------------------------------------------------------------------------------- + +-------------------------------------------------------------------------------- +-- ** Signals. + +-- | 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) + +-- | Scope of a signal. +data Scope = SProcess | SArchitecture | SEntity + deriving (Show) + +-- | Signal representation. +data Signal a = SignalC Integer | SignalE (IORef a) + +-- | Commands for signals. +data SignalCMD (exp :: * -> *) (prog :: * -> *) a + where + -- ^ Create a new signal. + NewSignal :: PredicateExp exp a => Clause -> Scope -> Mode -> Maybe (exp a) -> SignalCMD exp prog (Signal a) + -- ^ Fetch the contents of a signal. + GetSignal :: PredicateExp exp a => Signal a -> SignalCMD exp prog (exp a) + -- ^ Write the value to a signal. + SetSignal :: PredicateExp exp a => Signal a -> exp a -> SignalCMD exp prog () + -- ^ 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 + +instance HFunctor (SignalCMD exp) + where + hfmap _ (NewSignal c s m e) = NewSignal c s m e + hfmap _ (GetSignal s) = GetSignal s + hfmap _ (SetSignal s e) = SetSignal s e + +-------------------------------------------------------------------------------- +-- ** Variables. + +-- | Variable representation. +data Variable a = VariableC Integer | VariableE (IORef a) + +-- | Commands for variables. +data VariableCMD (exp :: * -> *) (prog :: * -> *) a + where + -- ^ Create a new variable. + NewVariable :: PredicateExp exp a => Maybe (exp a) -> VariableCMD exp prog (Variable a) + -- ^ Fetch the contents of a variable. + GetVariable :: PredicateExp exp a => Variable a -> VariableCMD exp prog (exp a) + -- ^ Write the value to a variable. + SetVariable :: PredicateExp exp a => Variable a -> exp a -> VariableCMD exp prog () + -- ^ 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 + +instance HFunctor (VariableCMD exp) + where + hfmap _ (NewVariable e) = NewVariable e + hfmap _ (GetVariable s) = GetVariable s + hfmap _ (SetVariable s e) = SetVariable s e + +-------------------------------------------------------------------------------- +-- ** 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 _ _ = Nothing + +-- | Array reprensentation. +data Array i a = ArrayC Integer | ArrayE (IOArray i a) + +-- | Commands for arrays. +data ArrayCMD (exp :: * -> *) (prog :: * -> *) 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) + -- ^ 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) + -- ^ 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) + -- ^ 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) + +type instance IExp (ArrayCMD e) = e +type instance IExp (ArrayCMD e :+: i) = e + +instance HFunctor (ArrayCMD exp) + 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 + +-------------------------------------------------------------------------------- +-- ** Looping. + +-- | Commands for looping constructs. +data LoopCMD (exp :: * -> *) (prog :: * -> *) a + where + -- ^ Creates a new for loop. + For :: (PredicateExp exp n, Integral n) => exp n -> (exp n -> prog ()) -> LoopCMD exp prog () + -- ^ 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 + +instance HFunctor (LoopCMD exp) + where + hfmap f (For r step) = For r (f . step) + hfmap f (While cont step) = While (f cont) (f step) + +-------------------------------------------------------------------------------- +-- ** Conditional statements. + +-- | Commnads for conditional statements. +data ConditionalCMD (exp :: * -> *) (prog :: * -> *) a + where + If :: PredicateExp exp Bool + => (exp Bool, prog ()) -- if + -> [(exp Bool, prog ())] -- else-if + -> Maybe (prog ()) -- else + -> ConditionalCMD exp prog () + +type instance IExp (ConditionalCMD e) = e +type instance IExp (ConditionalCMD e :+: i) = e + +instance HFunctor (ConditionalCMD exp) + where + hfmap f (If a cs b) = If (fmap f a) (fmap (fmap f) cs) (fmap f b) + +-------------------------------------------------------------------------------- +-- ** Structural entities. + +-- | Untyped signals. +data SignalX = forall a. SignalX (Signal a) + +-- | Commands for structural entities. +data StructuralCMD (exp :: * -> *) (prog :: * -> *) a + where + -- ^ Wraps the program in an entity. + Entity :: String -> prog a -> StructuralCMD exp prog a + -- ^ Wraps the program in an architecture. + Architecture :: String -> String -> prog a -> StructuralCMD exp prog a + -- ^ Wraps the program in a process. + Process :: [SignalX] -> prog () -> StructuralCMD exp prog () + +type instance IExp (StructuralCMD e) = e +type instance IExp (StructuralCMD e :+: i) = e + +instance HFunctor (StructuralCMD exp) + 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) + +-------------------------------------------------------------------------------- diff --git a/src/Language/Embedded/Hardware/Command/Frontend.hs b/src/Language/Embedded/Hardware/Command/Frontend.hs new file mode 100644 --- /dev/null +++ b/src/Language/Embedded/Hardware/Command/Frontend.hs @@ -0,0 +1,199 @@ +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} + +module Language.Embedded.Hardware.Command.Frontend where + +import Language.Embedded.VHDL (Mode(..)) +import Language.Embedded.Hardware.Interface (PredicateExp) +import Language.Embedded.Hardware.Command.CMD + +import Control.Monad.Operational.Higher + +import Data.Ix (Ix) + +-------------------------------------------------------------------------------- +-- ** Signals. + +-- | 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 + +-- | 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 + +-- | 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 + +-- | 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 + +-- | 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 + +-- | 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 + +-- | 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 + +-- | 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 + +-- | 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-hand for 'setSignal'. +(<==) :: (SignalCMD (IExp i) :<: i, PredicateExp (IExp i) a) => Signal a -> IExp i a -> ProgramT i m () +(<==) = setSignal + +-------------------------------------------------------------------------------- +-- ** Variables. + +-- | Declare a variable. +newVariable :: (VariableCMD (IExp i) :<: i, PredicateExp (IExp i) a) => IExp i a -> ProgramT i m (Variable a) +newVariable = singleE . NewVariable . Just + +-- | Declare an uninitialized variable. +newVariable_ :: (VariableCMD (IExp i) :<: i, PredicateExp (IExp i) a) => ProgramT i m (Variable a) +newVariable_ = singleE $ NewVariable Nothing + +-- | 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 + +-- | 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 + +-- | 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 + +-- | Short-hand for 'setVariable'. +(==:) :: (VariableCMD (IExp i) :<: i, PredicateExp (IExp i) a) => Variable a -> IExp i a -> ProgramT i m () +(==:) = setVariable + +-------------------------------------------------------------------------------- +-- ** 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 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 + +-- | 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 + +-- | 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 + +-- | 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 + +-------------------------------------------------------------------------------- +-- ** 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 + +-- | 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 + +-------------------------------------------------------------------------------- +-- ** 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 + +-- | Guarded statement. +when + :: (ConditionalCMD (IExp i) :<: i, PredicateExp (IExp i) Bool) + => IExp i Bool + -> ProgramT i m () + -> ProgramT i 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 b t e = conditional (b, t) [] (Just e) + +-------------------------------------------------------------------------------- +-- ** 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 + +-- | 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 + +-- | 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 + +-- | ... +hideSig :: Signal a -> SignalX +hideSig = SignalX + +-------------------------------------------------------------------------------- diff --git a/src/Language/Embedded/Hardware/Expression.hs b/src/Language/Embedded/Hardware/Expression.hs new file mode 100644 --- /dev/null +++ b/src/Language/Embedded/Hardware/Expression.hs @@ -0,0 +1,9 @@ +module Language.Embedded.Hardware.Expression + ( HExp + , HType + , module Language.Embedded.Hardware.Expression.Frontend + ) where + +import Language.Embedded.Hardware.Expression.Syntax (HExp, HType) +import Language.Embedded.Hardware.Expression.Frontend +import Language.Embedded.Hardware.Expression.Backend.VHDL () diff --git a/src/Language/Embedded/Hardware/Expression/Backend/VHDL.hs b/src/Language/Embedded/Hardware/Expression/Backend/VHDL.hs new file mode 100644 --- /dev/null +++ b/src/Language/Embedded/Hardware/Expression/Backend/VHDL.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Language.Embedded.Hardware.Expression.Backend.VHDL where + +import Language.Syntactic +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.Represent +import Language.Embedded.Hardware.Expression.Hoist (Kind) +import Language.Embedded.Hardware.Interface +import qualified Language.Embedded.Hardware.Expression.Hoist as Hoist + +import Language.Embedded.VHDL (VHDL) +import qualified Language.VHDL as VHDL +import qualified Language.Embedded.VHDL as VHDL + +import Control.Applicative + +-------------------------------------------------------------------------------- +-- * Compilation and evaluation of hardware expressions for VHDL. +-------------------------------------------------------------------------------- + +instance EvaluateExp HExp + where + litE = value + evalE = evalHExp + +evalHExp :: HExp a -> a +evalHExp = go . unHExp + where + go :: AST T sig -> Denotation sig + go (Sym (T s)) = evalSym s + go (f :$ a) = go f $ go a + +-------------------------------------------------------------------------------- + +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)) + +compHExp :: forall a. HType 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 + + 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] + | Just Xor <- prj expr = go $ \a b -> VHDL.xor [a, b] + | Just Xnor <- prj expr = go $ \a b -> VHDL.xnor [a, b] + | Just Nand <- prj expr = go VHDL.nand + | Just Nor <- prj expr = go VHDL.nor + where + go :: (VHDL.Relation -> VHDL.Relation -> VHDL.Expression) -> VHDL Kind + go f = do + 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 + | Just Lt <- prj relate = go VHDL.lt + | Just Lte <- prj relate = go VHDL.lte + | Just Gt <- prj relate = go VHDL.gt + | Just Gte <- prj relate = go VHDL.gte + where + go :: (VHDL.ShiftExpression -> VHDL.ShiftExpression -> VHDL.Relation) -> VHDL Kind + go f = do + 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 + | Just Sla <- prj shift = go $ VHDL.sla + | Just Sra <- prj shift = go $ VHDL.sra + | Just Rol <- prj shift = go $ VHDL.rol + | Just Ror <- prj shift = go $ VHDL.ror + where + go :: (VHDL.SimpleExpression -> VHDL.SimpleExpression -> VHDL.ShiftExpression) -> VHDL Kind + go f = do + 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 + | Just Cat <- prj simple = go VHDL.cat + where + go :: ([VHDL.Term] -> VHDL.SimpleExpression) -> VHDL Kind + go f = do + x' <- Hoist.lift <$> compLoop x + y' <- Hoist.lift <$> compLoop y + return $ Hoist.Si $ f [x', y'] + compDomain simple (x :* _) + | Just Neg <- prj simple = do + x' <- Hoist.lift <$> compLoop x + return $ Hoist.Si $ VHDL.neg x' + | 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 + | Just Mod <- prj term = go VHDL.mod + | Just Rem <- prj term = go VHDL.rem + where + go :: ([VHDL.Factor] -> VHDL.Term) -> VHDL Kind + go f = do + 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 + y' <- Hoist.lift <$> compLoop y + return $ Hoist.F $ VHDL.exp x' y' + compDomain factor (x :* _) + | Just Abs <- prj factor = do + x' <- Hoist.lift <$> compLoop x + return $ Hoist.F $ VHDL.abs x' + | 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 (Conversion f) <- prj primary = do + t <- compHType (undefined :: HExp (DenResult sig)) + x' <- Hoist.lift <$> compLoop x + return $ Hoist.P $ VHDL.cast t x' + 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 (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 + +-------------------------------------------------------------------------------- diff --git a/src/Language/Embedded/Hardware/Expression/Frontend.hs b/src/Language/Embedded/Hardware/Expression/Frontend.hs new file mode 100644 --- /dev/null +++ b/src/Language/Embedded/Hardware/Expression/Frontend.hs @@ -0,0 +1,139 @@ +module Language.Embedded.Hardware.Expression.Frontend where + +import Language.Embedded.Hardware.Expression.Syntax + +import Data.Bits (Bits) + +import Prelude hiding (not, and, or, abs, rem, div, mod, exp) +import qualified Prelude as P + +-------------------------------------------------------------------------------- +-- * +-------------------------------------------------------------------------------- + +-- | Lifts a typed value to an expression. +value :: HType a => a -> HExp a +value i = sugarT (Literal i) + +-- | 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) + +-------------------------------------------------------------------------------- + +true, false :: HExp Bool +true = value True +false = value False + +-- 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 + +-- 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 +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 + +-- 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 + +-- multiplying operators +mul :: (HType a, Num a) => HExp a -> HExp a -> HExp a +mul = sugarT Mul + +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 + +abs :: (HType a, Num a) => HExp a -> HExp a +abs = sugarT Abs + +not :: HExp Bool -> HExp Bool +not = sugarT Not + +-------------------------------------------------------------------------------- + +instance (HType a, Eq a) => Eq (HExp a) + where + (==) = error "VHDL: equality checking is not supported" + +instance (HType a, Ord a) => Ord (HExp a) + where + compare = error "VHDL: compare is not supported" + max = error "VHDL: max is not supported" + min = error "VHDL: min is not supported" + +instance (HType a, Bounded a) => Bounded (HExp a) + where + minBound = value minBound + maxBound = value maxBound + +instance (HType a, Enum a) => Enum (HExp a) + where + toEnum = error "VHDL: toEnum is not supported" + fromEnum = error "VHDL: fromEnum is not supported" + +instance (HType a, Real a) => Real (HExp a) + where + toRational = error "VHDL: toRational is not supported" + +instance (HType a, Num a) => Num (HExp a) + where + fromInteger = value . fromInteger + (+) = add + (-) = sub + (*) = mul + abs = abs + signum = error "VHDL: signum is not supported" + +instance (HType a, Integral a) => Integral (HExp 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 (HType a, Fractional a) => Fractional (HExp a) + where + (/) = error "VHDL: floating point division is not _yet_ supported" + recip = (/) (value 1) + fromRational = error "VHDL: fromRational is not supported" + +-------------------------------------------------------------------------------- diff --git a/src/Language/Embedded/Hardware/Expression/Hoist.hs b/src/Language/Embedded/Hardware/Expression/Hoist.hs new file mode 100644 --- /dev/null +++ b/src/Language/Embedded/Hardware/Expression/Hoist.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} + +module Language.Embedded.Hardware.Expression.Hoist where + +import Language.VHDL ( + Expression (..) + , Relation (..) + , ShiftExpression (..) + , SimpleExpression (..) + , Term (..) + , Factor (..) + , Primary (..) + , Identifier (..) + ) + +-------------------------------------------------------------------------------- +-- * Lifting & hoisting of expressions. +-------------------------------------------------------------------------------- + +-- | Lift an expression into another. +class Lift a b where + lift :: a -> b + +-- base: we are the correct level. +instance {-# OVERLAPPING #-} Lift a a where + lift = id + +-- step: we can get to the correct level by stepping through the types. +instance {-# OVERLAPPABLE #-} (Hoist a, Lift (Next a) b) => Lift a b where + lift = lift . hoist + +-------------------------------------------------------------------------------- + +-- | Hoist an expression up one level. +class Hoist a where + type Next a :: * + hoist :: a -> Next a + +instance Hoist Primary where + type Next Primary = Factor + hoist p = FacPrim p Nothing + +instance Hoist Factor where + type Next Factor = Term + hoist f = Term f [] + +instance Hoist Term where + type Next Term = SimpleExpression + hoist t = SimpleExpression Nothing t [] + +instance Hoist SimpleExpression where + type Next SimpleExpression = ShiftExpression + hoist si = ShiftExpression si Nothing + +instance Hoist ShiftExpression where + type Next ShiftExpression = Relation + hoist sh = Relation sh Nothing + +instance Hoist Relation where + type Next Relation = Expression + hoist r = ENand r Nothing + +instance Hoist Expression where + type Next Expression = Primary + hoist e = PrimExp e + +-------------------------------------------------------------------------------- +-- ... I need to replace these ... +-------------------------------------------------------------------------------- + +-- | A collection of hardware expression types. +-- +-- Going from "Expr a -> VHDL.Exp" means recovering the structure of VHDL's +-- expressions since VHDL.Exp isn't a single type. Hence the need for "Kind". +data Kind = E Expression | R Relation | Sh ShiftExpression | Si SimpleExpression + | T Term | F Factor | P Primary + +instance Lift Kind Expression where + lift (E e) = lift e + lift (R r) = lift r + lift (Sh sh) = lift sh + lift (Si si) = lift si + lift (T t) = lift t + lift (F f) = lift f + lift (P p) = lift p + +instance Lift Kind Relation where + lift (E e) = lift e + lift (R r) = lift r + lift (Sh sh) = lift sh + lift (Si si) = lift si + lift (T t) = lift t + lift (F f) = lift f + lift (P p) = lift p + +instance Lift Kind ShiftExpression where + lift (E e) = lift e + lift (R r) = lift r + lift (Sh sh) = lift sh + lift (Si si) = lift si + lift (T t) = lift t + lift (F f) = lift f + lift (P p) = lift p + +instance Lift Kind SimpleExpression where + lift (E e) = lift e + lift (R r) = lift r + lift (Sh sh) = lift sh + lift (Si si) = lift si + lift (T t) = lift t + lift (F f) = lift f + lift (P p) = lift p + +instance Lift Kind Term where + lift (E e) = lift e + lift (R r) = lift r + lift (Sh sh) = lift sh + lift (Si si) = lift si + lift (T t) = lift t + lift (F f) = lift f + lift (P p) = lift p + +instance Lift Kind Factor where + lift (E e) = lift e + lift (R r) = lift r + lift (Sh sh) = lift sh + lift (Si si) = lift si + lift (T t) = lift t + lift (F f) = lift f + lift (P p) = lift p + +instance Lift Kind Primary where + lift (E e) = lift e + lift (R r) = lift r + lift (Sh sh) = lift sh + lift (Si si) = lift si + lift (T t) = lift t + lift (F f) = lift f + lift (P p) = lift p + +-------------------------------------------------------------------------------- diff --git a/src/Language/Embedded/Hardware/Expression/Represent.hs b/src/Language/Embedded/Hardware/Expression/Represent.hs new file mode 100644 --- /dev/null +++ b/src/Language/Embedded/Hardware/Expression/Represent.hs @@ -0,0 +1,141 @@ +module Language.Embedded.Hardware.Expression.Represent + ( Tagged (..) + , Rep (..) + ) where + +import Language.Embedded.VHDL (VHDL) +import Language.Embedded.VHDL.Monad (newLibrary, newImport) +import Language.Embedded.VHDL.Monad.Type + +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 + +-------------------------------------------------------------------------------- +-- * Representable types (until I come up with a solution free of VHDL stuff). +-------------------------------------------------------------------------------- + +-- | 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 newLibrary "IEEE" + newImport "IEEE.std_logic_1164" + +declareNumeric :: VHDL () +declareNumeric = + do newLibrary "IEEE" + newImport "IEEE.std_logic_1164" + 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 -> 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 "" + +-------------------------------------------------------------------------------- diff --git a/src/Language/Embedded/Hardware/Expression/Syntax.hs b/src/Language/Embedded/Hardware/Expression/Syntax.hs new file mode 100644 --- /dev/null +++ b/src/Language/Embedded/Hardware/Expression/Syntax.hs @@ -0,0 +1,375 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} + +module Language.Embedded.Hardware.Expression.Syntax where + +import Language.Syntactic +import Language.Syntactic.Functional (Denotation, Eval(..), EvalEnv) + +import Language.Embedded.Hardware.Command +import Language.Embedded.Hardware.Interface +import Language.Embedded.Hardware.Expression.Represent + +import Data.Bits (Bits) +import Data.Typeable (Typeable) +import qualified Data.Bits as Bits + +-------------------------------------------------------------------------------- +-- * 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 + :+: Term + :+: Factor + :+: Primary + +-- | Typed expressions. +data T sig + where + T :: HType (DenResult sig) => { unT :: Dom sig } -> T sig + +-- | Specialized sugarSym for T. +sugarT + :: ( Signature (SmartSig fi), sub :<: Dom + , T :<: SmartSym fi + , SyntacticN f fi + , SmartFun (SmartSym fi) (SmartSig fi) ~ fi + , HType (DenResult (SmartSig fi))) + => sub (SmartSig fi) + -> f +sugarT sym = sugarSym (T $ inj sym) + +-- | Hardware expressions. +newtype HExp a = HExp { unHExp :: ASTF T a } + +instance Syntactic (HExp a) + where + type Domain (HExp a) = T + type Internal (HExp a) = a + + desugar = unHExp + sugar = HExp + +-------------------------------------------------------------------------------- +-- ** Syntax. + +-- | Logical expressions. +data Expression sig + where + 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) + +-- | Relational expressions. +data Relational sig + where + Eq :: (HType a) => Relational (a :-> a :-> Full Bool) + Neq :: (HType a) => Relational (a :-> a :-> Full Bool) + Lt :: (HType a, Ord a) => Relational (a :-> a :-> Full Bool) + Lte :: (HType a, Ord a) => Relational (a :-> a :-> Full Bool) + Gt :: (HType a, Ord a) => Relational (a :-> a :-> Full Bool) + Gte :: (HType a, Ord a) => Relational (a :-> a :-> Full Bool) + +-- | Bit vector expressions. +data Shift 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) + +-- | Numerical expressions. +data Simple 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) + +-- | Integral expressions. +data Term sig + where + Mul :: (HType a, Num a) => Term (a :-> a :-> Full a) + Div :: (HType a, Integral a) => Term (a :-> a :-> Full a) + Mod :: (HType a, Integral a) => Term (a :-> a :-> Full a) + Rem :: (HType a, Integral a) => Term (a :-> a :-> Full a) + +-- | ... +data Factor sig + where + Exp :: (HType a, Num a, HType b, Integral b) => Factor (a :-> b :-> Full a) + Abs :: (HType a, Num a) => Factor (a :-> Full a) + Not :: Factor (Bool :-> Full Bool) + +-- | ... +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]) + 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) + +-------------------------------------------------------------------------------- +-- ** Syntactic instances. + +instance CompArrayIx HExp + +instance Equality T + where + equal (T s) (T t) = equal s t + hash (T s) = hash s + +instance StringTree T + where + stringTreeSym as (T s) = stringTreeSym as (T s) + +instance Symbol T + where + symSig (T s) = symSig s + +instance Render T + where + renderSym (T s) = renderSym s + renderArgs as (T s) = renderArgs as s + +instance Equality Expression +instance StringTree Expression + +instance Symbol Expression + where + symSig And = signature + symSig Or = signature + symSig Xor = signature + symSig Xnor = signature + symSig Nand = signature + symSig Nor = signature + +instance Render Expression + where + renderSym And = "and" + renderSym Or = "or" + renderSym Xor = "xor" + renderSym Xnor = "xnor" + renderSym Nand = "nand" + renderSym Nor = "nor" + +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) + +instance EvalEnv Expression env + +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 + +instance Equality Shift +instance StringTree Shift + +instance Symbol Shift + where + symSig Sll = signature + symSig Srl = signature + symSig Sla = signature + symSig Sra = signature + symSig Rol = signature + symSig Ror = signature + +instance Render Shift + where + renderSym Sll = "sll" + renderSym Srl = "srl" + renderSym Sla = "sla" + renderSym Sra = "sra" + renderSym Rol = "rol" + renderSym Ror = "ror" + +instance Eval Shift + where + evalSym Sll = \x i -> Bits.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] + 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) + +instance EvalEnv Shift env + +instance Equality Simple +instance StringTree Simple + +instance Symbol Simple + where + symSig Neg = signature + symSig Pos = signature + symSig Add = signature + symSig Sub = signature + symSig Cat = signature + +instance Render Simple + where + renderSym Neg = "(-)" + renderSym Pos = "id" + renderSym Add = "(+)" + renderSym Sub = "(-)" + renderSym Cat = "(&)" + +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 + +instance Equality Term +instance StringTree Term + +instance Symbol Term + where + symSig Mul = signature + symSig Div = signature + symSig Mod = signature + symSig Rem = signature + +instance Render Term + where + renderSym Mul = "(*)" + renderSym Div = "(/)" + renderSym Mod = "(%)" + renderSym Rem = "rem" + +instance Eval Term + where + evalSym Mul = (*) + evalSym Div = Prelude.div + evalSym Mod = Prelude.mod + evalSym Rem = Prelude.rem + +instance EvalEnv Term env + +instance Equality Factor +instance StringTree Factor + +instance Symbol Factor + where + symSig Exp = signature + symSig Abs = signature + symSig Not = signature + +instance Render Factor + where + renderSym Exp = "(**)" + renderSym Abs = "abs" + renderSym Not = "not" + +instance Eval Factor + where + evalSym Exp = (^) + evalSym Abs = Prelude.abs + evalSym Not = Prelude.not + +instance EvalEnv Factor env + +instance Equality Primary +instance StringTree Primary + +instance Symbol Primary + where + symSig (Name _) = signature + symSig (Literal _) = signature + symSig (Aggregate _) = undefined + symSig (Function _ _) = signature + symSig (Qualified _) = signature + symSig (Conversion _) = signature + symSig (Allocator) = signature + +instance Render Primary + where + renderSym (Name _) = "name" + renderSym (Literal _) = "lit" + renderSym (Aggregate _) = "agg" + renderSym (Function _ _) = "fun" + renderSym (Qualified _) = "qual" + renderSym (Conversion _) = "conv" + renderSym (Allocator) = "alloc" + +instance Eval Primary + where + evalSym (Name _) = error "cannot eval open names!" + evalSym (Literal i) = i + evalSym (Aggregate xs) = xs + evalSym (Function _ f) = f + evalSym (Qualified _) = error "todo: eval qualified names." + evalSym (Conversion f) = f + evalSym (Allocator) = undefined + +instance EvalEnv Primary env + +-------------------------------------------------------------------------------- diff --git a/src/Language/Embedded/Hardware/Interface.hs b/src/Language/Embedded/Hardware/Interface.hs new file mode 100644 --- /dev/null +++ b/src/Language/Embedded/Hardware/Interface.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeFamilies #-} + +module Language.Embedded.Hardware.Interface where + +import Language.VHDL (Expression) +import Language.Embedded.VHDL (VHDL, Type) +import Data.Constraint + +-------------------------------------------------------------------------------- +-- * 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 + +-- | General interface for evaluating expressions. +class EvaluateExp exp + where + -- | Literal expressions. + litE :: PredicateExp exp a => a -> exp a + + -- | Evaluation of (closed) expressions. + evalE :: PredicateExp exp a => exp a -> a + +-- | General interface for compiling expressions. +class 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 + +-------------------------------------------------------------------------------- diff --git a/src/Language/Embedded/VHDL.hs b/src/Language/Embedded/VHDL.hs new file mode 100644 --- /dev/null +++ b/src/Language/Embedded/VHDL.hs @@ -0,0 +1,12 @@ +module Language.Embedded.VHDL + ( module VHDL + , module Language.Embedded.VHDL.Monad + , module Language.Embedded.VHDL.Monad.Expression + , module Language.Embedded.VHDL.Monad.Type + ) where + +import Language.VHDL as VHDL (Identifier(..), Mode(..), Direction(..)) + +import Language.Embedded.VHDL.Monad +import Language.Embedded.VHDL.Monad.Expression +import Language.Embedded.VHDL.Monad.Type diff --git a/src/Language/Embedded/VHDL/Monad.hs b/src/Language/Embedded/VHDL/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Language/Embedded/VHDL/Monad.hs @@ -0,0 +1,674 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} + +-- used for the Ord/Eq inst. of XDeclaration etc. +{-# LANGUAGE StandaloneDeriving #-} + +module Language.Embedded.VHDL.Monad ( + VHDL + , VHDLT + , VHDLEnv + , emptyVHDLEnv + + -- ^ run + , runVHDLT, runVHDL, execVHDLT, execVHDL + + -- ^ pretty printing + , prettyVHDL, prettyVHDLT + + -- ^ name generation + , freshUnique, newSym, newLabel + + -- ^ imports + , newLibrary, newImport + + -- ^ declarations + , addPort, addGeneric + , addGlobal, addLocal + , addConcurrent, addSequential + , addType, addComponent + + -- ^ statements + , inProcess, inFor, inWhile, inConditional, inCase + + -- ^ structures + , entity, architecture, package + + -- ^ common things + , interfaceConstant, interfaceSignal, interfaceVariable + , declareConstant, declareSignal, declareVariable + , assignSignal, assignSignalS, assignVariable, assignArray + + , unconstrainedArray, constrainedArray + ) where + +import Language.VHDL + +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.Maybe (catMaybes) +import Data.Foldable (toList) +import Data.Functor (fmap) +import Data.List (groupBy) +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 Prelude hiding (null, not, abs, exp, rem, mod, div, and, or) +import qualified Prelude as P + +-------------------------------------------------------------------------------- +-- * VHDL monad and environment. +-------------------------------------------------------------------------------- + +-- | Code generation state +data VHDLEnv = VHDLEnv + { _unique :: !Integer + , _designs :: [DesignUnit] + , _context :: Set ContextItem + , _types :: Set TypeDeclaration + , _ports :: [InterfaceDeclaration] + , _generics :: [InterfaceDeclaration] + , _components :: Set ComponentDeclaration + , _global :: [BlockDeclarativeItem] + , _local :: [BlockDeclarativeItem] + , _concurrent :: [ConcurrentStatement] + , _sequential :: [SequentialStatement] + } + +-- | Initial state during code generation +emptyVHDLEnv = VHDLEnv + { _unique = 0 + , _designs = [] + , _context = Set.empty + , _types = Set.empty + , _components = Set.empty + , _ports = [] + , _generics = [] + , _global = [] + , _local = [] + , _concurrent = [] + , _sequential = [] + } + +-------------------------------------------------------------------------------- +-- * VHDL monad. + +-- | Type constraints for the VHDL monads +type MonadV m = (Functor m, Applicative m, Monad m, MonadState VHDLEnv m) + +-- | VHDL code generation monad +type VHDL = VHDLT Identity + +-- | VHDL code genreation monad transformer. +newtype VHDLT m a = VHDLT { unVGenT :: StateT VHDLEnv m a } + deriving ( Functor + , Applicative + , Monad + , MonadState VHDLEnv + , MonadIO + ) + +-- | Run the VHDL code generation monad transformer. +runVHDLT :: Monad m => VHDLT m a -> VHDLEnv -> m (a, VHDLEnv) +runVHDLT m = CMS.runStateT (unVGenT m) + +-- | -- | Executes the VHDL code generation monad transformer, returning only its final state. +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 + +-------------------------------------------------------------------------------- +-- ** Generating uniques. + +-- | 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. +newSym :: MonadV m => m Identifier +newSym = do i <- freshUnique; return (Ident $ 'v' : show i) + +-- | Generates a fresh and unique label. +newLabel :: MonadV m => m Label +newLabel = do i <- freshUnique; return (Ident $ 'l' : show i) + +-------------------------------------------------------------------------------- +-- ** VHDL environment updates. + +-- | Adds a new library import to the context. +newLibrary :: MonadV m => String -> m () +newLibrary l = CMS.modify $ \s -> s { _context = Set.insert item (_context s) } + where + item :: ContextItem + item = ContextLibrary (LibraryClause (LogicalNameList [Ident l])) + +-- | Adds a new library use clause to the context (with an .ALL suffix by default). +newImport :: MonadV m => String -> m () +newImport i = CMS.modify $ \s -> s { _context = Set.insert item (_context s) } + where + 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) } + +-- | Adds a component declaration. +addComponent :: MonadV m => ComponentDeclaration -> m () +addComponent c = CMS.modify $ \s -> s { _components = Set.insert c (_components s) } + +-- | Adds a global declaration. +addGlobal :: MonadV m => BlockDeclarativeItem -> m () +addGlobal g = CMS.modify $ \s -> s { _global = g : (_global s) } + +-- | Adds a local declaration. +addLocal :: MonadV m => BlockDeclarativeItem -> m () +addLocal l = CMS.modify $ \s -> s { _local = l : (_local s) } + +-- | Adds a concurrent statement. +addConcurrent :: MonadV m => ConcurrentStatement -> m () +addConcurrent con = CMS.modify $ \s -> s { _concurrent = con : (_concurrent s) } + +-- | Adds a sequential statement. +addSequential :: MonadV m => SequentialStatement -> m () +addSequential seq = CMS.modify $ \s -> s { _sequential = seq : (_sequential s) } + +-------------------------------------------------------------------------------- +-- * Concurrent and sequential statements +-------------------------------------------------------------------------------- + +-- | 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 + oldSequential <- CMS.gets _sequential + CMS.modify $ \e -> e { _local = [] + , _sequential = [] } + result <- m + newLocals <- reverse <$> CMS.gets _local + newSequential <- reverse <$> CMS.gets _sequential + CMS.modify $ \e -> e { _local = oldLocals + , _sequential = oldSequential } + return ( result + , ProcessStatement + (Just l) -- label + (False) -- postponed + (sensitivity) -- sensitivitylist + (translate $ merge $ newLocals) -- declarativepart + (newSequential)) -- statementpart + where + sensitivity | P.null is = Nothing + | otherwise = Just $ SensitivityList $ fmap NSimple is + +-- | Run program in for loop. +inFor :: MonadV m => Identifier -> Range -> m () -> m (LoopStatement) +inFor i r m = + do oldSequential <- CMS.gets _sequential + CMS.modify $ \e -> e { _sequential = [] } + m + newSequential <- reverse <$> CMS.gets _sequential + CMS.modify $ \e -> e { _sequential = oldSequential } + return $ + LoopStatement + (Nothing) + (Just (IterFor (ParameterSpecification + (i) + (DRRange r)))) + (newSequential) + +-- | Run program inside while loop. +inWhile :: MonadV m => Expression -> m () -> m (LoopStatement) +inWhile cont m = + do oldSequential <- CMS.gets _sequential + CMS.modify $ \e -> e { _sequential = [] } + m + newSequential <- reverse <$> CMS.gets _sequential + CMS.modify $ \e -> e { _sequential = oldSequential } + return $ + LoopStatement + (Nothing) + (Just (IterWhile cont)) + (newSequential) + +-- | Conditional statements. +inConditional :: MonadV m => (Condition, m ()) -> [(Condition, m ())] -> m () -> m (IfStatement) +inConditional (c, m) os e = + do let (cs, ns) = unzip os + oldSequential <- CMS.gets _sequential + CMS.modify $ \e -> e { _sequential = [] } + m' <- contain m + ns' <- mapM contain ns + e' <- contain e + CMS.modify $ \e -> e { _sequential = oldSequential } + return $ + IfStatement + (Nothing) + (c, m') + (zip cs ns') + (maybeList e') + where + maybeList :: [SequentialStatement] -> Maybe [SequentialStatement] + maybeList xs + | P.null xs = Nothing + | otherwise = Just xs + +-- | Case statements. +inCase :: MonadV m => Expression -> [(Choices, m ())] -> m (CaseStatement) +inCase e choices = + 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 } + 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 + +-------------------------------------------------------------------------------- +-- * Design units +-------------------------------------------------------------------------------- + +-- ... design unit with context +addDesign :: MonadV m => LibraryUnit -> m () +addDesign lib = + do ctxt <- CMS.gets _context + dsig <- CMS.gets _designs + let item = DesignUnit (ContextClause (Set.toList ctxt)) lib + CMS.modify $ \s -> s { _designs = 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)} + +-------------------------------------------------------------------------------- +-- ** Architectures + +-- | 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 <- reverse <$> CMS.gets _global + newConcurrent <- reverse <$> CMS.gets _concurrent + addDesign_ $ LibrarySecondary $ SecondaryArchitecture $ + ArchitectureBody + (name) + (NSimple entity) + (merge newGlobal) + (newConcurrent) + CMS.modify $ \e -> e { _global = oldGlobal + , _concurrent = oldConcurrent } + return result + +-------------------------------------------------------------------------------- +-- ** 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 <- reverse <$> CMS.gets _ports + newGenerics <- reverse <$> CMS.gets _generics + addDesign $ LibraryPrimary $ PrimaryEntity $ + EntityDeclaration + (name) + (EntityHeader + (GenericClause <$> maybeNull newGenerics) + (PortClause <$> maybeNull newPorts)) + ([]) + (Nothing) + CMS.modify $ \e -> e { _ports = oldPorts + , _generics = oldGenerics } + return result + where + maybeNull :: [InterfaceDeclaration] -> Maybe InterfaceList + maybeNull [] = Nothing + maybeNull xs = Just $ InterfaceList $ merge xs + +-------------------------------------------------------------------------------- +-- ** Packages + +-- | Declares a package with the given name by consuming all type declarations +-- produced by running the monadic action. +package :: MonadV m => String -> m a -> m a +package name m = + do oldTypes <- CMS.gets _types + CMS.modify $ \e -> e { _types = Set.empty } + result <- m + newTypes <- CMS.gets _types + addDesign $ LibraryPrimary $ PrimaryPackage $ + PackageDeclaration + (Ident name) + (fmap PHDIType $ Set.toList newTypes) + CMS.modify $ \e -> e { _types = oldTypes } + return result + +-------------------------------------------------------------------------------- +-- * Pretty printing VHDL programs +-------------------------------------------------------------------------------- + +-- | Runs the VHDL monad and pretty prints its resulting VHDL program. +prettyVHDL :: VHDL a -> Doc +prettyVHDL = CMI.runIdentity . prettyVHDLT + +-- | Runs the VHDL monad transformer and pretty prints its resulting VHDL program. +prettyVHDLT :: Monad m => VHDLT m a -> m Doc +prettyVHDLT m = prettyVEnv <$> execVHDLT m emptyVHDLEnv + +-------------------------------------------------------------------------------- + +-- | Pretty print a VHDL environment. +-- +-- *** Shouldn't use revers to fix ordering issues! Pair architectures/bodies +-- with their respective entities. +prettyVEnv :: VHDLEnv -> Doc +prettyVEnv env = pp (DesignFile $ types ++ archi) + where + 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 TypeDeclaration -> [DesignUnit] +designTypes set + | Set.null set = [] + | otherwise = _designs . snd $ runVHDL pack emptyVHDLEnv + 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 } + +-------------------------------------------------------------------------------- +-- * Common things +-------------------------------------------------------------------------------- + +-------------------------------------------------------------------------------- +-- ** Ports/Generic declarations + +interfaceConstant :: Identifier -> SubtypeIndication -> Maybe Expression -> InterfaceDeclaration +interfaceConstant i t e = InterfaceConstantDeclaration [i] t e + +interfaceSignal :: Identifier -> Mode -> SubtypeIndication -> Maybe Expression -> InterfaceDeclaration +interfaceSignal i m t e = 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 + +-------------------------------------------------------------------------------- +-- ** 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)) + +-------------------------------------------------------------------------------- +-- ** 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 + +declareVariable :: Identifier -> SubtypeIndication -> Maybe Expression -> BlockDeclarativeItem +declareVariable i t e = BDIShared $ VariableDeclaration False [i] t e + +-------------------------------------------------------------------------------- +-- ** Assign Signal/Variable. + +assignSignal :: Identifier -> Expression -> ConcurrentStatement +assignSignal i e = ConSignalAss $ CSASCond Nothing False $ + ConditionalSignalAssignment + (TargetName (NSimple i)) + (Options False Nothing) + (ConditionalWaveforms + ([]) + ( WaveElem [WaveEExp e Nothing] + , Nothing)) + +assignSignalS :: Identifier -> Expression -> SequentialStatement +assignSignalS i e = SSignalAss $ + SignalAssignmentStatement + (Nothing) + (TargetName (NSimple i)) + (Nothing) + (WaveElem [WaveEExp e 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]) + +-------------------------------------------------------------------------------- +-- Some helper classes and their instances +-------------------------------------------------------------------------------- +-- +-- I use BlockDeclarativeItem to represent all declarative items, which means we +-- have to translate them over to their correct VHDL kind when generating an AST + +class Merge a + where + -- group two items if this holds + group :: a -> a -> Bool + + -- merge in this way + reduce :: [a] -> a + + merge :: [a] -> [a] + merge = fmap reduce . groupBy group + +instance Merge BlockDeclarativeItem + where + group l r = setBlockIds l [] == setBlockIds r [] + reduce bs@(b:_) = setBlockIds b $ concatMap getBlockIds bs + +instance Merge InterfaceDeclaration + where + group l r = l { idecl_identifier_list = [] } == r { idecl_identifier_list = [] } + reduce (x:xs) = x { idecl_identifier_list = ids x ++ concatMap ids xs } + where ids = idecl_identifier_list + +-------------------------------------------------------------------------------- + +setBlockIds :: BlockDeclarativeItem -> [Identifier] -> BlockDeclarativeItem +setBlockIds (BDIConstant c) is = BDIConstant $ c { const_identifier_list = is } +setBlockIds (BDISignal s) is = BDISignal $ s { signal_identifier_list = is } +setBlockIds (BDIShared v) is = BDIShared $ v { var_identifier_list = is } +setBlockIds (BDIFile f) is = BDIFile $ f { fd_identifier_list = is } +setBlockIds x _ = x + +getBlockIds :: BlockDeclarativeItem -> [Identifier] +getBlockIds (BDIConstant c) = const_identifier_list c +getBlockIds (BDISignal s) = signal_identifier_list s +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. + +deriving instance Ord ContextItem +deriving instance Ord LibraryClause +deriving instance Ord LogicalNameList +deriving instance Ord UseClause + +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 + +deriving instance Ord IncompleteTypeDeclaration + +instance Ord ComponentDeclaration + where + compare l r = compare (comp_identifier l) (comp_identifier r) + +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" + +deriving instance Ord RangeConstraint + +instance Ord Range + where + compare (RSimple a b c) (RSimple x y z) = + case compare a x of + GT -> GT + LT -> LT + EQ -> case compare b y of + GT -> GT + LT -> LT + EQ -> case compare c z of + GT -> GT + LT -> LT + EQ -> EQ + compare _ _ = error "Ord not supported for attribute ranges" + +deriving instance Ord Direction +deriving instance Ord Expression +deriving instance Ord Relation +deriving instance Ord ShiftExpression +deriving instance Ord SimpleExpression +deriving instance Ord Term +deriving instance Ord Factor + +instance Ord Primary + where + compare (PrimName a) (PrimName x) = compare a x + +deriving instance Ord LogicalOperator +deriving instance Ord RelationalOperator +deriving instance Ord ShiftOperator +deriving instance Ord AddingOperator +deriving instance Ord Sign +deriving instance Ord MultiplyingOperator +deriving instance Ord MiscellaneousOperator +deriving instance Ord Identifier + +instance Ord Name + where + compare (NSimple a) (NSimple x) = compare a x + compare (NSelect a) (NSelect x) = compare a x + compare (NIndex a) (NIndex x) = compare a x + compare (NSlice a) (NSlice x) = compare a x + compare (NAttr a) (NAttr x) = compare a x + +deriving instance Ord StringLiteral +deriving instance Ord SelectedName + +instance Ord Suffix + where + compare (SSimple a) (SSimple x) = compare a x + compare (SChar a) (SChar x) = compare a x + compare (SAll) (SAll) = EQ + compare _ _ = error "Ord not supported for operator symbols" + +deriving instance Ord CharacterLiteral +deriving instance Ord IndexedName +deriving instance Ord SliceName +deriving instance Ord DiscreteRange + +instance Ord Prefix + where + compare (PName a) (PName x) = compare a x + compare _ _ = error "Ord not supported for function names" + +deriving instance Ord AttributeName +deriving instance Ord Signature + +-------------------------------------------------------------------------------- diff --git a/src/Language/Embedded/VHDL/Monad/Expression.hs b/src/Language/Embedded/VHDL/Monad/Expression.hs new file mode 100644 --- /dev/null +++ b/src/Language/Embedded/VHDL/Monad/Expression.hs @@ -0,0 +1,167 @@ +module Language.Embedded.VHDL.Monad.Expression + ( and, or, xor, xnor, nand, nor + , eq, neq, lt, lte, gt, gte + , sll, srl, sla, sra, rol, ror + , add, sub, cat, neg + , mul, div, mod, rem + , exp, abs, not + , name, string, indexed, selected, slice + , lit, null + , aggregate, associate + , function + , qualified + , cast + , resize + , range, downto, to + ) where + +import Language.VHDL + +import Prelude hiding (and, or, div, mod, rem, exp, abs, not, null) + +-------------------------------------------------------------------------------- +-- * Expressions and their sub-layers. +-------------------------------------------------------------------------------- + +relation :: RelationalOperator -> ShiftExpression -> ShiftExpression -> Relation +relation r a b = Relation a (Just (r, b)) + +shiftexp :: ShiftOperator -> SimpleExpression -> SimpleExpression -> ShiftExpression +shiftexp s a b = ShiftExpression a (Just (s, b)) + +simplexp :: Maybe Sign -> AddingOperator -> [Term] -> SimpleExpression +simplexp s o (a:as) = SimpleExpression s a (fmap ((,) o) as) + +term :: MultiplyingOperator -> [Factor] -> Term +term o (a:as) = Term a (fmap ((,) o) as) + +-------------------------------------------------------------------------------- +-- ** Expressions + +and, or, xor, xnor :: [Relation] -> Expression +and = EAnd +or = EOr +xor = EXor +xnor = EXnor + +nand, nor :: Relation -> Relation -> Expression +nand a b = ENand a (Just b) +nor a b = ENor a (Just b) + +-------------------------------------------------------------------------------- +-- ** Relations + +eq, neq, lt, lte, gt, gte :: ShiftExpression -> ShiftExpression -> Relation +eq = relation Eq +neq = relation Neq +lt = relation Lt +lte = relation Lte +gt = relation Gt +gte = relation Gte + +-------------------------------------------------------------------------------- +-- ** Shift Expressions + +sll, srl, sla, sra, rol, ror :: SimpleExpression -> SimpleExpression -> ShiftExpression +sll = shiftexp Sll +srl = shiftexp Srl +sla = shiftexp Sla +sra = shiftexp Sra +rol = shiftexp Rol +ror = shiftexp Ror + +-------------------------------------------------------------------------------- +-- ** Simple Expressions + +add, sub, cat :: [Term] -> SimpleExpression +add = simplexp Nothing Plus +sub = simplexp Nothing Minus +cat = simplexp Nothing Concat + +neg :: Term -> SimpleExpression +neg = simplexp (Just Negation) Plus . (: []) + +-------------------------------------------------------------------------------- +-- ** Terms + +mul, div, mod, rem :: [Factor] -> Term +mul = term Times +div = term Div +mod = term Mod +rem = term Rem + +-------------------------------------------------------------------------------- +-- ** Factors + +exp :: Primary -> Primary -> Factor +exp a b = FacPrim a (Just b) + +abs, not :: Primary -> Factor +abs = FacAbs +not = FacNot + +-------------------------------------------------------------------------------- +-- ** Primaries + +-- names +name :: String -> Primary +name = PrimName . NSimple . Ident + +string :: String -> Primary +string = PrimLit . LitString . SLit + +indexed :: Identifier -> Expression -> Name +indexed i l = NIndex $ IndexedName (PName $ NSimple i) [l] + +selected :: Identifier -> Identifier -> Primary +selected p s = PrimName $ NSelect $ SelectedName (PName $ NSimple p) (SSimple s) + +slice :: Identifier -> (SimpleExpression, SimpleExpression) -> Primary +slice i (f, t) = PrimName $ NSlice $ SliceName (PName $ NSimple i) (DRRange $ RSimple f DownTo t) + +-- literals +lit :: Show i => i -> Primary +lit = PrimLit . LitNum . NLitPhysical . PhysicalLiteral Nothing . NSimple . Ident . show + +null :: Primary +null = PrimLit LitNull + +-- aggregates +aggregate :: [Expression] -> Primary +aggregate = PrimAgg . Aggregate . fmap (ElementAssociation Nothing) + +associate :: [(Maybe Choices, Expression)] -> Primary +associate es = PrimAgg $ Aggregate $ map (uncurry ElementAssociation) es + +-- function calls +function :: Identifier -> [Expression] -> Primary +function i [] = PrimFun $ FunctionCall (NSimple i) Nothing +function i xs = PrimFun + . FunctionCall (NSimple i) . Just . AssociationList + $ fmap (AssociationElement Nothing . APDesignator . ADExpression) xs + +-- qualified expressions +qualified :: SubtypeIndication -> Expression -> Primary +qualified (SubtypeIndication _ t _) = PrimQual . QualExp t + +-- type conversions +cast :: SubtypeIndication -> Expression -> Primary +cast (SubtypeIndication _ t _) = PrimTCon . TypeConversion t + +-------------------------------------------------------------------------------- +-- ** 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 + +range :: SimpleExpression -> Direction -> SimpleExpression -> Range +range = RSimple + +downto, to :: Direction +downto = DownTo +to = To + +-------------------------------------------------------------------------------- diff --git a/src/Language/Embedded/VHDL/Monad/Type.hs b/src/Language/Embedded/VHDL/Monad/Type.hs new file mode 100644 --- /dev/null +++ b/src/Language/Embedded/VHDL/Monad/Type.hs @@ -0,0 +1,60 @@ +module Language.Embedded.VHDL.Monad.Type + ( Type + , Kind(..) + + , std_logic + , signed8, signed16, signed32, signed64 + , usigned8, usigned16, usigned32, usigned64 + ) where + +import Language.VHDL + +import Language.Embedded.VHDL.Monad.Expression (lit) + +-------------------------------------------------------------------------------- +-- * VHDL 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 numbers. + +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 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 .. +--------------------------------------------------------------------------------