+ dobind :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The bind to process
+ -> TranslatorSession ((Maybe CoreSyn.CoreBndr, Maybe CoreSyn.CoreBndr), ([AST.ConcSm], [CoreSyn.CoreBndr]))
+ -- ^ ((Input state variable, output state variable), (statements, used entities))
+ -- newtype unpacking is just a cast
+ dobind (bndr, unpacked@(CoreSyn.Cast packed coercion))
+ | hasStateType packed && not (hasStateType unpacked)
+ = return ((Just bndr, Nothing), ([], []))
+ -- With simplCore, newtype packing is just a cast
+ dobind (bndr, packed@(CoreSyn.Cast unpacked@(CoreSyn.Var state) coercion))
+ | hasStateType packed && not (hasStateType unpacked)
+ = return ((Nothing, Just state), ([], []))
+ -- Without simplCore, newtype packing uses a data constructor
+ dobind (bndr, (CoreSyn.App (CoreSyn.App (CoreSyn.Var con) (CoreSyn.Type _)) (CoreSyn.Var state)))
+ | isStateCon con
+ = return ((Nothing, Just state), ([], []))
+ -- Anything else is handled by mkConcSm
+ dobind bind = do
+ sms <- mkConcSm bind
+ return ((Nothing, Nothing), sms)
+
+mkStateProcSm ::
+ (CoreSyn.CoreBndr, CoreSyn.CoreBndr, CoreSyn.CoreBndr) -- ^ The current state, new state and reset variables
+ -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr]) -- ^ The resulting statements
+mkStateProcSm (old, new, res) = 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
+ (error $ "\nGenerate.mkStateProcSm: empty type for state? Type: " ++ pprString (Var.varType old))
+ type_mark_old_maybe
+ type_mark_res_maybe <- MonadState.lift tsType $ vhdlTy error_msg (Var.varType res)
+ let type_mark_res' = Maybe.fromMaybe
+ (error $ "\nGenerate.mkStateProcSm: empty type for initial state? Type: " ++ pprString (Var.varType res))
+ type_mark_res_maybe
+ let type_mark_res = if type_mark_old == type_mark_res' then
+ type_mark_res'
+ else
+ error $ "Initial state has different type than state type, state type: " ++ show type_mark_old ++ ", init type: " ++ show type_mark_res'
+ let resvalid = mkVHDLExtId $ varToString res ++ "val"
+ let resvaldec = AST.BDISD $ AST.SigDec resvalid type_mark_res Nothing
+ let reswform = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple resvalid) Nothing]
+ let res_assign = AST.SigAssign (varToVHDLName old) reswform
+ let blocklabel = mkVHDLBasicId "state"
+ let statelabel = mkVHDLBasicId "stateupdate"
+ let rising_edge = AST.NSimple $ mkVHDLBasicId "rising_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 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]]
+ 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]
+ return ([block],[res])