import qualified Sim
import Data.SizedWord
import Types
+import Types.Data.Num
+import CLasH.Translator.Annotations
+import qualified Prelude as P
+
+fst (a, b) = a
+snd (a, b) = b
main = Sim.simulate exec program initial_state
mainIO = Sim.simulateIO exec initial_state
dontcare = Low
+newtype State s = State s deriving (P.Show)
+
program = [
-- (addr, we, op)
(High, Low, High), -- z = r1 and t (0) ; t = r1 (1)
]
--initial_state = (Regs Low High, Low, Low)
-initial_state = ((0, 1), 0, 0)
+initial_state = State (State (0, 1), 0, 0)
type Word = SizedWord D4
-- Register bank
type RegAddr = Bit
-type RegisterBankState = (Word, Word)
+type RegisterBankState = State (Word, Word)
--data RegisterBankState = Regs { r0, r1 :: Bit} deriving (Show)
register_bank ::
- (RegAddr, Bit, Word) -> -- (addr, we, d)
- RegisterBankState -> -- s
- (RegisterBankState, Word) -- (s', o)
-
-register_bank (Low, Low, _) s = -- Read r0
- --(s, r0 s)
- (s, fst s)
+ RegAddr -- ^ Address
+ -> Bit -- ^ Write Enable
+ -> Word -- ^ Data
+ -> RegisterBankState -> -- State
+ (RegisterBankState, Word) -- (State', Output)
-register_bank (High, Low, _) s = -- Read r1
- --(s, r1 s)
- (s, snd s)
-
-register_bank (addr, High, d) s = -- Write
- (s', 0)
- where
- --Regs r0 r1 = s
- (r0, r1) = s
- r0' = case addr of Low -> d; High -> r0
- r1' = case addr of High -> d; Low -> r1
- --s' = Regs r0' r1'
- s' = (r0', r1')
+register_bank addr we d (State s) =
+ case we of
+ Low -> -- Read
+ let
+ o = case addr of Low -> fst s; High -> snd s
+ in (State s, o) -- Don't change state
+ High -> -- Write
+ let
+ (r0, r1) = s
+ r0' = case addr of Low -> d; High -> r0
+ r1' = case addr of High -> d; Low -> r1
+ s' = (r0', r1')
+ in (State s', 0) -- Don't output anything useful
-- ALU
{-# NOINLINE alu #-}
--alu High a b = a `hwand` b
--alu Low a b = a `hwor` b
-alu High a b = a + b
-alu Low a b = a - b
+alu High a b = a P.+ b
+alu Low a b = a P.- b
-type ExecState = (RegisterBankState, Word, Word)
+type ExecState = State (RegisterBankState, Word, Word)
exec :: (RegAddr, Bit, AluOp) -> ExecState -> (ExecState, Word)
+{-# ANN exec TopEntity #-}
-- Read & Exec
-exec (addr, we, op) s =
- (s', z')
+exec (addr, we, op) (State s) =
+ (State s', z')
where
(reg_s, t, z) = s
- (reg_s', t') = register_bank (addr, we, z) reg_s
+ (reg_s', t') = register_bank addr we z reg_s
z' = alu op t' t
s' = (reg_s', t', z')
letremovetop :: Transform
letremovetop = everywhere ("letremove", inlinebind (\(b, e) -> Trans.lift $ is_local_var e))
+--------------------------------
+-- Unused let binding removal
+--------------------------------
+letremoveunused, letremoveunusedtop :: Transform
+letremoveunused expr@(Let (Rec binds) res) = do
+ -- Filter out all unused binds.
+ let binds' = filter dobind binds
+ -- Only set the changed flag if binds got removed
+ changeif (length binds' /= length binds) (Let (Rec binds') res)
+ where
+ bound_exprs = map snd binds
+ -- For each bind check if the bind is used by res or any of the bound
+ -- expressions
+ dobind (bndr, _) = any (expr_uses_binders [bndr]) (res:bound_exprs)
+-- Leave all other expressions unchanged
+letremoveunused expr = return expr
+letremoveunusedtop = everywhere ("letremoveunused", letremoveunused)
+
--------------------------------
-- Function inlining
--------------------------------
-- What transforms to run?
-transforms = [argproptop, funextracttop, etatop, betatop, castproptop, letremovetop, letrectop, letsimpltop, letflattop, scrutsimpltop, casesimpltop, caseremovetop, inlinenonreptop, appsimpltop]
+transforms = [argproptop, funextracttop, etatop, betatop, castproptop, letremovetop, letrectop, letsimpltop, letflattop, scrutsimpltop, casesimpltop, caseremovetop, inlinenonreptop, appsimpltop, letremoveunusedtop]
-- | Returns the normalized version of the given function.
getNormalized ::
-- Normalize this expression
trace ("Transforming " ++ what ++ "\nBefore:\n\n" ++ showSDoc ( ppr expr' ) ++ "\n") $ return ()
expr'' <- dotransforms transforms expr'
- trace ("\nAfter:\n\n" ++ showSDoc ( ppr expr')) $ return ()
+ trace ("\nAfter:\n\n" ++ showSDoc ( ppr expr'')) $ return ()
return expr''
-- | Get the value that is bound to the given binder at top level. Fails when
setChanged
return val
+-- Returns the given value and sets the changed flag if the bool given is
+-- True. Note that this will not unset the changed flag if the bool is False.
+changeif :: Bool -> a -> TransformMonad a
+changeif True val = change val
+changeif False val = return val
+
-- Replace each of the binders given with the coresponding expressions in the
-- given expression.
substitute :: [(CoreBndr, CoreExpr)] -> CoreExpr -> CoreExpr
-> String -- ^ The TopEntity
-> String -- ^ The InitState
-> String -- ^ The TestInput
- -> Bool -- ^ Is it stateful? (in case InitState is empty)
-> IO ()
-makeVHDLStrings libdir filenames topentity initstate testinput stateful = do
- makeVHDL libdir filenames finder stateful
+makeVHDLStrings libdir filenames topentity initstate testinput = do
+ makeVHDL libdir filenames finder
where
finder = findSpec (hasVarName topentity)
(hasVarName initstate)
makeVHDLAnnotations ::
FilePath -- ^ The GHC Library Dir
-> [FilePath] -- ^ The FileNames
- -> Bool -- ^ Is it stateful? (in case InitState is not specified)
-> IO ()
-makeVHDLAnnotations libdir filenames stateful = do
- makeVHDL libdir filenames finder stateful
+makeVHDLAnnotations libdir filenames = do
+ makeVHDL libdir filenames finder
where
finder = findSpec (hasCLasHAnnotation isTopEntity)
(hasCLasHAnnotation isInitState)
FilePath -- ^ The GHC Library Dir
-> [FilePath] -- ^ The Filenames
-> Finder
- -> Bool -- ^ Indicates if it is meant to be stateful
-> IO ()
-makeVHDL libdir filenames finder stateful = do
+makeVHDL libdir filenames finder = do
-- Load the modules
(cores, env, specs) <- loadModules libdir filenames (Just finder)
-- Translate to VHDL
- vhdl <- moduleToVHDL env cores specs stateful
+ vhdl <- moduleToVHDL env cores specs
-- Write VHDL to file. Just use the first entity for the name
let top_entity = (\(t, _, _) -> t) $ head specs
let dir = "./vhdl/" ++ (show top_entity) ++ "/"
mapM (writeVHDL dir) vhdl
return ()
--- | Translate the binds with the given names from the given core module to
--- VHDL. The Bool in the tuple makes the function stateful (True) or
--- stateless (False).
+-- | Translate the specified entities in the given modules to VHDL.
moduleToVHDL ::
HscTypes.HscEnv -- ^ The GHC Environment
-> [HscTypes.CoreModule] -- ^ The Core Modules
-> [EntitySpec] -- ^ The entities to generate
- -> Bool -- ^ Is it stateful (in case InitState is not specified)
-> IO [(AST.VHDLId, AST.DesignFile)]
-moduleToVHDL env cores specs stateful = do
+moduleToVHDL env cores specs = do
vhdl <- runTranslatorSession env $ do
let all_bindings = concat (map (\x -> CoreSyn.flattenBinds (HscTypes.cm_binds x)) cores)
-- Store the bindings we loaded
-----------------------------------------------------------------------------
-- A orderable equivalent of CoreSyn's Type for use as a map key
-newtype OrdType = OrdType { getType :: Type.Type }
+newtype OrdType = OrdType Type.Type
instance Eq OrdType where
(OrdType a) == (OrdType b) = Type.tcEqType a b
instance Ord OrdType where
BuiltinType String
deriving (Eq, Ord)
--- A map of a Core type to the corresponding type name
-type TypeMap = Map.Map HType (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn)
+-- A map of a Core type to the corresponding type name, or Nothing when the
+-- type would be empty.
+type TypeMap = Map.Map HType (Maybe (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn))
-- A map of a vector Core element type and function name to the coressponding
-- VHDLId of the function and the function body.
-> m [a]
concatM = Monad.liftM concat
+isJustM :: (Monad m) => m (Maybe a) -> m Bool
+isJustM = Monad.liftM Maybe.isJust
+{-# LANGUAGE PatternGuards, TypeSynonymInstances #-}
-- | This module provides a number of functions to find out things about Core
-- programs. This module does not provide the actual plumbing to work with
-- Core and Haskell (it uses HsTools for this), but only the functions that
import qualified RdrName
import qualified Name
import qualified OccName
+import qualified Type
+import qualified Id
+import qualified TyCon
import qualified TysWiredIn
import qualified Bag
import qualified DynFlags
has_free_vars :: CoreSyn.CoreExpr -> Bool
has_free_vars = not . VarSet.isEmptyVarSet . CoreFVs.exprFreeVars
+-- Does the given expression use any of the given binders?
+expr_uses_binders :: [CoreSyn.CoreBndr] -> CoreSyn.CoreExpr -> Bool
+expr_uses_binders bndrs = not . VarSet.isEmptyVarSet . (CoreFVs.exprSomeFreeVars (`elem` bndrs))
+
-- Turns a Var CoreExpr into the Id inside it. Will of course only work for
-- simple Var CoreExprs, not complexer ones.
exprToVar :: CoreSyn.CoreExpr -> Var.Id
otherwise -> []
reduceCoreListToHsList _ = []
+
+-- | Is the given type a State type?
+isStateType :: Type.Type -> Bool
+-- Resolve any type synonyms remaining
+isStateType ty | Just ty' <- Type.tcView ty = isStateType ty'
+isStateType ty = Maybe.isJust $ do
+ -- Split the type. Don't use normal splitAppTy, since that looks through
+ -- newtypes, and we want to see the State newtype.
+ (typef, _) <- Type.repSplitAppTy_maybe ty
+ -- See if the applied type is a type constructor
+ (tycon, _) <- Type.splitTyConApp_maybe typef
+ if TyCon.isNewTyCon tycon && Name.getOccString tycon == "State"
+ then
+ Just ()
+ else
+ Nothing
+
+-- | Does the given TypedThing have a State type?
+hasStateType :: (TypedThing t) => t -> Bool
+hasStateType expr = case getType expr of
+ Nothing -> False
+ Just ty -> isStateType ty
+
+
+-- | A class of things that (optionally) have a core Type. The type is
+-- optional, since Type expressions don't have a type themselves.
+class TypedThing t where
+ getType :: t -> Maybe Type.Type
+
+instance TypedThing CoreSyn.CoreExpr where
+ getType (CoreSyn.Type _) = Nothing
+ getType expr = Just $ CoreUtils.exprType expr
+
+instance TypedThing CoreSyn.CoreBndr where
+ getType = return . Id.idType
+
+instance TypedThing Type.Type where
+ getType = return . id
import CLasH.VHDL.Constants
import CLasH.VHDL.VHDLTypes
import CLasH.VHDL.VHDLTools
-import qualified CLasH.Utils as Utils
+import CLasH.Utils as Utils
import CLasH.Utils.Core.CoreTools
import CLasH.Utils.Pretty
import qualified CLasH.Normalize as Normalize
expr <- Normalize.getNormalized fname
-- Strip off lambda's, these will be arguments
let (args, letexpr) = CoreSyn.collectBinders expr
- args' <- mapM mkMap args
+ -- Generate ports for all non-state types
+ args' <- catMaybesM $ mapM mkMap args
-- There must be a let at top level
let (CoreSyn.Let binds (CoreSyn.Var res)) = letexpr
- res' <- mkMap res
+ -- TODO: Handle Nothing
+ Just res' <- mkMap res
let vhdl_id = mkVHDLBasicId $ varToString fname ++ "_" ++ varToStringUniq fname
let ent_decl = createEntityAST vhdl_id args' res'
let signature = Entity vhdl_id args' res' ent_decl
mkMap ::
--[(SignalId, SignalInfo)]
CoreSyn.CoreBndr
- -> TranslatorSession Port
+ -> TranslatorSession (Maybe Port)
mkMap = (\bndr ->
let
--info = Maybe.fromMaybe
ty = Var.varType bndr
error_msg = "\nVHDL.createEntity.mkMap: Can not create entity: " ++ pprString fname ++ "\nbecause no type can be created for port: " ++ pprString bndr
in do
- type_mark <- MonadState.lift tsType $ vhdl_ty error_msg ty
- return (id, type_mark)
+ type_mark_maybe <- MonadState.lift tsType $ vhdl_ty error_msg ty
+ case type_mark_maybe of
+ Just type_mark -> return $ Just (id, type_mark)
+ Nothing -> return Nothing
)
-- | Create the VHDL AST for an entity
-- A single alt case must be a selector. This means thee scrutinee is a simple
-- variable, the alternative is a dataalt with a single non-wild binder that
-- is also returned.
-mkConcSm (bndr, expr@(CoreSyn.Case (CoreSyn.Var scrut) b ty [alt])) =
+mkConcSm (bndr, expr@(CoreSyn.Case (CoreSyn.Var scrut) b ty [alt]))
+ -- Don't generate VHDL for substate extraction
+ | hasStateType bndr = return ([], [])
+ | otherwise =
case alt of
(CoreSyn.DataAlt dc, bndrs, (CoreSyn.Var sel_bndr)) -> do
- case List.elemIndex sel_bndr bndrs of
+ bndrs' <- Monad.filterM hasNonEmptyType bndrs
+ case List.elemIndex sel_bndr bndrs' of
Just i -> do
labels <- MonadState.lift tsType $ getFieldLabels (Id.idType scrut)
let label = labels!!i
-- | A function to wrap a builder-like function that expects its arguments to
-- be expressions.
genExprArgs wrap dst func args = do
- args' <- eitherCoreOrExprArgs args
+ args' <- argsToVHDLExprs args
wrap dst func args'
-eitherCoreOrExprArgs :: [Either CoreSyn.CoreExpr AST.Expr] -> TranslatorSession [AST.Expr]
-eitherCoreOrExprArgs args = mapM (Either.either ((MonadState.lift tsType) . varToVHDLExpr . exprToVar) return) args
+-- | Turn the all lefts into VHDL Expressions.
+argsToVHDLExprs :: [Either CoreSyn.CoreExpr AST.Expr] -> TranslatorSession [AST.Expr]
+argsToVHDLExprs = catMaybesM . (mapM argToVHDLExpr)
+
+argToVHDLExpr :: Either CoreSyn.CoreExpr AST.Expr -> TranslatorSession (Maybe AST.Expr)
+argToVHDLExpr (Left expr) = MonadState.lift tsType $ do
+ let errmsg = "Generate.argToVHDLExpr: Using non-representable type? Should not happen!"
+ ty_maybe <- vhdl_ty errmsg expr
+ case ty_maybe of
+ Just _ -> do
+ vhdl_expr <- varToVHDLExpr $ exprToVar expr
+ return $ Just vhdl_expr
+ Nothing -> return $ Nothing
+
+argToVHDLExpr (Right expr) = return $ Just expr
-- A function to wrap a builder-like function that generates no component
-- instantiations
-- temporary vector
let tmp_ty = Type.mkAppTy nvec (Var.varType start)
let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty
- tmp_vhdl_ty <- MonadState.lift tsType $ vhdl_ty error_msg tmp_ty
+ -- TODO: Handle Nothing
+ Just tmp_vhdl_ty <- MonadState.lift tsType $ vhdl_ty error_msg tmp_ty
-- Setup the generate scheme
let gen_label = mkVHDLExtId ("foldlVector" ++ (varToString vec))
let block_label = mkVHDLExtId ("foldlVector" ++ (varToString res))
-- -- temporary vector
let tmp_ty = Var.varType res
let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty
- tmp_vhdl_ty <- MonadState.lift tsType $ vhdl_ty error_msg tmp_ty
+ -- TODO: Handle Nothing
+ Just tmp_vhdl_ty <- MonadState.lift tsType $ vhdl_ty error_msg tmp_ty
-- Setup the generate scheme
let gen_label = mkVHDLExtId ("iterateVector" ++ (varToString start))
let block_label = mkVHDLExtId ("iterateVector" ++ (varToString res))
-- Local binder that references a top level binding. Generate a
-- component instantiation.
signature <- getEntity f
- args' <- eitherCoreOrExprArgs args
+ args' <- argsToVHDLExprs args
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 portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature
+ portmaps <- mkAssocElems args' ((either varToVHDLName id) dst) signature
return ([mkComponentInst label entity_id portmaps], [f])
False -> do
-- Not a top level binder, so this must be a local variable reference.
-- assignment here.
f' <- MonadState.lift tsType $ varToVHDLExpr f
return $ ([mkUncondAssign dst f'], [])
- True ->
+ True | not stateful ->
case Var.idDetails f of
IdInfo.DataConWorkId dc -> case dst of
-- It's a datacon. Create a record from its arguments.
Left bndr -> do
-- We have the bndr, so we can get at the type
labels <- MonadState.lift tsType $ getFieldLabels (Var.varType bndr)
- args' <- eitherCoreOrExprArgs args
+ args' <- argsToVHDLExprs args
return $ (zipWith mkassign labels $ args', [])
where
mkassign :: AST.VHDLId -> AST.Expr -> AST.ConcSm
error $ "\nGenerate.genApplication(ClassOpId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
Nothing -> error $ "\nGenerate.genApplication(ClassOpId): Using function from another module that is not a known builtin: " ++ pprString f
details -> error $ "\nGenerate.genApplication: Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details
+ -- If we can't generate a component instantiation, and the destination is
+ -- a state type, don't generate anything.
+ _ -> return ([], [])
+ where
+ -- Is our destination a state value?
+ stateful = case dst of
+ -- When our destination is a VHDL name, it won't have had a state type
+ Right _ -> False
+ -- Otherwise check its type
+ Left bndr -> hasStateType bndr
-----------------------------------------------------------------------------
-- Functions to generate functions dealing with vectors.
vectorFunId :: Type.Type -> String -> TypeSession AST.VHDLId
vectorFunId el_ty fname = do
let error_msg = "\nGenerate.vectorFunId: Can not construct vector function for element: " ++ pprString el_ty
- elemTM <- vhdl_ty error_msg el_ty
+ -- TODO: Handle the Nothing case?
+ Just elemTM <- vhdl_ty error_msg el_ty
-- TODO: This should not be duplicated from mk_vector_ty. Probably but it in
-- the VHDLState or something.
let vectorTM = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId elemTM)
---
-- Functions to create a VHDL testbench from a list of test input.
--
module CLasH.VHDL.Testbench where
[AST.SigDec clockId std_logicTM (Just $ AST.PrimLit "'0'"),
AST.SigDec resetId std_logicTM (Just $ AST.PrimLit "'0'")]
let oDecs = AST.SigDec (fst oIface) (snd oIface) Nothing
- let portmaps = mkAssocElems (map idToVHDLExpr iIds) (AST.NSimple oId) signature
+ portmaps <- mkAssocElems (map idToVHDLExpr iIds) (AST.NSimple oId) signature
let mIns = mkComponentInst "totest" entId portmaps
(stimuliAssigns, stimuliDecs, cycles, used) <- createStimuliAssigns mCycles stimuli (head iIds)
let finalAssigns = (AST.CSSASm (AST.NSimple resetId AST.:<==:
+{-# LANGUAGE RelaxedPolyRec #-} -- Needed for vhdl_ty_either', for some reason...
module CLasH.VHDL.VHDLTools where
-- Standard modules
import qualified Type
import qualified DataCon
import qualified CoreSubst
+import qualified Outputable
-- Local imports
import CLasH.VHDL.VHDLTypes
import CLasH.Translator.TranslatorTypes
import CLasH.Utils.Core.CoreTools
+import CLasH.Utils
import CLasH.Utils.Pretty
import CLasH.VHDL.Constants
[AST.Expr] -- ^ The argument that are applied to function
-> AST.VHDLName -- ^ The binder in which to store the result
-> Entity -- ^ The entity to map against.
- -> [AST.AssocElem] -- ^ The resulting port maps
+ -> TranslatorSession [AST.AssocElem] -- ^ The resulting port maps
mkAssocElems args res entity =
-- Create the actual AssocElems
- zipWith mkAssocElem ports sigs
+ return $ zipWith mkAssocElem ports sigs
where
-- Turn the ports and signals from a map into a flat list. This works,
-- since the maps must have an identical form by definition. TODO: Check
mkAssocElem :: AST.VHDLId -> AST.Expr -> AST.AssocElem
mkAssocElem port signal = Just port AST.:=>: (AST.ADExpr signal)
--- | Create an VHDL port -> signal association
-mkAssocElemIndexed :: AST.VHDLId -> AST.VHDLId -> AST.VHDLId -> AST.AssocElem
-mkAssocElemIndexed port signal index = Just port AST.:=>: (AST.ADName (AST.NIndexed (AST.IndexedName
- (AST.NSimple signal) [AST.PrimName $ AST.NSimple index])))
-
-- | Create an aggregate signal
mkAggregateSignal :: [AST.Expr] -> AST.Expr
mkAggregateSignal x = AST.Aggregate (map (\z -> AST.ElemAssoc Nothing z) x)
-- for a few builtin types.
builtin_types =
Map.fromList [
- ("Bit", std_logicTM),
- ("Bool", booleanTM), -- TysWiredIn.boolTy
- ("Dec", integerTM)
+ ("Bit", Just std_logicTM),
+ ("Bool", Just booleanTM), -- TysWiredIn.boolTy
+ ("Dec", Just integerTM)
]
-- Translate a Haskell type to a VHDL type, generating a new type if needed.
-- Returns an error value, using the given message, when no type could be
--- created.
-vhdl_ty :: String -> Type.Type -> TypeSession AST.TypeMark
+-- created. Returns Nothing when the type is valid, but empty.
+vhdl_ty :: (TypedThing t, Outputable.Outputable t) =>
+ String -> t -> TypeSession (Maybe AST.TypeMark)
vhdl_ty msg ty = do
tm_either <- vhdl_ty_either ty
case tm_either of
-- Translate a Haskell type to a VHDL type, generating a new type if needed.
-- Returns either an error message or the resulting type.
-vhdl_ty_either :: Type.Type -> TypeSession (Either String AST.TypeMark)
-vhdl_ty_either ty = do
+vhdl_ty_either :: (TypedThing t, Outputable.Outputable t) =>
+ t -> TypeSession (Either String (Maybe AST.TypeMark))
+vhdl_ty_either tything =
+ case getType tything of
+ Nothing -> return $ Left $ "VHDLTools.vhdl_ty: Typed thing without a type: " ++ pprString tything
+ Just ty -> vhdl_ty_either' ty
+
+vhdl_ty_either' :: Type.Type -> TypeSession (Either String (Maybe AST.TypeMark))
+vhdl_ty_either' ty = do
typemap <- getA tsTypes
htype_either <- mkHType ty
case htype_either of
let name = Name.getOccString (TyCon.tyConName tycon)
Map.lookup name builtin_types
-- If not a builtin type, try the custom types
- let existing_ty = (fmap fst) $ Map.lookup htype typemap
+ let existing_ty = (Monad.liftM $ fmap fst) $ Map.lookup htype typemap
case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of
-- Found a type, return it
Just t -> return (Right t)
-- No type yet, try to construct it
Nothing -> do
- newty_maybe <- (construct_vhdl_ty ty)
- case newty_maybe of
- Right (ty_id, ty_def) -> do
+ newty_either <- (construct_vhdl_ty ty)
+ case newty_either of
+ Right newty -> do
-- TODO: Check name uniqueness
- modA tsTypes (Map.insert htype (ty_id, ty_def))
- modA tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)])
- return (Right ty_id)
+ modA tsTypes (Map.insert htype newty)
+ case newty of
+ Just (ty_id, ty_def) -> do
+ modA tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)])
+ return (Right $ Just ty_id)
+ Nothing -> return $ Right Nothing
Left err -> return $ Left $
"VHDLTools.vhdl_ty: Unsupported Haskell type: " ++ pprString ty ++ "\n"
++ err
-- Construct a new VHDL type for the given Haskell type. Returns an error
-- message or the resulting typemark and typedef.
-construct_vhdl_ty :: Type.Type -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
+construct_vhdl_ty :: Type.Type -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))
+-- State types don't generate VHDL
+construct_vhdl_ty ty | isStateType ty = return $ Right Nothing
construct_vhdl_ty ty = do
case Type.splitTyConApp_maybe ty of
Just (tycon, args) -> do
Nothing -> return (Left $ "VHDLTools.construct_vhdl_ty: Cannot create type for non-tycon type: " ++ pprString ty ++ "\n")
-- | Create VHDL type for a custom tycon
-mk_tycon_ty :: Type.Type -> TyCon.TyCon -> [Type.Type] -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
+mk_tycon_ty :: Type.Type -> TyCon.TyCon -> [Type.Type] -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))
mk_tycon_ty ty tycon args =
case TyCon.tyConDataCons tycon of
-- Not an algebraic type
elem_tys_either <- mapM vhdl_ty_either real_arg_tys
case Either.partitionEithers elem_tys_either of
-- No errors in element types
- ([], elem_tys) -> do
- let elems = zipWith AST.ElementDec recordlabels elem_tys
- -- For a single construct datatype, build a record with one field for
- -- each argument.
- -- TODO: Add argument type ids to this, to ensure uniqueness
- -- TODO: Special handling for tuples?
- let elem_names = concat $ map prettyShow elem_tys
- let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon) ++ elem_names
- let ty_def = AST.TDR $ AST.RecordTypeDef elems
- let tupshow = mkTupleShow elem_tys ty_id
- modA tsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, tupshow)
- return $ Right (ty_id, Left ty_def)
+ ([], elem_tys') -> do
+ -- Throw away all empty members
+ case Maybe.catMaybes elem_tys' of
+ [] -> -- No non-empty members
+ return $ Right Nothing
+ elem_tys -> do
+ let elems = zipWith AST.ElementDec recordlabels elem_tys
+ -- For a single construct datatype, build a record with one field for
+ -- each argument.
+ -- TODO: Add argument type ids to this, to ensure uniqueness
+ -- TODO: Special handling for tuples?
+ let elem_names = concat $ map prettyShow elem_tys
+ let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon) ++ elem_names
+ let ty_def = AST.TDR $ AST.RecordTypeDef elems
+ let tupshow = mkTupleShow elem_tys ty_id
+ modA tsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, tupshow)
+ return $ Right $ Just (ty_id, Left ty_def)
-- There were errors in element types
(errors, _) -> return $ Left $
"VHDLTools.mk_tycon_ty: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
-- | Create a VHDL vector type
mk_vector_ty ::
Type.Type -- ^ The Haskell type of the Vector
- -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
+ -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))
-- ^ An error message or The typemark created.
mk_vector_ty ty = do
el_ty_tm_either <- vhdl_ty_either el_ty
case el_ty_tm_either of
-- Could create element type
- Right el_ty_tm -> do
+ Right (Just el_ty_tm) -> do
let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId el_ty_tm) ++ "-0_to_" ++ (show len)
let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
- let existing_elem_ty = (fmap fst) $ Map.lookup (StdType $ OrdType vec_ty) types_map
+ let existing_elem_ty = (fmap $ fmap fst) $ Map.lookup (StdType $ OrdType vec_ty) types_map
case existing_elem_ty of
- Just t -> do
+ Just (Just t) -> do
let ty_def = AST.SubtypeIn t (Just range)
- return (Right (ty_id, Right ty_def))
+ return (Right $ Just (ty_id, Right ty_def))
Nothing -> do
let vec_id = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId el_ty_tm)
let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] el_ty_tm
- modA tsTypes (Map.insert (StdType $ OrdType vec_ty) (vec_id, (Left vec_def)))
+ modA tsTypes (Map.insert (StdType $ OrdType vec_ty) (Just (vec_id, (Left vec_def))))
modA tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (vec_id, (Left vec_def))])
let vecShowFuns = mkVectorShow el_ty_tm vec_id
mapM_ (\(id, subprog) -> modA tsTypeFuns $ Map.insert (OrdType vec_ty, id) ((mkVHDLExtId id), subprog)) vecShowFuns
let ty_def = AST.SubtypeIn vec_id (Just range)
- return (Right (ty_id, Right ty_def))
+ return (Right $ Just (ty_id, Right ty_def))
+ -- Empty element type? Empty vector type then. TODO: Does this make sense?
+ -- Probably needs changes in the builtin functions as well...
+ Right Nothing -> return $ Right Nothing
-- Could not create element type
Left err -> return $ Left $
"VHDLTools.mk_vector_ty: Can not construct vectortype for elementtype: " ++ pprString el_ty ++ "\n"
mk_natural_ty ::
Int -- ^ The minimum bound (> 0)
-> Int -- ^ The maximum bound (> minimum bound)
- -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
+ -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))
-- ^ An error message or The typemark created.
mk_natural_ty min_bound max_bound = do
let ty_id = mkVHDLExtId $ "nat_" ++ (show min_bound) ++ "_to_" ++ (show max_bound)
let range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit $ (show min_bound)) (AST.PrimLit $ (show max_bound))
let ty_def = AST.SubtypeIn naturalTM (Just range)
- return (Right (ty_id, Right ty_def))
+ return (Right $ Just (ty_id, Right ty_def))
mk_unsigned_ty ::
Type.Type -- ^ Haskell type of the unsigned integer
- -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
+ -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))
mk_unsigned_ty ty = do
size <- tfp_to_int (sized_word_len_ty ty)
let ty_id = mkVHDLExtId $ "unsigned_" ++ show (size - 1)
let ty_def = AST.SubtypeIn unsignedTM (Just range)
let unsignedshow = mkIntegerShow ty_id
modA tsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, unsignedshow)
- return (Right (ty_id, Right ty_def))
+ return (Right $ Just (ty_id, Right ty_def))
mk_signed_ty ::
Type.Type -- ^ Haskell type of the signed integer
- -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
+ -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))
mk_signed_ty ty = do
size <- tfp_to_int (sized_int_len_ty ty)
let ty_id = mkVHDLExtId $ "signed_" ++ show (size - 1)
let ty_def = AST.SubtypeIn signedTM (Just range)
let signedshow = mkIntegerShow ty_id
modA tsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, signedshow)
- return (Right (ty_id, Right ty_def))
+ return (Right $ Just (ty_id, Right ty_def))
-- Finds the field labels for VHDL type generated for the given Core type,
-- which must result in a record type.
-- Assume the type for which we want labels is really translatable
Right htype <- mkHType ty
case Map.lookup htype types of
- Just (_, Left (AST.TDR (AST.RecordTypeDef elems))) -> return $ map (\(AST.ElementDec id _) -> id) elems
+ Just (Just (_, Left (AST.TDR (AST.RecordTypeDef elems)))) -> return $ map (\(AST.ElementDec id _) -> id) elems
+ Just Nothing -> return [] -- The type is empty
_ -> error $ "\nVHDL.getFieldLabels: Type not found or not a record type? This should not happen! Type: " ++ (show ty)
mktydecl :: (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn) -> AST.PackageDecItem
showExpr = AST.ReturnSm (Just $
AST.PrimLit "'('" AST.:&: showMiddle AST.:&: AST.PrimLit "')'")
where
- showMiddle = foldr1 (\e1 e2 -> e1 AST.:&: AST.PrimLit "','" AST.:&: e2) $
- map ((genExprFCall showId).
- AST.PrimName .
- AST.NSelected .
- (AST.NSimple tupPar AST.:.:).
- tupVHDLSuffix)
- (take tupSize recordlabels)
+ showMiddle = if null elemTMs then
+ AST.PrimLit "''"
+ else
+ foldr1 (\e1 e2 -> e1 AST.:&: AST.PrimLit "','" AST.:&: e2) $
+ map ((genExprFCall showId).
+ AST.PrimName .
+ AST.NSelected .
+ (AST.NSimple tupPar AST.:.:).
+ tupVHDLSuffix)
+ (take tupSize recordlabels)
recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
tupSize = length elemTMs
map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [arg1,arg2]
mkSigDec :: CoreSyn.CoreBndr -> TranslatorSession (Maybe AST.SigDec)
-mkSigDec bndr =
- if True then do --isInternalSigUse use || isStateSigUse use then do
- let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString bndr
- type_mark <- MonadState.lift tsType $ vhdl_ty error_msg (Var.varType bndr)
- return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing)
- else
- return Nothing
+mkSigDec bndr = do
+ let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString bndr
+ type_mark_maybe <- MonadState.lift tsType $ vhdl_ty error_msg (Var.varType bndr)
+ case type_mark_maybe of
+ Just type_mark -> return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing)
+ Nothing -> return Nothing
+
+-- | Does the given thing have a non-empty type?
+hasNonEmptyType :: (TypedThing t, Outputable.Outputable t) =>
+ t -> TranslatorSession Bool
+hasNonEmptyType thing = MonadState.lift tsType $ isJustM (vhdl_ty "hasNonEmptyType: Non representable type?" thing)
projects / matthijs / master-project / cλash.git / commitdiff