diff --git a/CLasH/HardwareTypes.hs b/CLasH/HardwareTypes.hs --- a/CLasH/HardwareTypes.hs +++ b/CLasH/HardwareTypes.hs @@ -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, (.)) diff --git a/CLasH/Normalize.hs b/CLasH/Normalize.hs --- a/CLasH/Normalize.hs +++ b/CLasH/Normalize.hs @@ -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) diff --git a/CLasH/Translator.hs b/CLasH/Translator.hs --- a/CLasH/Translator.hs +++ b/CLasH/Translator.hs @@ -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 diff --git a/CLasH/Translator/Annotations.hs b/CLasH/Translator/Annotations.hs --- a/CLasH/Translator/Annotations.hs +++ b/CLasH/Translator/Annotations.hs @@ -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 diff --git a/CLasH/Translator/TranslatorTypes.hs b/CLasH/Translator/TranslatorTypes.hs --- a/CLasH/Translator/TranslatorTypes.hs +++ b/CLasH/Translator/TranslatorTypes.hs @@ -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 diff --git a/CLasH/Utils/Core/CoreTools.hs b/CLasH/Utils/Core/CoreTools.hs --- a/CLasH/Utils/Core/CoreTools.hs +++ b/CLasH/Utils/Core/CoreTools.hs @@ -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 diff --git a/CLasH/Utils/GhcTools.hs b/CLasH/Utils/GhcTools.hs --- a/CLasH/Utils/GhcTools.hs +++ b/CLasH/Utils/GhcTools.hs @@ -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)] diff --git a/CLasH/Utils/HsTools.hs b/CLasH/Utils/HsTools.hs --- a/CLasH/Utils/HsTools.hs +++ b/CLasH/Utils/HsTools.hs @@ -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. diff --git a/CLasH/VHDL/Constants.hs b/CLasH/VHDL/Constants.hs --- a/CLasH/VHDL/Constants.hs +++ b/CLasH/VHDL/Constants.hs @@ -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 diff --git a/CLasH/VHDL/Generate.hs b/CLasH/VHDL/Generate.hs --- a/CLasH/VHDL/Generate.hs +++ b/CLasH/VHDL/Generate.hs @@ -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")) ] diff --git a/CLasH/VHDL/VHDLTools.hs b/CLasH/VHDL/VHDLTools.hs --- a/CLasH/VHDL/VHDLTools.hs +++ b/CLasH/VHDL/VHDLTools.hs @@ -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) diff --git a/Data/Accessor/Monad/Trans/StrictState.hs b/Data/Accessor/Monad/Trans/StrictState.hs --- a/Data/Accessor/Monad/Trans/StrictState.hs +++ b/Data/Accessor/Monad/Trans/StrictState.hs @@ -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 () diff --git a/Data/Param/Vector.hs b/Data/Param/Vector.hs --- a/Data/Param/Vector.hs +++ b/Data/Param/Vector.hs @@ -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 diff --git a/clash.cabal b/clash.cabal --- a/clash.cabal +++ b/clash.cabal @@ -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 - -