clash 0.1.2.5 → 0.1.3.0
raw patch · 15 files changed
+597/−164 lines, 15 filesdep −data-accessor-transformers
Dependencies removed: data-accessor-transformers
Files
- CLasH/HardwareTypes.hs +190/−28
- CLasH/Normalize.hs +44/−8
- CLasH/Normalize/NormalizeTools.hs +9/−3
- CLasH/Translator.hs +3/−3
- CLasH/Translator/TranslatorTypes.hs +5/−3
- CLasH/Utils.hs +2/−2
- CLasH/Utils/Core/BinderTools.hs +3/−3
- CLasH/Utils/Core/CoreTools.hs +171/−25
- CLasH/VHDL.hs +1/−1
- CLasH/VHDL/Constants.hs +7/−0
- CLasH/VHDL/Generate.hs +104/−71
- CLasH/VHDL/Testbench.hs +7/−4
- CLasH/VHDL/VHDLTools.hs +9/−10
- Data/Accessor/Monad/Trans/StrictState.hs +38/−0
- clash.cabal +4/−3
CLasH/HardwareTypes.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE TemplateHaskell, DeriveDataTypeable #-}+{-# LANGUAGE TemplateHaskell, DeriveDataTypeable, RecordWildCards #-} module CLasH.HardwareTypes ( module Types@@ -22,9 +22,27 @@ , RAM , MemState , blockRAM- , Stat+ , Clock(..)+ , pulseLength+ , Comp , simulate , (^^^)+ , comp+ , bv2u+ , u2bv+ , s2bv+ , bv2s+ , SimulatorSession+ , SimulationState+ , simulateM+ , run+ , runWithClock+ , setInput+ , setAndRun+ , getOutput+ , showOutput+ , assert+ , report ) where import Types@@ -34,6 +52,7 @@ import Data.Param.Signed import Data.Param.Unsigned import Data.Bits hiding (shiftL,shiftR)+import qualified Data.Bits as B import Language.Haskell.TH.Lift import Data.Typeable@@ -43,7 +62,15 @@ import Control.Monad.Fix (mfix) import qualified Prelude as P import Prelude hiding (id, (.))+import qualified Data.Set as Set +import qualified Data.List as L++import qualified Control.Monad.Trans.State.Strict as State+import qualified Data.Accessor.Template+import qualified Data.Accessor.Monad.Trans.StrictState as MonadState+import qualified Control.Monad.Trans.Class as Trans+ import CLasH.Translator.Annotations newtype State s = State s deriving (P.Show)@@ -93,38 +120,173 @@ else mem +-- ==============================+-- = Integer/Vector Conversions =+-- ==============================+-- ===============+-- = Conversions =+-- ===============+bv2u :: NaturalT nT => Vector nT Bit -> Unsigned nT+bv2u bv = vfoldl (\a b -> let+ a' = B.shiftL a 1+ in+ if b == High then+ a' + 1+ else+ a'+ ) 0 bv++bv2s :: NaturalT nT => Vector nT Bit -> Signed nT+bv2s bv = vfoldl (\a b -> let+ a' = B.shiftL a 1+ in+ if b == High then+ a' + 1+ else+ a'+ ) 0 bv++u2bv :: NaturalT nT => Unsigned nT -> Vector nT Bit+u2bv u = vreverse . (vmap fst) . (vgenerate f) $ (Low,(0,u))+ where+ f (_,(n,u)) = if testBit u n then (High,(n+1,u)) else (Low,(n+1,u))+ +s2bv :: NaturalT nT => Signed nT -> Vector nT Bit+s2bv u = vreverse . (vmap fst) . (vgenerate f) $ (Low,(0,u))+ where+ f (_,(n,u)) = if testBit u n then (High,(n+1,u)) else (Low,(n+1,u))++-- ==========+-- = Clocks =+-- ==========+data Clock = ClockUp Int | ClockDown Int+ deriving (Eq,Ord,Show)++pulseLength (ClockUp i) = i+pulseLength (ClockDown i) = i+ -- ================== -- = Automata Arrow = -- ==================-newtype Stat i o = A {- apply :: i -> (o, Stat i o)-}+data Comp i o = C {+ domain :: Set.Set Clock + , exec :: Clock -> i -> (o, Comp i o)+ } -instance Category Stat where- (A g) . (A f) = A (\b -> let (c,f') = f b- (d,g') = g c- in (d, g'.f'))- id = arr id+instance Category Comp where+ k@(C { domain = cdA, exec = g}) . (C {domain = cdB, exec = f}) =+ C { domain = Set.union cdA cdB+ , exec = \clk b -> let (c,f') = f clk b+ (d,g') = g clk c+ in (d, g'.f')+ }+ id = arr id -instance Arrow Stat where- arr f = A (\b -> (f b, arr f))- first (A f) = A (\(b,d) -> let (c,f') = f b- in ((c,d), first f'))-instance ArrowLoop Stat where- loop (A f) = A (\i -> let ((c,d), f') = f (i, d)- in (c, loop f'))+instance Arrow Comp where+ arr f = C { domain = Set.empty+ , exec = \clk b -> (f b, arr f)+ }+ first af = af { exec = \clk (b,d) -> let (c,f') = (exec af) clk b+ in ((c,d), first f')+ }+instance ArrowLoop Comp where+ loop af = af { exec = (\clk i -> let ((c,d), f') = (exec af) clk (i, d)+ in (c, loop f'))+ } -liftS :: s -> (State s -> i -> (State s,o)) -> Stat i o-liftS init f = A applyS- where applyS = \i -> let (State s,o) = f (State init) i- in (o, liftS s f)+comp :: (State s -> i -> (State s,o)) -> s -> Clock -> Comp i o+comp f initS clk = C { domain = Set.singleton clk+ , exec = \clk' i -> let (State s,o) = f (State initS) i+ s' | clk == clk' = s+ | otherwise = initS+ in (o, comp f s' clk) + } -simulate :: Stat b c -> [b] -> [c]-simulate (A f) [] = []-simulate (A f) (b:bs) = let (c,f') = f b in (c : simulate f' bs)+liftS :: s -> (State s -> i -> (State s,o)) -> Comp i o+liftS init f = C {domain = Set.singleton (ClockUp 1), exec = applyS}+ where applyS = \clk i -> let (State s,o) = f (State init) i+ in (o, liftS s f) -arrState :: s -> (State s -> i -> (State s,o)) -> Stat i o-arrState = liftS+(^^^) :: (State s -> i -> (State s,o)) -> s -> Comp i o+(^^^) f init = liftS init f -(^^^) :: (State s -> i -> (State s,o)) -> s -> Stat i o-(^^^) f init = arrState init f+simulate :: Comp b c -> [b] -> [c]+simulate af inps = if (Set.size $ domain af) < 2 then+ simulate' af (Set.findMin $ domain af) inps+ else+ error "Use simulateM for components with more than 1 clock"++simulate' :: Comp b c -> Clock -> [b] -> [c]+simulate' af _ [] = []+simulate' (C {exec = f}) clk (i:is) = let (o,f') = f clk i in (o : simulate' f' clk is)++data SimulationState i o = SimulationState {+ clockTicks_ :: ([Clock],[Int])+ , input_ :: i+ , hw_ :: Comp i o+ }+ +Data.Accessor.Template.deriveAccessors ''SimulationState++type SimulatorSession i o a = State.StateT (SimulationState i o) IO a++simulateM :: Comp i o -> SimulatorSession i o () -> IO ()+simulateM hw testbench = State.evalStateT testbench initSession+ where+ initSession = SimulationState ((Set.toList $ domain hw), (replicate (Set.size $ domain hw) 1)) (error "CLasH.simulateM: initial simulation input not set") hw+++run :: Int -> SimulatorSession i o ()+run n = do+ (clocks,ticks) <- MonadState.get clockTicks+ let (pulses,newTicks) = runClocks (clocks,ticks) n+ MonadState.modify clockTicks (\(a,b) -> (a,newTicks))+ curInp <- MonadState.get input+ MonadState.modify hw (snd . (run' pulses curInp))++runWithClock :: Clock -> Int -> SimulatorSession i o ()+runWithClock clk n = do+ curInp <- MonadState.get input+ MonadState.modify hw (snd . (run' (replicate n clk) curInp))+ +run' [] _ arch = ([],arch)+run' (clk:clks) i (C {..}) = let (c,f') = clk `seq` exec clk i+ (cs,f'') = f' `seq` run' clks i f'+ in f'' `seq` (c:cs,f'')++setInput :: i -> SimulatorSession i o ()+setInput i = MonadState.set input i++setAndRun :: i -> Int -> SimulatorSession i o ()+setAndRun inp n = (setInput inp) >> (run n)++getOutput :: SimulatorSession i o o+getOutput = do+ curInp <- MonadState.get input+ arch <- MonadState.get hw+ return $ head $ fst $ run' [ClockUp (-1)] curInp arch++showOutput :: (Show o) => SimulatorSession i o ()+showOutput = do+ outp <- getOutput+ Trans.lift $ putStrLn $ show outp+ +assert :: (o -> Bool) -> String -> SimulatorSession i o ()+assert test msg = do+ outp <- getOutput+ if (test outp) then return () else Trans.lift $ putStrLn msg++report :: String -> SimulatorSession i o ()+report msg = Trans.lift $ putStrLn msg++runClocks :: ([Clock], [Int]) -> Int -> ([Clock],[Int])+runClocks (clocks, ticks) 0 = ([],ticks)+runClocks (clocks, ticks) delta = ((concat curClocks) ++ nextClocks,nextTicks)+ where+ (curClocks,curTicks) = unzip $ zipWith clockTick clocks ticks+ (nextClocks,nextTicks) = runClocks (clocks,curTicks) (delta-1)++clockTick (ClockUp i) i' = if i == i' then ([ClockUp i] ,1) else ([],i'+1)+clockTick (ClockDown i) i' = if i == i' then ([ClockDown i],1) else ([],i'+1)++
CLasH/Normalize.hs view
@@ -12,7 +12,7 @@ import qualified Control.Monad.Trans.Class as Trans import qualified Control.Monad as Monad import qualified Control.Monad.Trans.Writer as Writer-import qualified Data.Accessor.Monad.Trans.State as MonadState+import qualified Data.Accessor.Monad.Trans.StrictState as MonadState import qualified Data.Monoid as Monoid import qualified Data.Map as Map @@ -171,13 +171,15 @@ -- initial state with this clone. We also need to replace the -- original reference with a reference to this clone initSmap <- Trans.lift $ MonadState.get tsInitStates- case (CoreSyn.collectArgs body, Map.lookup f initSmap) of- ((Var inlineF, inlineFargs), Just initState) -> do+ clocksMap <- Trans.lift $ MonadState.get tsClocks+ case (CoreSyn.collectArgs body, Map.lookup f initSmap, Map.lookup f clocksMap) of+ ((Var inlineF, inlineFargs), Just initState, Just clock) -> do -- Get the body belong to the applied function and clone it inlineFbody <- Trans.lift $ getGlobalBind inlineF newInlineF <- Trans.lift $ mkFunction inlineF (Maybe.fromJust inlineFbody)- -- Associate the initial state with the cloned function+ -- Associate the initial state and clock with the cloned function Trans.lift $ MonadState.modify tsInitStates (\ismap -> Map.insert (newInlineF) initState ismap)+ Trans.lift $ MonadState.modify tsClocks (\clocksMap -> Map.insert (newInlineF) clock clocksMap) -- Replace original reference with a reference to the cloned function let newBody = mkApps (Var newInlineF) inlineFargs newBodyUniqued <- Trans.lift $ genUniques newBody@@ -694,13 +696,22 @@ let newbody = MkCore.mkCoreLams newparams (MkCore.mkCoreApps body oldargs) -- Create a new function with the same name but a new body newf <- Trans.lift $ mkFunction f newbody+ -- Copy initial statee if it has one Trans.lift $ MonadState.modify tsInitStates (\ismap -> let init_state_maybe = Map.lookup f ismap in case init_state_maybe of Nothing -> ismap- Just init_state -> Map.insert (newf) init_state ismap)+ Just init_state -> Map.insert newf init_state ismap)+ -- Copy clock if it has one+ Trans.lift $ MonadState.modify tsClocks (\clockMap ->+ let + clockMaybe = Map.lookup f clockMap + in+ case clockMaybe of+ Nothing -> clockMap+ Just clock -> Map.insert newf clock clockMap) -- Replace the original application with one of the new function to the -- new arguments. change $ MkCore.mkCoreApps (Var newf) newargs@@ -1037,10 +1048,11 @@ -- To: -- \(s::s) (i::a) -> f i arrowLiftSExtract :: Transform-arrowLiftSExtract c expr@(App _ _) | isLift (appliedF, alreadyMappedArgs) = do+arrowLiftSExtract c expr@(App _ _) | isLift (appliedF, alreadyMappedArgs) || isComponent (appliedF, alreadyMappedArgs) = do -- Collect the lifted function and the initial state let (Var liftS) = appliedF- let [realfun, initvalue] = get_val_args (Var.varType liftS) alreadyMappedArgs+ let valArgs = get_val_args (Var.varType liftS) alreadyMappedArgs+ let [realfun, initvalue] = take 2 valArgs -- TODO: All of this looks/is hacked! Needs rethinking and rewriting (realfunBndr, realfunBody) <- case realfun of (Var realfunBndr) -> do@@ -1059,22 +1071,46 @@ let [arg1Ty,arg2Ty] = (fst . Type.splitFunTys . CoreUtils.exprType) realfun id1 <- Trans.lift $ mkInternalVar "param" arg1Ty id2 <- Trans.lift $ mkInternalVar "param" arg2Ty- -- Associate initial value with the cloned functions+ -- Associate initial value with the cloned function initbndr <- case initvalue of (Var initvalueBndr) -> do initBndrMaybe <- Trans.lift $ getGlobalBind initvalueBndr case initBndrMaybe of (Just a) -> return initvalueBndr+ -- FIXME: This is definately broken, we're making a top-level binder that+ -- rerefences a local variable from another function... What we should do+ -- is copy the value that's referenced by the local variable! Nothing -> do let body = Var initvalueBndr initId <- Trans.lift $ mkBinderFor body ("init" ++ Name.getOccString realfunBndr) Trans.lift $ addGlobalBind initId body return initId otherwise -> do+ -- FIXME: This is also broken! In case a local variable is referenced anywhere+ -- in the expression that we're making a top-level binder, we'll again be making+ -- a reference that the new top-level binder can not find. We should check if+ -- there are any references to local variables, and copy their values! initId <- Trans.lift $ mkBinderFor initvalue ("init" ++ Name.getOccString realfunBndr) Trans.lift $ addGlobalBind initId initvalue return initId Trans.lift $ MonadState.modify tsInitStates (Map.insert realfunBndr initbndr)+ -- Associate clock with the clone function+ clockEdge <- if isLift (appliedF, alreadyMappedArgs) then+ return (True,1)+ else do+ let clock = last valArgs+ case clock of+ (Var clockBndr) -> do+ exprMaybe <- Trans.lift $ getGlobalBind clockBndr+ let clockExpr = Maybe.fromMaybe (error $ "Normalize.arrowLiftSExtract: could not find clock for: " ++ pprString realfun) exprMaybe+ let (Var appliedFunBndr, [litArg]) = collectArgs clockExpr+ clockLit <- Trans.lift $ getIntegerLiteral litArg+ case (Name.getOccString appliedFunBndr) of+ "ClockUp" -> return (True,clockLit)+ "ClockDown" -> return (False,clockLit)+ otherwise -> do+ error $ "Normalize.arrowLiftSExtract: Do now know how to handle clock:" ++ show clock+ Trans.lift $ MonadState.modify tsClocks (Map.insert realfunBndr clockEdge) -- Return the extracted expression change (Lam id1 (Lam id2 (App (App realfunBody (Var id1)) (Var id2)))) where
CLasH/Normalize/NormalizeTools.hs view
@@ -9,7 +9,7 @@ import qualified Control.Monad as Monad import qualified Control.Monad.Trans.Writer as Writer import qualified Control.Monad.Trans.Class as Trans-import qualified Data.Accessor.Monad.Trans.State as MonadState+import qualified Data.Accessor.Monad.Trans.StrictState as MonadState -- GHC API import CoreSyn@@ -278,7 +278,7 @@ where ty = Id.idType bndr res = case Type.splitTyConApp_maybe ty of- Just (tycon, args) -> Name.getOccString (TyCon.tyConName tycon) == "Stat"+ Just (tycon, args) -> Name.getOccString (TyCon.tyConName tycon) == "Comp" Nothing -> False isArrowE ::@@ -288,7 +288,7 @@ where ty = CoreUtils.exprType expr res = case Type.splitTyConApp_maybe ty of- Just (tycon, args) -> (Name.getOccString (TyCon.tyConName tycon)) == "Stat"+ Just (tycon, args) -> (Name.getOccString (TyCon.tyConName tycon)) == "Comp" Nothing -> False isLift ::@@ -296,6 +296,12 @@ -> Bool isLift ((Var bndr), args) = (Name.getOccString bndr) == "^^^" && (length $ CoreTools.get_val_args (Var.varType bndr) args) == 2 isLift _ = False++isComponent ::+ (CoreExpr, [CoreExpr])+ -> Bool+isComponent ((Var bndr), args) = (Name.getOccString bndr) == "comp" && (length $ CoreTools.get_val_args (Var.varType bndr) args) == 3+isComponent _ = False isArrHooks :: (CoreExpr, [CoreExpr])
CLasH/Translator.hs view
@@ -8,9 +8,9 @@ import qualified Maybe import qualified Monad import qualified System.FilePath as FilePath-import qualified Control.Monad.Trans.State as State+import qualified Control.Monad.Trans.State.Strict as State import Text.PrettyPrint.HughesPJ (render)-import Data.Accessor.Monad.Trans.State+import Data.Accessor.Monad.Trans.StrictState import qualified Data.Map as Map import qualified Data.Time.Clock as Clock import Debug.Trace@@ -114,7 +114,7 @@ uniqSupply <- UniqSupply.mkSplitUniqSupply 'z' let init_typedecls = map (mktydecl . Maybe.fromJust . snd) $ Map.toList builtin_types let init_typestate = TypeState builtin_types init_typedecls Map.empty Map.empty env- let init_state = TranslatorState uniqSupply init_typestate Map.empty Map.empty 0 Map.empty Map.empty Map.empty 0 Map.empty+ let init_state = TranslatorState uniqSupply init_typestate Map.empty Map.empty 0 Map.empty Map.empty Map.empty 0 Map.empty Map.empty return $ State.evalState session init_state -- | Prepares the directory for writing VHDL files. This means creating the
CLasH/Translator/TranslatorTypes.hs view
@@ -6,10 +6,10 @@ module CLasH.Translator.TranslatorTypes where -- Standard modules-import qualified Control.Monad.Trans.State as State+import qualified Control.Monad.Trans.State.Strict as State import qualified Data.Map as Map import qualified Data.Accessor.Template-import qualified Data.Accessor.Monad.Trans.State as MonadState+import qualified Data.Accessor.Monad.Trans.StrictState as MonadState -- GHC API import qualified GHC@@ -17,6 +17,7 @@ import qualified Type import qualified HscTypes import qualified UniqSupply+import qualified TyCon -- VHDL Imports import qualified Language.VHDL.AST as AST@@ -72,7 +73,7 @@ -- VHDLId of the function and the function body. type TypeFunMap = Map.Map (HType, String) (AST.VHDLId, AST.SubProgBody) -type TfpIntMap = Map.Map OrdType Int+type TfpIntMap = Map.Map TyCon.TyCon Int -- A substate that deals with type generation data TypeState = TypeState { -- | A map of Core type -> VHDL Type@@ -102,6 +103,7 @@ , tsInitStates_ :: Map.Map CoreSyn.CoreBndr CoreSyn.CoreBndr , tsTransformCounter_ :: Int -- ^ How many transformations were applied? , tsArrows_ :: Map.Map CoreSyn.CoreBndr CoreSyn.CoreBndr+ , tsClocks_ :: Map.Map CoreSyn.CoreBndr (Bool,Integer) } -- Derive accessors
CLasH/Utils.hs view
@@ -3,10 +3,10 @@ -- Standard Imports import qualified Maybe import Data.Accessor-import qualified Data.Accessor.Monad.Trans.State as MonadState+import qualified Data.Accessor.Monad.Trans.StrictState as MonadState import qualified Data.Map as Map import qualified Control.Monad as Monad-import qualified Control.Monad.Trans.State as State+import qualified Control.Monad.Trans.State.Strict as State import qualified Debug.Trace as Trace -- Make a caching version of a stateful computatation.
CLasH/Utils/Core/BinderTools.hs view
@@ -4,7 +4,7 @@ module CLasH.Utils.Core.BinderTools where -- Standard modules-import qualified Data.Accessor.Monad.Trans.State as MonadState+import qualified Data.Accessor.Monad.Trans.StrictState as MonadState -- GHC API import qualified CoreSyn@@ -37,7 +37,7 @@ mkInternalVar :: String -> Type.Type -> TranslatorSession Var.Var mkInternalVar str ty = do uniq <- mkUnique- let occname = OccName.mkVarOcc (str ++ show uniq)+ let occname = OccName.mkVarOcc str let name = Name.mkInternalName uniq occname SrcLoc.noSrcSpan return $ Var.mkLocalVar IdInfo.VanillaId name ty IdInfo.vanillaIdInfo @@ -48,7 +48,7 @@ mkTypeVar :: String -> Type.Kind -> TranslatorSession Var.Var mkTypeVar str kind = do uniq <- mkUnique- let occname = OccName.mkVarOcc (str ++ show uniq)+ let occname = OccName.mkVarOcc str let name = Name.mkInternalName uniq occname SrcLoc.noSrcSpan return $ Var.mkTyVar name kind
CLasH/Utils/Core/CoreTools.hs view
@@ -10,7 +10,7 @@ import qualified List import qualified System.IO.Unsafe import qualified Data.Map as Map-import qualified Data.Accessor.Monad.Trans.State as MonadState+import qualified Data.Accessor.Monad.Trans.StrictState as MonadState -- GHC API import qualified GHC@@ -35,7 +35,9 @@ import qualified Literal import qualified MkCore import qualified VarEnv+import qualified VarSet import qualified Outputable+import qualified TypeRep -- Local imports import CLasH.Translator.TranslatorTypes@@ -52,35 +54,178 @@ -- | Evaluate a core Type representing type level int from the tfp -- library to a real int. Checks if the type really is a Dec type and -- caches the results.+-- tfp_to_int :: Type.Type -> TypeSession Int+-- tfp_to_int ty = do+-- hscenv <- MonadState.get tsHscEnv+-- let norm_ty = normalize_tfp_int hscenv ty+-- case Type.splitTyConApp_maybe norm_ty of+-- Just (tycon, args) -> do+-- let name = Name.getOccString (TyCon.tyConName tycon)+-- case name of+-- "Dec" ->+-- tfp_to_int' ty+-- otherwise -> do+-- return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty))+-- Nothing -> return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty)) tfp_to_int :: Type.Type -> TypeSession Int-tfp_to_int ty = do- hscenv <- MonadState.get tsHscEnv- let norm_ty = normalize_tfp_int hscenv ty- case Type.splitTyConApp_maybe norm_ty of- Just (tycon, args) -> do- let name = Name.getOccString (TyCon.tyConName tycon)- case name of- "Dec" ->- tfp_to_int' ty- otherwise -> do- return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty))- Nothing -> return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty))+tfp_to_int ty = tfp_to_int' (pprString ty ++ "\n") ty +tfp_to_int' :: String -> Type.Type -> TypeSession Int+tfp_to_int' msg ty@(TypeRep.TyConApp tycon args) = if (TyCon.isClosedSynTyCon tycon) && (null args) then do+ lens <- MonadState.get tsTfpInts+ let knownSynonymMaybe = Map.lookup tycon lens+ case knownSynonymMaybe of+ Just knownSynonym -> return knownSynonym+ Nothing -> do+ let tycon' = TyCon.synTyConType tycon+ len <- tycon' `seq` tfp_to_int' (msg ++ " > " ++ (Name.getOccString (TyCon.tyConName tycon))) $! tycon'+ len `seq` MonadState.modify tsTfpInts $! (Map.insert tycon len)+ return len+ else if (TyCon.isClosedSynTyCon tycon) then do+ let tyconNameString = Name.getOccString (TyCon.tyConName tycon)+ case tyconNameString of+ -- TODO: Add more cases for type synonyms introduced by the Renamer+ -- Especially for those cases where there are more type arguments+ -- than type variables, which will throw an error if not not caught.+ "R:IfFalseyz" -> do+ let arg = args!!1+ len <- arg `seq` tfp_to_int' (msg ++ " > " ++ tyconNameString) $! arg+ return len+ "R:IfTrueyz" -> do+ let arg = head args+ len <- arg `seq` tfp_to_int' (msg ++ " > " ++ tyconNameString) $! arg+ return len+ -- FIXME: substitution of type variables by type arguments is potentially+ -- wrong!! Check if there are cases when this is valid. If not, throw an+ -- Error if we do not know the syntycon name!+ -- FIXED: It should be valid in all cases as we are replacing type variables+ -- on the RHS of the type synonym. So no additional logic/arithmatic is needed.+ _ -> do {+ ; let { ty' = TyCon.synTyConType tycon+ ; tyvarSet = VarSet.varSetElems $ Type.tyVarsOfType ty'+ ; ty'' = let+ tysubst = if length args == length tyvarSet then+ Type.zipTopTvSubst tyvarSet args+ else+ error $ "CoreTools.tfp_to_int': TyVars(" ++ (show $ length tyvarSet) ++ ") and Args(" ++ (show $ length args) ++ + ") don't match for: " ++ tyconNameString ++ "\nContext: " ++ msg+ in+ Type.substTy tysubst ty'+ } + ; len <- (Type.seqType ty'') `seq` tfp_to_int' (msg ++ " > " ++ tyconNameString) $! ty''+ ; return len+ }+ else do+ let tyconName = pprString tycon+ let tyconNameString = Name.getOccString (TyCon.tyConName tycon)+ case tyconNameString of+ "Dec" -> do+ let arg = head args+ len <- arg `seq` tfp_to_int' (msg ++ " > " ++ tyconName) $! arg+ return len+ ":." -> do+ let arg0 = head args+ let arg1 = args!!1+ int0 <- arg0 `seq` tfp_to_int' (msg ++ " > " ++ tyconName) $! arg0+ int1 <- arg1 `seq` tfp_to_int' (msg ++ " > " ++ tyconName) $! arg1+ let len = int0 `seq` int1 `seq` int0 * 10 + int1+ return len+ "DecN" -> return 0+ "Dec0" -> return 0+ "Dec1" -> return 1+ "Dec2" -> return 2+ "Dec3" -> return 3+ "Dec4" -> return 4+ "Dec5" -> return 5+ "Dec6" -> return 6+ "Dec7" -> return 7+ "Dec8" -> return 8+ "Dec9" -> return 9+ "Succ" -> do+ let arg = head args+ int <- arg `seq` tfp_to_int' (msg ++ " > " ++ tyconName) $! arg+ let len = int `seq` int + 1+ return len+ "Pred" -> do+ let arg = head args+ int <- arg `seq` tfp_to_int' (msg ++ " > " ++ tyconName) $! arg+ let len = int `seq` int - 1+ return len+ ":+:" -> do+ let arg0 = head args+ let arg1 = args!!1+ int0 <- arg0 `seq` tfp_to_int' (msg ++ " > " ++ tyconName) $! arg0+ int1 <- arg1 `seq` tfp_to_int' (msg ++ " > " ++ tyconName) $! arg1+ let len = int0 `seq` int1 `seq` int0 + int1+ return len+ ":-:" -> do+ let arg0 = head args+ let arg1 = args!!1+ int0 <- arg0 `seq` tfp_to_int' (msg ++ " > " ++ tyconName) $! arg0+ int1 <- arg1 `seq` tfp_to_int' (msg ++ " > " ++ tyconName) $! arg1+ let len = int0 `seq` int1 `seq` int0 - int1+ return len+ ":*:" -> do+ let arg0 = head args+ let arg1 = args!!1+ int0 <- arg0 `seq` tfp_to_int' (msg ++ " > " ++ tyconName) $! arg0+ int1 <- arg1 `seq` tfp_to_int' (msg ++ " > " ++ tyconName) $! arg1+ let len = int0 `seq` int1 `seq` int0 * int1+ return len+ "Pow2" -> do+ let arg = head args+ int <- arg `seq` tfp_to_int' (msg ++ " > " ++ tyconName) $! arg+ let len = int `seq` int * int+ return len+ "Mul2" -> do+ let arg = head args+ int <- arg `seq` tfp_to_int' (msg ++ " > " ++ tyconName) $! arg+ let len = int `seq` int + int+ return len+ "Div2" -> do+ let arg = head args+ int <- arg `seq` tfp_to_int' (msg ++ " > " ++ tyconName) $! arg+ let len = int `seq` int `div` 2+ return len+ "Fac" -> do+ let arg = head args+ int <- arg `seq` tfp_to_int' (msg ++ " > " ++ tyconName) $! arg+ let fac x = if x == 0 then 1 else x * fac (x - 1)+ let len = int `seq` fac int+ return len+ "Min" -> do+ let arg0 = head args+ let arg1 = args!!1+ int0 <- arg0 `seq` tfp_to_int' (msg ++ " > " ++ tyconName) $! arg0+ int1 <- arg1 `seq` tfp_to_int' (msg ++ " > " ++ tyconName) $! arg1+ let len = int0 `seq` int1 `seq` if int0 <= int1 then int0 else int1+ return len+ "Max" -> do+ let arg0 = head args+ let arg1 = args!!1+ int0 <- arg0 `seq` tfp_to_int' (msg ++ " > " ++ tyconName) $! arg0+ int1 <- arg1 `seq` tfp_to_int' (msg ++ " > " ++ tyconName) $! arg1+ let len = int0 `seq` int1 `seq` if int0 >= int1 then int0 else int1+ return len+ _ -> error $ "CoreTools.tfp_to_int: Unknown TyCon : " ++ pprString tycon ++ "\n Context: " ++ msg+tfp_to_int' msg ty = error $ "CoreTools.tfp_to_int: Not a TyConApp: " ++ show ty ++ "\n Context: " ++ msg++ -- | Evaluate a core Type representing type level int from the tfp -- library to a real int. Caches the results. Do not use directly, use -- tfp_to_int instead.-tfp_to_int' :: Type.Type -> TypeSession Int-tfp_to_int' ty = do- lens <- MonadState.get tsTfpInts- hscenv <- MonadState.get tsHscEnv- let norm_ty = normalize_tfp_int hscenv ty- let existing_len = Map.lookup (OrdType norm_ty) lens- case existing_len of- Just len -> return len- Nothing -> do- let new_len = eval_tfp_int hscenv ty- MonadState.modify tsTfpInts (Map.insert (OrdType norm_ty) (new_len))- return new_len+-- tfp_to_int' :: Type.Type -> TypeSession Int+-- tfp_to_int' ty = do+-- lens <- MonadState.get tsTfpInts+-- hscenv <- MonadState.get tsHscEnv+-- let norm_ty = normalize_tfp_int hscenv ty+-- let existing_len = Map.lookup (OrdType norm_ty) lens+-- case existing_len of+-- Just len -> return len+-- Nothing -> do+-- let new_len = eval_tfp_int hscenv ty+-- MonadState.modify tsTfpInts (Map.insert (OrdType norm_ty) (new_len))+-- return new_len -- | Evaluate a core Type representing type level int from the tfp -- library to a real int. Do not use directly, use tfp_to_int instead.@@ -259,6 +404,7 @@ case CoreSyn.collectArgs expr of (CoreSyn.Var f, [CoreSyn.Lit (Literal.MachInt integer)]) | getFullString f == "GHC.Integer.smallInteger" -> return integer+ | getFullString f == "GHC.Types.I#" -> return integer (CoreSyn.Var f, [CoreSyn.Lit (Literal.MachInt64 integer)]) | getFullString f == "GHC.Integer.int64ToInteger" -> return integer (CoreSyn.Var f, [CoreSyn.Lit (Literal.MachWord integer)])
CLasH/VHDL.hs view
@@ -8,7 +8,7 @@ import qualified Maybe import qualified Control.Arrow as Arrow import Data.Accessor-import qualified Data.Accessor.Monad.Trans.State as MonadState+import qualified Data.Accessor.Monad.Trans.StrictState as MonadState -- VHDL Imports import qualified Language.VHDL.AST as AST
CLasH/VHDL/Constants.hs view
@@ -16,10 +16,17 @@ , negateId, minusId, fromSizedWordId, fromIntegerId, resizeWordId , resizeIntId, sizedIntId, smallIntegerId, fstId, sndId, blockRAMId , splitId, minimumId, fromRangedWordId, xorId, shiftLId , shiftRId+ , u2bvId, s2bvId, bv2sId, bv2uId ] -------------- -- Identifiers --------------++u2bvId, s2bvId, bv2sId, bv2uId :: String+u2bvId = "u2bv"+s2bvId = "s2bv"+bv2sId = "bv2s"+bv2uId = "bv2u" -- | reset and clock signal identifiers in String form resetStr, clockStr :: String
CLasH/VHDL/Generate.hs view
@@ -3,10 +3,11 @@ -- Standard modules import qualified Data.List as List import qualified Data.Map as Map+import qualified Data.Set as Set import qualified Control.Monad as Monad import qualified Maybe import qualified Data.Either as Either-import qualified Data.Accessor.Monad.Trans.State as MonadState+import qualified Data.Accessor.Monad.Trans.StrictState as MonadState -- VHDL Imports import qualified Language.VHDL.AST as AST@@ -52,7 +53,9 @@ count <- MonadState.get tsEntityCounter let vhdl_id = mkVHDLBasicId $ varToString fname ++ "Component_" ++ show count MonadState.set tsEntityCounter (count + 1)- let ent_decl = createEntityAST vhdl_id args' res'+ clocks <- MonadState.get tsClocks+ let clockList = (Set.toList . Set.fromList . Map.elems) clocks+ let ent_decl = createEntityAST vhdl_id clockList args' res' let signature = Entity vhdl_id args' res' ent_decl return signature where@@ -79,19 +82,21 @@ -- | Create the VHDL AST for an entity createEntityAST :: AST.VHDLId -- ^ The name of the function+ -> [(Bool,Integer)] -- ^ Clocks -> [Port] -- ^ The entity's arguments -> Maybe Port -- ^ The entity's result -> AST.EntityDec -- ^ The entity with the ent_decl filled in as well -createEntityAST vhdl_id args res =+createEntityAST vhdl_id clocks args res = AST.EntityDec vhdl_id ports where -- Create a basic Id, since VHDL doesn't grok filenames with extended Ids. ports = map (mkIfaceSigDec AST.In) args ++ (Maybe.maybeToList res_port)- ++ [clk_port,resetn_port]- -- Add a clk port if we have state- clk_port = AST.IfaceSigDec clockId AST.In std_logicTM+ ++ clkPorts+ ++ [resetn_port]+ -- TODO: Only add a clk ports if we have state+ clkPorts = map ((\a -> AST.IfaceSigDec a AST.In std_logicTM) . AST.unsafeVHDLBasicId . ("clock" ++) . show . snd) clocks resetn_port = AST.IfaceSigDec resetId AST.In std_logicTM res_port = fmap (mkIfaceSigDec AST.Out) res @@ -130,7 +135,10 @@ let (statementss, used_entitiess) = unzip sms -- Get initial state, if it's there initSmap <- MonadState.get tsInitStates- let init_state = Map.lookup (fname) initSmap+ let init_state = Map.lookup fname initSmap+ -- Get clock domains, if they're there+ clocksMap <- MonadState.get tsClocks+ let clockEdge = Map.lookup fname clocksMap -- Create a state proc, if needed (state_proc, resbndr) <- case (Maybe.catMaybes in_state_maybes, Maybe.catMaybes out_state_maybes, init_state) of ([in_state], [out_state], Nothing) -> do @@ -141,7 +149,7 @@ ([in_state], [out_state], Just resetval) -> do nonEmpty <- hasNonEmptyType "" in_state if nonEmpty - then mkStateProcSm (in_state, out_state, resetval) + then mkStateProcSm (in_state, out_state, resetval, Maybe.fromMaybe (error $ "Generate.getArchitecture: No clock found for: " ++ show fname ++ ", listed clocks: " ++ show clocksMap) clockEdge) else do nonEmptyReset <- hasNonEmptyType "" resetval if nonEmptyReset@@ -178,9 +186,9 @@ return ((Nothing, Nothing), sms) mkStateProcSm :: - (CoreSyn.CoreBndr, CoreSyn.CoreBndr, CoreSyn.CoreBndr) -- ^ The current state, new state and reset variables+ (CoreSyn.CoreBndr, CoreSyn.CoreBndr, CoreSyn.CoreBndr, (Bool, Integer)) -- ^ The current state, new state, reset variables, and clock domain -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr]) -- ^ The resulting statements-mkStateProcSm (old, new, res) = do+mkStateProcSm (old, new, res, (edge, period)) = do let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString res type_mark_old_maybe <- MonadState.lift tsType $ vhdlTy error_msg (Var.varType old) let type_mark_old = Maybe.fromMaybe @@ -201,16 +209,20 @@ let blocklabel = mkVHDLBasicId "state" let statelabel = mkVHDLBasicId "stateupdate" let rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"+ let falling_edge = AST.NSimple $ mkVHDLBasicId "falling_edge" let wform = AST.Wform [AST.WformElem (AST.PrimName $ varToVHDLName new) Nothing] let clk_assign = AST.SigAssign (varToVHDLName old) wform- let rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clockId)]+ let clockId = AST.unsafeVHDLBasicId ("clock" ++ show period)+ let clkFlank = AST.PrimFCall $ AST.FCall (if edge then rising_edge else falling_edge) [Nothing AST.:=>: (AST.ADName $ AST.NSimple clockId)] let resetn_is_low = (AST.PrimName $ AST.NSimple resetId) AST.:=: (AST.PrimLit "'0'") signature <- getEntity res let entity_id = ent_id signature let reslabel = "resetval_" ++ ((prettyShow . varToVHDLName) res) let portmaps = mkAssocElems [] (AST.NSimple resvalid) signature- let reset_statement = mkComponentInst reslabel entity_id portmaps- let clk_statement = [AST.ElseIf rising_edge_clk [clk_assign]]+ clocksMap <- MonadState.get tsClocks+ let clockDomains = ((map snd) . Set.toList . Set.fromList . Map.elems) clocksMap+ let reset_statement = mkComponentInst reslabel entity_id clockDomains portmaps+ let clk_statement = [AST.ElseIf clkFlank [clk_assign]] let statement = AST.IfSm resetn_is_low [res_assign] clk_statement Nothing let stateupdate = AST.CSPSm $ AST.ProcSm statelabel [clockId,resetId,resvalid] [statement] let block = AST.CSBSm $ AST.BlockSm blocklabel [] (AST.PMapAspect []) [resvaldec] [reset_statement,stateupdate]@@ -874,6 +886,17 @@ } ; return [out_assign] }++genCopyn :: BuiltinBuilder +genCopyn = genNoInsts genCopyn'+genCopyn' :: (Either CoreSyn.CoreBndr AST.VHDLName ) -> CoreSyn.CoreBndr -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -> TranslatorSession [AST.ConcSm]+genCopyn' (Left res) f [arg0,(arg,argType)] = do {+ ; [arg'] <- argsToVHDLExprs [arg]+ ; let { resExpr = AST.Aggregate [AST.ElemAssoc (Just AST.Others) arg']+ ; out_assign = mkUncondAssign (Left res) resExpr+ }+ ; return [out_assign]+ } genConcat :: BuiltinBuilder genConcat = genNoInsts genConcat'@@ -1027,6 +1050,7 @@ return [AST.CSBSm block] where ram_id = mkVHDLBasicId "ram"+ clockId = AST.unsafeVHDLBasicId "clock1" mkUpdateProcSm :: AST.ConcSm mkUpdateProcSm = AST.CSPSm $ AST.ProcSm proclabel [clockId] [statement] where@@ -1082,6 +1106,56 @@ ; return $ (genExprFCall2 (mkVHDLBasicId "shift_right") (arg1, (genExprFCall (mkVHDLBasicId toIntegerId) arg2))) } +genI2bv :: BuiltinBuilder+genI2bv = genNoInsts $ genExprArgs $ genExprRes genI2bv'+genI2bv' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [(AST.Expr, Type.Type)] -> TranslatorSession AST.Expr+genI2bv' (Left res) f [(arg1,_)] = do {+ ; let resTy = Var.varType res+ ; let errorMsg = "\nGenerate.genS2bv': Can not construct vector type: " ++ pprString resTy + -- TODO: Handle Nothing+ ; Just tmpVhdlTy <- MonadState.lift tsType $ vhdlTy errorMsg resTy+ ; return $ (genExprFCall (mkVHDLBasicId $ AST.fromVHDLId tmpVhdlTy) arg1)+ }++genBV2u :: BuiltinBuilder+genBV2u = genNoInsts $ genExprArgs $ genExprRes genBV2u'+genBV2u' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [(AST.Expr, Type.Type)] -> TranslatorSession AST.Expr+genBV2u' (Left res) f [(arg1,_)] = do {+ ; return $ (genExprFCall (mkVHDLBasicId "unsigned") arg1)+ }++genBV2s :: BuiltinBuilder+genBV2s = genNoInsts $ genExprArgs $ genExprRes genBV2s'+genBV2s' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [(AST.Expr, Type.Type)] -> TranslatorSession AST.Expr+genBV2s' (Left res) f [(arg1,_)] = do {+ ; return $ (genExprFCall (mkVHDLBasicId "signed") arg1)+ }++genTake :: BuiltinBuilder+genTake = genNoInsts $ genExprRes genTake'+genTake' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -> TranslatorSession AST.Expr+genTake' res f [(arg1,arg1Type),(arg2,arg2Type)] = do {+ ; literal <- MonadState.lift tsType $ tfp_to_int arg1Type+ ; arg2expr <- argToVHDLExpr arg2+ ; let (AST.PrimName arg2name) = Maybe.fromMaybe (error $ "Generate.genTake': Expected variable reference, but found:" ++ either pprString show arg2) arg2expr+ ; arg2len <- MonadState.lift tsType $ tfp_to_int $ tfvec_len_ty arg2Type+ ; let minLit = min literal arg2len+ ; let takeVal = AST.PrimName (AST.NSlice (AST.SliceName arg2name (AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (minLit - 1)))))+ ; return takeVal+ }++genDrop :: BuiltinBuilder+genDrop = genNoInsts $ genExprRes genDrop'+genDrop' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -> TranslatorSession AST.Expr+genDrop' res f [(arg1,arg1Type),(arg2,arg2Type)] = do {+ ; literal <- MonadState.lift tsType $ tfp_to_int arg1Type+ ; arg2expr <- argToVHDLExpr arg2+ ; let (AST.PrimName arg2name) = Maybe.fromMaybe (error $ "Generate.genDrop': Expected variable reference, but found:" ++ either pprString show arg2) arg2expr+ ; arg2len <- MonadState.lift tsType $ tfp_to_int $ tfvec_len_ty arg2Type+ ; let dropVal = AST.PrimName (AST.NSlice (AST.SliceName arg2name (AST.ToRange (AST.PrimLit $ show literal) (AST.PrimLit $ show (arg2len - 1)))))+ ; return dropVal+ }+ ----------------------------------------------------------------------------- -- Function to generate VHDL for applications -----------------------------------------------------------------------------@@ -1191,9 +1265,11 @@ let entity_id = ent_id signature -- TODO: Using show here isn't really pretty, but we'll need some -- unique-ish value...- let label = "comp_ins_" ++ (either show prettyShow) dst+ let label = "comp_ins_" ++ (either (prettyShow . varToVHDLName) prettyShow) dst let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature- return ([mkComponentInst label entity_id portmaps], [f])+ clocksMap <- MonadState.get tsClocks+ let clockDomains = ((map snd) . Set.toList . Set.fromList . Map.elems) clocksMap+ return ([mkComponentInst label entity_id clockDomains portmaps], [f]) else -- Not a top level binder, so this must be a local variable reference. -- It should have a representable type (and thus, no arguments) and a@@ -1232,7 +1308,9 @@ -- unique-ish value... let label = "comp_ins_" ++ (either (prettyShow . varToVHDLName) prettyShow) dst let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature- return ([mkComponentInst label entity_id portmaps], [f])+ clocksMap <- MonadState.get tsClocks+ let clockDomains = ((map snd) . Set.toList . Set.fromList . Map.elems) clocksMap+ return ([mkComponentInst label entity_id clockDomains portmaps], [f]) else -- Not a top level binder, so this must be a local variable reference. -- It should have a representable type (and thus, no arguments) and a@@ -1292,12 +1370,9 @@ , (lastId, (AST.SubProgBody lastSpec [] [lastExpr],[])) , (initId, (AST.SubProgBody initSpec [AST.SPVD initVar] [initExpr, initRet],[])) , (minimumId, (AST.SubProgBody minimumSpec [] [minimumExpr],[]))- , (takeId, (AST.SubProgBody takeSpec [AST.SPVD takeVar] [takeExpr, takeRet],[minimumId]))- , (dropId, (AST.SubProgBody dropSpec [AST.SPVD dropVar] [dropExpr, dropRet],[])) , (plusgtId, (AST.SubProgBody plusgtSpec [AST.SPVD plusgtVar] [plusgtExpr, plusgtRet],[])) , (emptyId, (AST.SubProgBody emptySpec [AST.SPVD emptyVar] [emptyExpr],[])) , (singletonId, (AST.SubProgBody singletonSpec [AST.SPVD singletonVar] [singletonRet],[]))- , (copynId, (AST.SubProgBody copynSpec [AST.SPVD copynVar] [copynExpr],[])) , (selId, (AST.SubProgBody selSpec [AST.SPVD selVar] [selFor, selRet],[])) , (ltplusId, (AST.SubProgBody ltplusSpec [AST.SPVD ltplusVar] [ltplusExpr, ltplusRet],[])) , (plusplusId, (AST.SubProgBody plusplusSpec [AST.SPVD plusplusVar] [plusplusExpr, plusplusRet],[]))@@ -1381,45 +1456,12 @@ [] (Just $ AST.Else [minimumExprRet]) where minimumExprRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple rightPar)- takeSpec = AST.Function (mkVHDLExtId takeId) [AST.IfaceVarDec nPar naturalTM,- AST.IfaceVarDec vecPar vectorTM ] vectorTM -- variable res : fsvec_x (0 to (minimum (n,vec'length))-1); minLength = AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId minimumId)) [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple nPar) ,Nothing AST.:=>: AST.ADExpr (AST.PrimName (AST.NAttribute $ AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]- takeVar = - AST.VarDec resId - (AST.SubtypeIn vectorTM- (Just $ AST.ConstraintIndex $ AST.IndexConstraint - [AST.ToRange (AST.PrimLit "0")- (minLength AST.:-:- (AST.PrimLit "1")) ]))- Nothing- -- res AST.:= vec(0 to n-1)- takeExpr = AST.NSimple resId AST.:= - (vecSlice (AST.PrimLit "0") - (minLength AST.:-: AST.PrimLit "1"))- takeRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)- dropSpec = AST.Function (mkVHDLExtId dropId) [AST.IfaceVarDec nPar naturalTM,- AST.IfaceVarDec vecPar vectorTM ] vectorTM - -- variable res : fsvec_x (0 to vec'length-n-1);- dropVar = - AST.VarDec resId - (AST.SubtypeIn vectorTM- (Just $ AST.ConstraintIndex $ AST.IndexConstraint - [AST.ToRange (AST.PrimLit "0")- (AST.PrimName (AST.NAttribute $ - AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:- (AST.PrimName $ AST.NSimple nPar)AST.:-: (AST.PrimLit "1")) ]))- Nothing- -- res AST.:= vec(n to vec'length-1)- dropExpr = AST.NSimple resId AST.:= (vecSlice - (AST.PrimName $ AST.NSimple nPar) - (AST.PrimName (AST.NAttribute $ - AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) - AST.:-: AST.PrimLit "1"))- dropRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)+ plusgtSpec = AST.Function (mkVHDLExtId plusgtId) [AST.IfaceVarDec aPar elemTM, AST.IfaceVarDec vecPar vectorTM] vectorTM -- variable res : fsvec_x (0 to vec'length);@@ -1454,20 +1496,7 @@ (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others) (AST.PrimName $ AST.NSimple aPar)]) singletonRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)- copynSpec = AST.Function (mkVHDLExtId copynId) [AST.IfaceVarDec nPar naturalTM,- AST.IfaceVarDec aPar elemTM ] vectorTM - -- variable res : fsvec_x (0 to n-1) := (others => a);- copynVar = - AST.VarDec resId - (AST.SubtypeIn vectorTM- (Just $ AST.ConstraintIndex $ AST.IndexConstraint - [AST.ToRange (AST.PrimLit "0")- ((AST.PrimName (AST.NSimple nPar)) AST.:-:- (AST.PrimLit "1")) ]))- (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others) - (AST.PrimName $ AST.NSimple aPar)])- -- return res- copynExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)+ selSpec = AST.Function (mkVHDLExtId selId) [AST.IfaceVarDec fPar naturalTM, AST.IfaceVarDec sPar naturalTM, AST.IfaceVarDec nPar naturalTM,@@ -1671,14 +1700,14 @@ -- it to VHDL.Constants/builtinIds as well. globalNameTable :: NameTable globalNameTable = Map.fromList- [ (exId , (2, genFCall True ) )+ [ (exId , (2, genFCall True ) ) , (replaceId , (3, genFCall False ) ) , (headId , (1, genFCall True ) ) , (lastId , (1, genFCall True ) ) , (tailId , (1, genFCall False ) ) , (initId , (1, genFCall False ) )- , (takeId , (2, genFCall False ) )- , (dropId , (2, genFCall False ) )+ , (takeId , (2, genTake ) )+ , (dropId , (2, genDrop ) ) , (selId , (4, genFCall False ) ) , (plusgtId , (2, genFCall False ) ) , (ltplusId , (2, genFCall False ) )@@ -1701,7 +1730,7 @@ , (generateId , (2, genGenerate ) ) , (emptyId , (0, genFCall False ) ) , (singletonId , (1, genFCall False ) )- , (copynId , (2, genFCall False ) )+ , (copynId , (2, genCopyn ) ) , (copyId , (1, genCopy ) ) , (lengthTId , (1, genFCall False ) ) , (nullId , (1, genFCall False ) )@@ -1736,6 +1765,10 @@ , (xorId , (2, genOperator2 AST.Xor ) ) , (shiftLId , (2, genSll ) ) , (shiftRId , (2, genSra ) )+ , (s2bvId , (1, genI2bv ) )+ , (u2bvId , (1, genI2bv ) )+ , (bv2uId , (1, genBV2u ) )+ , (bv2sId , (1, genBV2s ) ) --, (tfvecId , (1, genTFVec ) ) , (minimumId , (2, error "\nFunction name: \"minimum\" is used internally, use another name")) ]
CLasH/VHDL/Testbench.hs view
@@ -7,7 +7,7 @@ import qualified Control.Monad as Monad import qualified Maybe import qualified Data.Map as Map-import qualified Data.Accessor.Monad.Trans.State as MonadState+import qualified Data.Accessor.Monad.Trans.StrictState as MonadState -- VHDL Imports import qualified Language.VHDL.AST as AST@@ -78,11 +78,12 @@ -- used by mkAssocElems when there is no output port. Nothing -> (undefined, [], []) let iDecs = map (\(vId, tm) -> AST.SigDec vId tm Nothing) iIface+ let clockId = AST.unsafeVHDLBasicId ("clock1") let finalIDecs = iDecs ++ [AST.SigDec clockId std_logicTM (Just $ AST.PrimLit "'0'"), AST.SigDec resetId std_logicTM (Just $ AST.PrimLit "'0'")] let portmaps = mkAssocElems (map idToVHDLExpr iIds) (AST.NSimple oId) signature- let mIns = mkComponentInst "totest" entId portmaps+ let mIns = mkComponentInst "totest" entId [1] portmaps (stimuliAssigns, stimuliDecs, cycles, used) <- createStimuliAssigns mCycles stimuli (head iIds) let finalAssigns = (AST.CSSASm (AST.NSimple resetId AST.:<==: AST.ConWforms []@@ -146,7 +147,8 @@ -- | generates a clock process with a period of 10ns createClkProc :: AST.ProcSm createClkProc = AST.ProcSm (AST.unsafeVHDLBasicId "clkproc") [] sms- where sms = -- wait for 5 ns -- (half a cycle)+ where clockId = AST.unsafeVHDLBasicId ("clock1")+ sms = -- wait for 5 ns -- (half a cycle) [AST.WaitFor $ AST.PrimLit "5 ns", -- clk <= not clk; AST.NSimple clockId `AST.SigAssign` @@ -159,7 +161,8 @@ AST.ProcSm (AST.unsafeVHDLBasicId "writeoutput") [clockId] [AST.IfSm clkPred (writeOuts outs) [] Nothing]- where clkPred = AST.PrimName (AST.NAttribute $ AST.AttribName (AST.NSimple clockId) + where clockId = AST.unsafeVHDLBasicId ("clock1")+ clkPred = AST.PrimName (AST.NAttribute $ AST.AttribName (AST.NSimple clockId) (AST.NSimple eventId) Nothing ) `AST.And` (AST.PrimName (AST.NSimple clockId) AST.:=: AST.PrimLit "'1'")
CLasH/VHDL/VHDLTools.hs view
@@ -8,7 +8,7 @@ import qualified Data.Char as Char import qualified Data.Map as Map import qualified Control.Monad as Monad-import qualified Data.Accessor.Monad.Trans.State as MonadState+import qualified Data.Accessor.Monad.Trans.StrictState as MonadState -- VHDL Imports import qualified Language.VHDL.AST as AST@@ -24,6 +24,7 @@ import qualified DataCon import qualified CoreSubst import qualified Outputable+import qualified Unique -- Local imports import CLasH.VHDL.VHDLTypes@@ -132,14 +133,15 @@ mkComponentInst :: String -- ^ The portmap label -> AST.VHDLId -- ^ The entity name+ -> [Integer] -- ^ Clock domains -> [AST.AssocElem] -- ^ The port assignments -> AST.ConcSm-mkComponentInst label entity_id portassigns = AST.CSISm compins+mkComponentInst label entity_id clockDomains portassigns = AST.CSISm compins where -- We always have a clock port, so no need to map it anywhere but here- clk_port = mkAssocElem clockId (idToVHDLExpr clockId)+ clkPorts = map (\clkId -> mkAssocElem clkId (idToVHDLExpr clkId)) $ map (AST.unsafeVHDLBasicId . ("clock" ++) . show) clockDomains resetn_port = mkAssocElem resetId (idToVHDLExpr resetId)- compins = AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect (portassigns ++ [clk_port,resetn_port]))+ compins = AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect (portassigns ++ clkPorts ++ [resetn_port])) ----------------------------------------------------------------------------- -- Functions to generate VHDL Exprs@@ -223,14 +225,11 @@ varToUniqString :: CoreSyn.CoreBndr -> String-varToUniqString var = (varToString var ++ varToStringUniq var ++ show (lowers $ varToStringUniq var))- where- lowers :: String -> Int- lowers xs = length [x | x <- xs, Char.isLower x]+varToUniqString var = (varToString var ++ varToStringUniq var) -- Get the string version a Var's unique varToStringUniq :: Var.Var -> String-varToStringUniq = show . Var.varUnique+varToStringUniq = show . Unique.getKey . Var.varUnique -- Extracts the string version of the name nameToString :: Name.Name -> String@@ -527,7 +526,7 @@ elTyTmMaybe <- vhdlTyMaybe elHType case elTyTmMaybe of (Just elTyTm) -> do- let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId elTyTm) ++ "-0_to_" ++ (show len)+ let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId elTyTm) ++ "-0_to_" ++ (show (len - 1)) let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))] let existing_uvec_ty = fmap (fmap fst) $ Map.lookup (UVecType elHType) typesMap case existing_uvec_ty of
+ Data/Accessor/Monad/Trans/StrictState.hs view
@@ -0,0 +1,38 @@+module Data.Accessor.Monad.Trans.StrictState where+ +import qualified Data.Accessor.Basic as Accessor+import qualified Control.Monad.Trans.State.Strict as State+import qualified Control.Monad.Trans.Class as Trans+import Control.Monad.Trans.State.Strict (State, runState, StateT(runStateT), )++set :: Monad m => Accessor.T r a -> a -> StateT r m ()+set f x = State.modify (Accessor.set f x)++get :: Monad m => Accessor.T r a -> StateT r m a+get f = State.gets (Accessor.get f)++modify :: Monad m => Accessor.T r a -> (a -> a) -> StateT r m ()+modify f g = State.modify (Accessor.modify f g)++infix 1 %=, %:++(%=) :: Monad m => Accessor.T r a -> a -> StateT r m ()+(%=) = set++(%:) :: Monad m => Accessor.T r a -> (a -> a) -> StateT r m ()+(%:) = modify++lift :: Monad m => Accessor.T r s -> State s a -> StateT r m a+lift f m =+ do s0 <- get f+ let (a,s1) = runState m s0+ set f s1+ return a++liftT :: (Monad m) =>+ Accessor.T r s -> StateT s m a -> StateT r m a+liftT f m =+ do s0 <- get f+ (a,s1) <- Trans.lift $ runStateT m s0+ set f s1+ return a
clash.cabal view
@@ -1,5 +1,5 @@ name: clash-version: 0.1.2.5+version: 0.1.3.0 build-type: Simple synopsis: CAES Language for Synchronous Hardware (CLaSH) description: CLaSH is a tool-chain/language to translate subsets of@@ -22,8 +22,8 @@ build-depends: ghc >= 6.12 && < 6.13, pretty, vhdl > 0.1.1, haskell98, syb, data-accessor >= 0.2.1.3, containers, base >= 4 && < 5, transformers >= 0.2, filepath, template-haskell, - data-accessor-template, data-accessor-transformers, - prettyclass, directory, tfp, th-lift, time+ data-accessor-template, prettyclass, directory, tfp, + th-lift, time exposed-modules: CLasH.HardwareTypes CLasH.Translator@@ -33,6 +33,7 @@ Data.Param.Unsigned Data.Param.Index Data.Param.Vector+ Data.Accessor.Monad.Trans.StrictState CLasH.Translator.TranslatorTypes CLasH.Translator.Annotations CLasH.Normalize