clash 0.1.3.0 → 0.1.3.9
raw patch · 14 files changed
+138/−110 lines, 14 filesdep −sybdep ~basedep ~containersdep ~data-accessor
Dependencies removed: syb
Dependency ranges changed: base, containers, data-accessor, data-accessor-template, directory, filepath, haskell98, pretty, prettyclass, template-haskell, tfp, th-lift, time, transformers, vhdl
Files
- CLasH/HardwareTypes.hs +1/−2
- CLasH/Normalize.hs +21/−6
- CLasH/Translator.hs +14/−17
- CLasH/Translator/Annotations.hs +1/−9
- CLasH/Translator/TranslatorTypes.hs +4/−4
- CLasH/Utils/Core/CoreTools.hs +1/−1
- CLasH/Utils/GhcTools.hs +8/−38
- CLasH/Utils/HsTools.hs +3/−1
- CLasH/VHDL/Constants.hs +4/−1
- CLasH/VHDL/Generate.hs +24/−11
- CLasH/VHDL/VHDLTools.hs +28/−10
- Data/Accessor/Monad/Trans/StrictState.hs +6/−0
- Data/Param/Vector.hs +4/−0
- clash.cabal +19/−10
CLasH/HardwareTypes.hs view
@@ -9,7 +9,6 @@ , module Data.Param.Unsigned , module Data.Bits , module Language.Haskell.TH.Lift- , module Control.Category , module Control.Arrow , module Control.Monad.Fix , module CLasH.Translator.Annotations@@ -58,7 +57,7 @@ import Data.Typeable import Control.Category (Category,(.),id)-import Control.Arrow (Arrow,arr,first,ArrowLoop,loop,(>>>),second,returnA)+import Control.Arrow (Arrow,arr,first,ArrowLoop,loop,(>>>),returnA) import Control.Monad.Fix (mfix) import qualified Prelude as P import Prelude hiding (id, (.))
CLasH/Normalize.hs view
@@ -176,7 +176,7 @@ ((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)+ newInlineF <- Trans.lift $ mkFunction inlineF (Maybe.fromMaybe (error $ "Normalize.inlinetoplevel: no expr found for bndr: " ++ pprString inlineF) inlineFbody) -- 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)@@ -1057,16 +1057,25 @@ (realfunBndr, realfunBody) <- case realfun of (Var realfunBndr) -> do exprMaybe <- Trans.lift $ getGlobalBind realfunBndr- let body = Maybe.fromMaybe (error $ "Normalize.arrowLiftSExtract: could not find lifted function: " ++ pprString realfun) exprMaybe+ let body = Maybe.fromMaybe (error $ "Normalize.arrowLiftSExtract(Var): could not find lifted function: " ++ pprString realfun) exprMaybe -- Clone the lifted function realfun' <- Trans.lift $ mkFunction realfunBndr body return (realfun', Var realfun')- (App appliedFun appliedArgs) -> do- let (Var appliedFunBndr, _) = collectArgs realfun+ (App _ _) -> do+ let (Var appliedFunBndr, appliedArgs) = collectArgs realfun exprMaybe <- Trans.lift $ getGlobalBind appliedFunBndr- let body = Maybe.fromMaybe (error $ "Normalize.arrowLiftSExtract: could not find lifted function: " ++ pprString realfun) exprMaybe+ let body = Maybe.fromMaybe (error $ "Normalize.arrowLiftSExtract(App): could not find lifted function: " ++ pprString realfun) exprMaybe+ -- Clone the lifted function realfun' <- Trans.lift $ mkFunction appliedFunBndr body- return (realfun', App (Var realfun') appliedArgs) + return (realfun', CoreSyn.mkApps (Var realfun') appliedArgs)+ (Lam id1 (Lam id2 (Cast (App (App appliedFun lamArg1) lamArg2) ty))) -> do+ let (Var appliedFunBndr, appliedArgs) = collectArgs appliedFun+ exprMaybe <- Trans.lift $ getGlobalBind appliedFunBndr+ let body = Maybe.fromMaybe (error $ "Normalize.arrowLiftSExtract(LamLamCastAppApp): could not find lifted function: " ++ pprString realfun) exprMaybe+ -- Clone the lifted function+ realfun' <- Trans.lift $ mkFunction appliedFunBndr body+ return (realfun', Lam id1 (Lam id2 (Cast (App (App (CoreSyn.mkApps (Var realfun') appliedArgs) lamArg1) lamArg2) ty)))+ otherwise -> error $ "Normalize.arrowLiftSExtract: Don't know how to lift: " ++ pprString realfun -- Create 2 new Vars that that will be applied to the lifted function let [arg1Ty,arg2Ty] = (fst . Type.splitFunTys . CoreUtils.exprType) realfun id1 <- Trans.lift $ mkInternalVar "param" arg1Ty@@ -1104,6 +1113,12 @@ 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)+ (App _ _) -> do+ let (Var appliedFunBndr, [litArg]) = collectArgs clock clockLit <- Trans.lift $ getIntegerLiteral litArg case (Name.getOccString appliedFunBndr) of "ClockUp" -> return (True,clockLit)
CLasH/Translator.hs view
@@ -44,8 +44,6 @@ makeVHDL libdir filenames finder where finder = findSpec (hasCLasHAnnotation isTopEntity)- (hasCLasHAnnotation isInitState)- (isCLasHAnnotation isInitState) (hasCLasHAnnotation isTestInput) -- | Turn Haskell to VHDL, using the given finder functions to find the Top@@ -58,11 +56,11 @@ makeVHDL libdir filenames finder = do start <- Clock.getCurrentTime -- Load the modules- (cores, env, specs) <- loadModules libdir filenames (Just finder)+ (cores, specs) <- loadModules libdir filenames (Just finder) -- Translate to VHDL- vhdl <- moduleToVHDL env cores specs+ vhdl <- moduleToVHDL cores specs -- Write VHDL to file. Just use the first entity for the name- let top_entity = head $ Maybe.catMaybes $ map (\(t, _, _) -> t) specs+ let top_entity = head $ Maybe.catMaybes $ map (\(t, _) -> t) specs let dir = "./vhdl/" ++ (show top_entity) ++ "/" prepareDir dir mapM_ (writeVHDL dir) vhdl@@ -72,19 +70,18 @@ -- | Translate the specified entities in the given modules to VHDL. moduleToVHDL ::- HscTypes.HscEnv -- ^ The GHC Environment- -> [HscTypes.CoreModule] -- ^ The Core Modules+ [HscTypes.CoreModule] -- ^ The Core Modules -> [EntitySpec] -- ^ The entities to generate -> IO [(AST.VHDLId, AST.DesignFile)]-moduleToVHDL env cores specs = do- (vhdl, count) <- runTranslatorSession env $ do+moduleToVHDL cores specs = do+ (vhdl, count) <- runTranslatorSession $ do let all_bindings = concatMap (\x -> CoreSyn.flattenBinds (HscTypes.cm_binds x)) cores -- Store the bindings we loaded tsBindings %= Map.fromList all_bindings -- let all_initstates = concatMap (\x -> case x of (_, Nothing, _) -> []; (_, Just inits, _) -> inits) specs tsInitStates %= Map.empty test_binds <- catMaybesM $ Monad.mapM mkTest specs- let topbinds = Maybe.catMaybes $ map (\(top, _, _) -> top) specs+ let topbinds = Maybe.catMaybes $ map (\(top, _) -> top) specs vhdl <- case topbinds of [] -> error "Could not find top entity requested" tops -> createDesignFiles (tops ++ test_binds)@@ -96,24 +93,24 @@ where mkTest :: EntitySpec -> TranslatorSession (Maybe CoreSyn.CoreBndr) -- Create a testbench for any entry that has test input- mkTest (_, _, Nothing) = return Nothing- mkTest (Nothing, _, _) = return Nothing- mkTest (Just top, _, Just input) = do+ mkTest (_, Nothing) = return Nothing+ mkTest (Nothing, _) = return Nothing+ mkTest (Just top, Just input) = do bndr <- createTestbench Nothing cores input top return $ Just bndr -- Run the given translator session. Generates a new UniqSupply for that -- session.-runTranslatorSession :: HscTypes.HscEnv -> TranslatorSession a -> IO a-runTranslatorSession env session = do+runTranslatorSession :: TranslatorSession a -> IO a+runTranslatorSession session = do -- Generate a UniqSupply -- Running -- egrep -r "(initTcRnIf|mkSplitUniqSupply)" . -- on the compiler dir of ghc suggests that 'z' is not used to generate -- a unique supply anywhere. 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_typedecls = map (mktydecl . (Maybe.fromMaybe (error "Translator.runTranslatorSession: No builtin type found")) . snd) $ Map.toList builtin_types+ let init_typestate = TypeState builtin_types init_typedecls Map.empty Map.empty 0 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
CLasH/Translator/Annotations.hs view
@@ -4,21 +4,13 @@ import qualified Language.Haskell.TH as TH import Data.Data -data CLasHAnn = TopEntity | InitState TH.Name | TestInput | TestCycles+data CLasHAnn = TopEntity | TestInput deriving (Show, Data, Typeable) isTopEntity :: CLasHAnn -> Bool isTopEntity TopEntity = True isTopEntity _ = False -isInitState :: CLasHAnn -> Bool-isInitState (InitState _) = True-isInitState _ = False- isTestInput :: CLasHAnn -> Bool isTestInput TestInput = True isTestInput _ = False--isTestCycles :: CLasHAnn -> Bool-isTestCycles TestCycles = True-isTestCycles _ = False
CLasH/Translator/TranslatorTypes.hs view
@@ -26,9 +26,8 @@ import CLasH.VHDL.VHDLTypes -- | A specification of an entity we can generate VHDL for. Consists of the--- binder of the top level entity, an optional initial state and an optional--- test input.-type EntitySpec = (Maybe CoreSyn.CoreBndr, Maybe [(CoreSyn.CoreBndr, CoreSyn.CoreBndr)], Maybe CoreSyn.CoreExpr)+-- binder of the top level entity and an optional test input.+type EntitySpec = (Maybe CoreSyn.CoreBndr, Maybe CoreSyn.CoreExpr) -- | A function that knows which parts of a module to compile type Finder =@@ -83,7 +82,8 @@ -- | A map of vector Core type -> VHDL type function tsTypeFuns_ :: TypeFunMap, tsTfpInts_ :: TfpIntMap,- tsHscEnv_ :: HscTypes.HscEnv+ -- tsHscEnv_ :: HscTypes.HscEnv+ tsTypeCnt_ :: Integer } -- Derive accessors
CLasH/Utils/Core/CoreTools.hs view
@@ -175,7 +175,7 @@ "Pow2" -> do let arg = head args int <- arg `seq` tfp_to_int' (msg ++ " > " ++ tyconName) $! arg- let len = int `seq` int * int+ let len = int `seq` 2 ^ int return len "Mul2" -> do let arg = head args
CLasH/Utils/GhcTools.hs view
@@ -35,7 +35,7 @@ listBindings :: FilePath -> [FilePath] -> IO () listBindings libdir filenames = do- (cores,_,_) <- loadModules libdir filenames Nothing+ (cores,_) <- loadModules libdir filenames Nothing let binds = concatMap (CoreSyn.flattenBinds . HscTypes.cm_binds) cores mapM listBinding binds putStr "\n=========================\n"@@ -69,7 +69,7 @@ -- | Show the core structure of the given binds in the given file. listBind :: FilePath -> [FilePath] -> String -> IO () listBind libdir filenames name = do- (cores,_,_) <- loadModules libdir filenames Nothing+ (cores,_) <- loadModules libdir filenames Nothing bindings <- concatM $ mapM (findBinder (hasVarName name)) cores mapM_ listBinding bindings return ()@@ -103,20 +103,18 @@ -> [String] -- ^ The files that need to be loaded -> Maybe Finder -- ^ What entities to build? -> IO ( [HscTypes.CoreModule]- , HscTypes.HscEnv , [EntitySpec]- ) -- ^ ( The loaded modules, the resulting ghc environment, the entities to build)+ ) -- ^ ( The loaded modules, the entities to build) loadModules libdir filenames finder = GHC.defaultErrorHandler DynFlags.defaultDynFlags $ GHC.runGhc (Just libdir) $ do dflags <- GHC.getSessionDynFlags GHC.setSessionDynFlags dflags cores <- mapM GHC.compileToCoreModule filenames- env <- GHC.getSession specs <- case finder of Nothing -> return [] Just f -> concatM $ mapM f cores- return (cores, env, specs)+ return (cores, specs) findBinds :: Monad m =>@@ -217,40 +215,12 @@ -> m Bool -- ^ Indicate if the binder has the name hasVarName lookfor bind = return $ lookfor == Name.occNameString (Name.nameOccName $ Name.getName bind) --findInitStates ::- (Var.Var -> GHC.Ghc Bool) -> - (Var.Var -> GHC.Ghc [CLasHAnn]) -> - HscTypes.CoreModule -> - GHC.Ghc (Maybe [(CoreSyn.CoreBndr, CoreSyn.CoreBndr)])-findInitStates statec annsc mod = do- states <- findBinds statec mod- anns <- findAnns annsc mod- let funs = Maybe.catMaybes (map extractInits anns)- exprs' <- mapM (\x -> findBind (hasVarName (TH.nameBase x)) mod) funs- let exprs = Maybe.catMaybes exprs'- let inits = zipMWith (\a b -> (a,b)) states exprs- return inits- where- extractInits :: CLasHAnn -> Maybe TH.Name- extractInits (InitState x) = Just x- extractInits _ = Nothing- zipMWith :: (a -> b -> c) -> (Maybe [a]) -> [b] -> (Maybe [c])- zipMWith _ Nothing _ = Nothing- zipMWith f (Just as) bs = Just $ zipWith f as bs---- | Make a complete spec out of a three conditions+-- | Make a complete spec out of a two conditions findSpec ::- (Var.Var -> GHC.Ghc Bool) -> (Var.Var -> GHC.Ghc Bool) -> (Var.Var -> GHC.Ghc [CLasHAnn]) -> (Var.Var -> GHC.Ghc Bool)+ (Var.Var -> GHC.Ghc Bool) -> (Var.Var -> GHC.Ghc Bool) -> Finder -findSpec topc statec annsc testc mod = do+findSpec topc testc mod = do top <- findBind topc mod- state <- findExprs statec mod- anns <- findAnns annsc mod test <- findExpr testc mod- inits <- findInitStates statec annsc mod- return [(top, inits, test)]- -- case top of- -- Just t -> return [(t, state, test)]- -- Nothing -> return error $ "Could not find top entity requested"+ return [(top, test)]
CLasH/Utils/HsTools.hs view
@@ -46,6 +46,8 @@ import qualified Type import qualified TyCon +import CLasH.Utils.Pretty+ -- | Translate a HsExpr to a Core expression. This does renaming, type -- checking, simplification of class instances and desugaring. The result is -- a let expression that holds the given expression and a number of binds that@@ -120,7 +122,7 @@ -- Normalize the type (_, nty) <- TcTyFuns.tcNormaliseFamInst ty return nty- let normalized_ty = Maybe.fromJust nty+ let normalized_ty = Maybe.fromMaybe (error $ "HsTools.normalizeType: tcNormaliseFamInst failed for: " ++ pprString ty) nty return normalized_ty -- | Translate a core Type to an HsType. Far from complete so far.
CLasH/VHDL/Constants.hs view
@@ -16,7 +16,7 @@ , negateId, minusId, fromSizedWordId, fromIntegerId, resizeWordId , resizeIntId, sizedIntId, smallIntegerId, fstId, sndId, blockRAMId , splitId, minimumId, fromRangedWordId, xorId, shiftLId , shiftRId- , u2bvId, s2bvId, bv2sId, bv2uId+ , u2bvId, s2bvId, bv2sId, bv2uId, maxIndexId ] -------------- -- Identifiers@@ -27,6 +27,9 @@ s2bvId = "s2bv" bv2sId = "bv2s" bv2uId = "bv2u"++maxIndexId :: String+maxIndexId = "maxIndex" -- | reset and clock signal identifiers in String form resetStr, clockStr :: String
CLasH/VHDL/Generate.hs view
@@ -96,7 +96,8 @@ ++ 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+ clkPorts = map ((\a -> AST.IfaceSigDec a AST.In std_logicTM) . AST.unsafeVHDLBasicId . ("clock" ++) . show . snd) + (if (null clocks) then [(undefined,1)] else clocks) resetn_port = AST.IfaceSigDec resetId AST.In std_logicTM res_port = fmap (mkIfaceSigDec AST.Out) res @@ -489,7 +490,7 @@ "Signed" -> MonadState.lift tsType $ tfp_to_int (sized_int_len_ty ty) "Unsigned" -> MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty) "Index" -> do { ubound <- MonadState.lift tsType $ tfp_to_int (ranged_word_bound_ty ty)- ; let bitsize = floor (logBase 2 (fromInteger (toInteger ubound)))+ ; let bitsize = ceiling (logBase 2 (fromInteger (toInteger ubound))) ; return bitsize } ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId resizeId))@@ -1070,14 +1071,14 @@ genSplit' (Left res) f args@[(vecIn,vecInType)] = do { ; len <- MonadState.lift tsType $ tfp_to_int $ tfvec_len_ty vecInType ; res_htype <- MonadState.lift tsType $ mkHType "\nGenerate.genSplit': Invalid result type" (Var.varType res)- ; [argExpr] <- argsToVHDLExprs [vecIn]+ ; [AST.PrimName argExpr] <- argsToVHDLExprs [vecIn] ; let { ; labels = getFieldLabels res_htype 0- ; block_label = mkVHDLExtId ("split" ++ show argExpr) ; halflen = round ((fromIntegral len) / 2)- ; rangeL = vecSlice (AST.PrimLit "0") (AST.PrimLit $ show (halflen - 1))- ; rangeR = vecSlice (AST.PrimLit $ show halflen) (AST.PrimLit $ show (len - 1))+ ; rangeL = vecSlice argExpr (AST.PrimLit "0") (AST.PrimLit $ show (halflen - 1))+ ; rangeR = vecSlice argExpr (AST.PrimLit $ show halflen) (AST.PrimLit $ show (len - 1)) ; resname = varToVHDLName res+ ; block_label = mkVHDLExtId ("split" ++ (varToUniqString res)) ; resnameL = mkSelectedName resname (labels!!0) ; resnameR = mkSelectedName resname (labels!!1) ; argexprL = vhdlNameToVHDLExpr rangeL@@ -1089,8 +1090,7 @@ ; return [AST.CSBSm block] } where- vecSlice init last = AST.NSlice (AST.SliceName (varToVHDLName res) - (AST.ToRange init last))+ vecSlice n init last = AST.NSlice (AST.SliceName n (AST.ToRange init last)) genSll :: BuiltinBuilder genSll = genNoInsts $ genExprArgs $ genExprRes genSll'@@ -1155,6 +1155,16 @@ ; let dropVal = AST.PrimName (AST.NSlice (AST.SliceName arg2name (AST.ToRange (AST.PrimLit $ show literal) (AST.PrimLit $ show (arg2len - 1))))) ; return dropVal }+ +genMaxIndex :: BuiltinBuilder+genMaxIndex = genNoInsts $ genExprRes genMaxIndex'+genMaxIndex' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -> TranslatorSession AST.Expr+genMaxIndex' res f [(arg1,arg1Type)] = do {+ ; len <- MonadState.lift tsType $ tfp_to_int $ tfvec_len_ty arg1Type+ ; let bitsize = floor (logBase 2 (fromInteger (toInteger len)))+ ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId toUnsignedId))+ [Nothing AST.:=>: AST.ADExpr (AST.PrimLit (show $ len - 1)), Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show bitsize))]+ } ----------------------------------------------------------------------------- -- Function to generate VHDL for applications@@ -1203,7 +1213,7 @@ -- constructor used to the constructor field as -- well. Just dc_label ->- let { dc_index = getConstructorIndex (snd $ Maybe.fromJust etype) (varToString f)+ let { dc_index = getConstructorIndex (snd $ Maybe.fromMaybe (error $ "Generate.genApplication: expecting constructor but found none for: " ++ show htype) etype) (varToString f) ; dc_expr = AST.PrimLit $ show dc_index } in (dc_label:labels, dc_expr:arg_exprs) return (zipWith mkassign final_labels final_exprs, [])@@ -1268,7 +1278,8 @@ let label = "comp_ins_" ++ (either (prettyShow . varToVHDLName) prettyShow) dst let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature clocksMap <- MonadState.get tsClocks- let clockDomains = ((map snd) . Set.toList . Set.fromList . Map.elems) clocksMap+ let clockDomains' = ((map snd) . Set.toList . Set.fromList . Map.elems) clocksMap+ let clockDomains = if null clockDomains' then [1] else clockDomains' return ([mkComponentInst label entity_id clockDomains portmaps], [f]) else -- Not a top level binder, so this must be a local variable reference.@@ -1309,7 +1320,8 @@ let label = "comp_ins_" ++ (either (prettyShow . varToVHDLName) prettyShow) dst let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature clocksMap <- MonadState.get tsClocks- let clockDomains = ((map snd) . Set.toList . Set.fromList . Map.elems) clocksMap+ let clockDomains' = ((map snd) . Set.toList . Set.fromList . Map.elems) clocksMap+ let clockDomains = if null clockDomains' then [1] else clockDomains' return ([mkComponentInst label entity_id clockDomains portmaps], [f]) else -- Not a top level binder, so this must be a local variable reference.@@ -1769,6 +1781,7 @@ , (u2bvId , (1, genI2bv ) ) , (bv2uId , (1, genBV2u ) ) , (bv2sId , (1, genBV2s ) )+ , (maxIndexId , (1, genMaxIndex ) ) --, (tfvecId , (1, genTFVec ) ) , (minimumId , (2, error "\nFunction name: \"minimum\" is used internally, use another name")) ]
CLasH/VHDL/VHDLTools.hs view
@@ -25,6 +25,7 @@ import qualified CoreSubst import qualified Outputable import qualified Unique+import qualified VarSet -- Local imports import CLasH.VHDL.VHDLTypes@@ -233,7 +234,12 @@ -- Extracts the string version of the name nameToString :: Name.Name -> String-nameToString = OccName.occNameString . Name.nameOccName+nameToString name = name'+ where+ name'' = OccName.occNameString $ Name.nameOccName name+ name' = case (filter (`notElem` ",") name'') of+ "()" -> "Tuple" ++ (show $ (+1) $ length $ filter (`elem` ",") name'')+ n -> name'' -- Shortcut for Basic VHDL Ids. -- Can only contain alphanumerics and underscores. The supplied string must be@@ -245,7 +251,7 @@ AST.unsafeVHDLBasicId $ (strip_multiscore . strip_leading . strip_invalid) s where -- Strip invalid characters.- strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")+ strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_") -- Strip leading numbers and underscores strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_") -- Strip multiple adjacent underscores@@ -360,6 +366,10 @@ return $ Right $ RangedWType (bound - 1) "()" -> do return $ Right UnitType+ "Clock" -> do+ return $ Left "\nVHDLTools.mkHTypeEither': Clock type is not representable"+ "Comp" -> do+ return $ Left "\nVHDLTools.mkHTypeEither': Comp type is not representable" otherwise -> mkTyConHType tycon args Nothing -> return $ Left $ "\nVHDLTools.mkHTypeEither': Do not know what to do with type: " ++ pprString ty@@ -399,7 +409,7 @@ -- when there are multiple datacons let enum_ty_part = case dcs of [dc] -> Nothing- _ -> Just ("constructor", enum_ty)+ _ -> Just ("constructor", EnumType (name ++ "Con") (map (nameToString . DataCon.dataConName) dcs)) -- Create the AggrType HType return $ Right $ AggrType name enum_ty_part fieldss -- There were errors in element types@@ -407,14 +417,21 @@ "\nVHDLTools.mkTyConHType: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n" ++ (concat $ concat errors) where- name = (nameToString (TyCon.tyConName tycon))- tyvars = TyCon.tyConTyVars tycon- subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)+ name = (nameToString (TyCon.tyConName tycon))+ + tyvars = TyCon.tyConTyVars tycon+ tyVarArgMap = zip tyvars args+ dataConTyVars = (concatMap VarSet.varSetElems) $ (map Type.tyVarsOfType) $ (concatMap DataCon.dataConRepArgTys) $ TyCon.tyConDataCons tycon+ dataConTyVarArg x = (x, snd $ head $ filter (equalTyVarName x) tyVarArgMap)+ equalTyVarName z (tv,_) = (Name.nameOccName $ Var.varName z) == (Name.nameOccName $ Var.varName tv)++ subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst $ map dataConTyVarArg dataConTyVars+ -- Label a field by taking the first available label and returning -- the rest. label_field :: [String] -> HType -> ([String], (String, HType)) label_field (l:ls) htype = (ls, (l, htype))- labels = map (:[]) ['A'..'Z']+ labels = [ [a,b] | a <- ['A'..'Z'], b <- ['A'..'Z'] ] --map (:[]) ['A'..'Z'] vhdlTy :: (TypedThing t, Outputable.Outputable t) => String -> t -> TypeSession (Maybe AST.TypeMark)@@ -474,7 +491,8 @@ let reclabelss = map (map mkVHDLBasicId) labelss let elemss = zipWith (zipWith AST.ElementDec) reclabelss elem_tyss let elem_names = concatMap (concatMap prettyShow) elem_tyss- let ty_id = mkVHDLExtId $ name ++ elem_names+ tyCnt <- MonadState.getAndModify tsTypeCnt (+1)+ let ty_id = mkVHDLExtId $ name ++ "_" ++ (show tyCnt)-- elem_names -- Find out if we need to add an extra field at the start of -- the record type containing the constructor (only needed -- when there's more than one constructor).@@ -526,7 +544,7 @@ elTyTmMaybe <- vhdlTyMaybe elHType case elTyTmMaybe of (Just elTyTm) -> do- let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId elTyTm) ++ "-0_to_" ++ (show (len - 1))+ 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@@ -642,7 +660,7 @@ foldr1 (\e1 e2 -> e1 AST.:&: AST.PrimLit "','" AST.:&: e2) $ map ((genExprFCall2 showId) . (\x -> (selectedName tupPar x, AST.PrimLit "false"))) (take tupSize recordlabels)- recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']+ recordlabels = map (\c -> mkVHDLBasicId c) [ [a,b] | a <- ['A'..'Z'], b <- ['A'..'Z'] ] -- ['A'..'Z'] tupSize = length elemTMs selectedName par = (AST.PrimName . AST.NSelected . (AST.NSimple par AST.:.:) . tupVHDLSuffix)
Data/Accessor/Monad/Trans/StrictState.hs view
@@ -14,6 +14,12 @@ modify :: Monad m => Accessor.T r a -> (a -> a) -> StateT r m () modify f g = State.modify (Accessor.modify f g) +getAndModify :: Monad m => Accessor.T r a -> (a -> a) -> StateT r m a+getAndModify f g =+ do x <- get f+ modify f g+ return x+ infix 1 %=, %: (%=) :: Monad m => Accessor.T r a -> a -> StateT r m ()
Data/Param/Vector.hs view
@@ -8,6 +8,7 @@ , unsafeVector , readVector , vlength+ , maxIndex , vlengthT , fromVector , vnull@@ -93,6 +94,9 @@ -- ======================= vlength :: forall s a . NaturalT s => Vector s a -> Int vlength _ = fromIntegerT (undefined :: s)++maxIndex :: forall s a . PositiveT s => Vector s a -> Index s+maxIndex _ = maxBound vlengthT :: NaturalT s => Vector s a -> s vlengthT = undefined
clash.cabal view
@@ -1,5 +1,5 @@ name: clash-version: 0.1.3.0+version: 0.1.3.9 build-type: Simple synopsis: CAES Language for Synchronous Hardware (CLaSH) description: CLaSH is a tool-chain/language to translate subsets of@@ -19,15 +19,26 @@ Cabal-Version: >= 1.2 Library- 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, prettyclass, directory, tfp, - th-lift, time- + build-depends: ghc >= 6.12 && < 6.13,+ pretty >= 1.0.1.1 && < 1.1,+ vhdl >= 0.1.2.1 && < 0.2,+ haskell98 >= 1.0.1.1 && < 1.1,+ data-accessor >= 0.2.1.3 && < 2.3,+ containers >= 0.3 && < 0.4,+ base >= 4.2 && < 4.3,+ transformers >= 0.2 && < 0.3,+ filepath >= 1.1.0.4 && < 1.2,+ template-haskell >= 2.4.0.1 && < 2.5,+ data-accessor-template >= 0.2.1.8 && < 0.3,+ prettyclass >= 1.0 && < 1.1,+ directory >= 1.0 && < 1.1,+ tfp >= 0.2 && < 0.4,+ th-lift >= 0.5.4 && < 0.6,+ time >= 1.1.4 && < 1.2+ exposed-modules: CLasH.HardwareTypes CLasH.Translator- + other-modules: Data.Param.Integer Data.Param.Signed Data.Param.Unsigned@@ -52,5 +63,3 @@ CLasH.Utils.Core.BinderTools CLasH.Utils.Core.CoreShow CLasH.Utils.Core.CoreTools- -