import HsValueMap
import Pretty
import CoreTools
+import Constants
+import Generate
+import GlobalNameTable
createDesignFiles ::
FlatFuncMap
map (Arrow.second $ AST.DesignFile full_context) units
where
- init_session = VHDLSession Map.empty builtin_funcs
+ init_session = VHDLSession Map.empty Map.empty builtin_funcs globalNameTable
(units, final_session) =
State.runState (createLibraryUnits flatfuncmap) init_session
ty_decls = Map.elems (final_session ^. vsTypes)
-> SignalId
-> VHDLState VHDLSignalMapElement
-- We only need the vsTypes element from the state
- mkMap sigmap = MonadState.lift vsTypes . (\id ->
+ mkMap sigmap = (\id ->
let
info = Maybe.fromMaybe
(error $ "Signal not found in the name map? This should not happen!")
sig_dec_maybes <- mapM (mkSigDec' . snd) sigs
let sig_decs = Maybe.catMaybes $ sig_dec_maybes
-- Create concurrent statements for all signal definitions
- let statements = zipWith (mkConcSm signaturemap sigs) defs [0..]
+ statements <- Monad.zipWithM (mkConcSm sigs) defs [0..]
return $ AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
where
sigs = flat_sigs flatfunc
procs = map mkStateProcSm (makeStatePairs flatfunc)
procs' = map AST.CSPSm procs
-- mkSigDec only uses vsTypes from the state
- mkSigDec' = MonadState.lift vsTypes . mkSigDec
+ mkSigDec' = mkSigDec
-- | Looks up all pairs of old state, new state signals, together with
-- the state id they represent.
rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
statement = AST.IfSm rising_edge_clk [assign] [] Nothing
-mkSigDec :: SignalInfo -> TypeState (Maybe AST.SigDec)
+mkSigDec :: SignalInfo -> VHDLState (Maybe AST.SigDec)
mkSigDec info =
let use = sigUse info in
if isInternalSigUse use || isStateSigUse use then do
-- | Transforms a signal definition into a VHDL concurrent statement
mkConcSm ::
- SignatureMap -- ^ The interfaces of functions in the session
- -> [(SignalId, SignalInfo)] -- ^ The signals in the current architecture
+ [(SignalId, SignalInfo)] -- ^ The signals in the current architecture
-> SigDef -- ^ The signal definition
-> Int -- ^ A number that will be unique for all
-- concurrent statements in the architecture.
- -> AST.ConcSm -- ^ The corresponding VHDL component instantiation.
+ -> VHDLState AST.ConcSm -- ^ The corresponding VHDL component instantiation.
-mkConcSm signatures sigs (FApp hsfunc args res) num =
+mkConcSm sigs (FApp hsfunc args res) num = do
+ signatures <- getA vsSignatures
let
- signature = Maybe.fromMaybe
- (error $ "Using function '" ++ (prettyShow hsfunc) ++ "' without signature? This should not happen!")
- (Map.lookup hsfunc signatures)
- entity_id = ent_id signature
- label = (AST.fromVHDLId entity_id) ++ "_" ++ (show num)
- -- Add a clk port if we have state
- clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
- portmaps = mkAssocElems sigs args res signature ++ (if hasState hsfunc then [clk_port] else [])
- in
- AST.CSISm $ AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)
-
-mkConcSm _ sigs (UncondDef src dst) _ =
- let
- src_expr = vhdl_expr src
- src_wform = AST.Wform [AST.WformElem src_expr Nothing]
- dst_name = AST.NSimple (getSignalId $ signalInfo sigs dst)
- assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
- in
- AST.CSSASm assign
+ signature = Maybe.fromMaybe
+ (error $ "Using function '" ++ (prettyShow hsfunc) ++ "' without signature? This should not happen!")
+ (Map.lookup hsfunc signatures)
+ entity_id = ent_id signature
+ label = (AST.fromVHDLId entity_id) ++ "_" ++ (show num)
+ -- Add a clk port if we have state
+ clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
+ portmaps = mkAssocElems sigs args res signature ++ (if hasState hsfunc then [clk_port] else [])
+ in
+ return $ AST.CSISm $ AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)
+
+mkConcSm sigs (UncondDef src dst) _ = do
+ src_expr <- vhdl_expr src
+ let src_wform = AST.Wform [AST.WformElem src_expr Nothing]
+ let dst_name = AST.NSimple (getSignalId $ signalInfo sigs dst)
+ let assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
+ return $ AST.CSSASm assign
where
- vhdl_expr (Left id) = mkIdExpr sigs id
+ vhdl_expr (Left id) = return $ mkIdExpr sigs id
vhdl_expr (Right expr) =
case expr of
(EqLit id lit) ->
- (mkIdExpr sigs id) AST.:=: (AST.PrimLit lit)
- (Literal lit _) ->
- AST.PrimLit lit
+ return $ (mkIdExpr sigs id) AST.:=: (AST.PrimLit lit)
+ (Literal lit Nothing) ->
+ return $ AST.PrimLit lit
+ (Literal lit (Just ty)) -> do
+ -- Create a cast expression, which is just a function call using the
+ -- type name as the function name.
+ let litexpr = AST.PrimLit lit
+ ty_id <- vhdl_ty ty
+ let ty_name = AST.NSimple ty_id
+ let args = [Nothing AST.:=>: (AST.ADExpr litexpr)]
+ return $ AST.PrimFCall $ AST.FCall ty_name args
(Eq a b) ->
- (mkIdExpr sigs a) AST.:=: (mkIdExpr sigs b)
+ return $ (mkIdExpr sigs a) AST.:=: (mkIdExpr sigs b)
-mkConcSm _ sigs (CondDef cond true false dst) _ =
+mkConcSm sigs (CondDef cond true false dst) _ =
let
cond_expr = mkIdExpr sigs cond
true_expr = mkIdExpr sigs true
dst_name = AST.NSimple (getSignalId $ signalInfo sigs dst)
assign = dst_name AST.:<==: (AST.ConWforms [whenelse] false_wform Nothing)
in
- AST.CSSASm assign
+ return $ AST.CSSASm assign
-- | Turn a SignalId into a VHDL Expr
mkIdExpr :: [(SignalId, SignalInfo)] -> SignalId -> AST.Expr
std_logic_ty = AST.unsafeVHDLBasicId "std_logic"
-- Translate a Haskell type to a VHDL type
-vhdl_ty :: Type.Type -> TypeState AST.TypeMark
+vhdl_ty :: Type.Type -> VHDLState AST.TypeMark
vhdl_ty ty = do
- typemap <- State.get
+ typemap <- getA vsTypes
let builtin_ty = do -- See if this is a tycon and lookup its name
(tycon, args) <- Type.splitTyConApp_maybe ty
let name = Name.getOccString (TyCon.tyConName tycon)
(tycon, args) <- Type.splitTyConApp_maybe ty
let name = Name.getOccString (TyCon.tyConName tycon)
case name of
- "FSVec" -> Just $ mk_vector_ty (fsvec_len ty) ty
+ "TFVec" -> Just $ mk_vector_ty (tfvec_len ty) ty
"SizedWord" -> Just $ mk_vector_ty (sized_word_len ty) ty
otherwise -> Nothing
-- Return new_ty when a new type was successfully created
mk_vector_ty ::
Int -- ^ The length of the vector
-> Type.Type -- ^ The Haskell type to create a VHDL type for
- -> TypeState AST.TypeMark -- The typemark created.
+ -> VHDLState AST.TypeMark -- The typemark created.
mk_vector_ty len ty = do
-- Assume there is a single type argument
let ty_def = AST.TDA $ AST.ConsArrayDef range std_logic_ty
let ty_dec = AST.TypeDec ty_id ty_def
-- TODO: Check name uniqueness
- State.modify (Map.insert (OrdType ty) (ty_id, ty_dec))
+ --State.modify (Map.insert (OrdType ty) (ty_id, ty_dec))
+ modA vsTypes (Map.insert (OrdType ty) (ty_id, ty_dec))
+ modA vsTypeFuns (Map.insert (OrdType ty) (genUnconsVectorFuns std_logic_ty ty_id))
return ty_id
projects / matthijs / master-project / cλash.git / blobdiff