packages feed

hardware-edsl 0.1.0.1 → 0.1.2

raw patch · 18 files changed

+3299/−967 lines, 18 filesdep +deepseqdep ~basedep ~language-vhdldep ~operational-alacarte

Dependencies added: deepseq

Dependency ranges changed: base, language-vhdl, operational-alacarte, syntactic

Files

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