(state_vars, sms) <- Monad.mapAndUnzipM dobind binds
let (in_state_maybes, out_state_maybes) = unzip state_vars
let (statementss, used_entitiess) = unzip sms
+ -- Get initial state, if it's there
+ initSmap <- getA tsInitStates
+ let init_state = Map.lookup fname initSmap
-- Create a state proc, if needed
- state_proc <- case (Maybe.catMaybes in_state_maybes, Maybe.catMaybes out_state_maybes) of
- ([in_state], [out_state]) -> mkStateProcSm (in_state, out_state)
- ([], []) -> return []
- (ins, outs) -> error $ "Weird use of state in " ++ show fname ++ ". In: " ++ show ins ++ " Out: " ++ show outs
+ (state_proc, resbndr) <- case (Maybe.catMaybes in_state_maybes, Maybe.catMaybes out_state_maybes, init_state) of
+ ([in_state], [out_state], Nothing) -> error $ "No initial state defined for: " ++ show fname
+ ([in_state], [out_state], Just resetval) -> mkStateProcSm (in_state, out_state,resetval)
+ ([], [], Just _) -> error $ "Initial state defined for state-less function: " ++ show fname
+ ([], [], Nothing) -> return ([],[])
+ (ins, outs, res) -> error $ "Weird use of state in " ++ show fname ++ ". In: " ++ show ins ++ " Out: " ++ show outs
-- Join the create statements and the (optional) state_proc
let statements = concat statementss ++ state_proc
-- Create the architecture
let arch = AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) statements
- let used_entities = concat used_entitiess
+ let used_entities = (concat used_entitiess) ++ resbndr
return (arch, used_entities)
where
dobind :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The bind to process
return ((Nothing, Nothing), sms)
mkStateProcSm ::
- (CoreSyn.CoreBndr, CoreSyn.CoreBndr) -- ^ The current and new state variables
- -> TranslatorSession [AST.ConcSm] -- ^ The resulting statements
-mkStateProcSm (old, new) = do
- nonempty <- hasNonEmptyType old
+ (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
+ nonempty <- hasNonEmptyType old
if nonempty
- then return [AST.CSPSm $ AST.ProcSm label [clockId,resetId] [statement]]
- else return []
- where
- label = mkVHDLBasicId $ "state"
- rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
- wform = AST.Wform [AST.WformElem (AST.PrimName $ varToVHDLName new) Nothing]
- clk_assign = AST.SigAssign (varToVHDLName old) wform
- rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clockId)]
- resetn_is_low = (AST.PrimName $ AST.NSimple resetId) AST.:=: (AST.PrimLit "'0'")
- reset_statement = []
- clk_statement = [AST.ElseIf rising_edge_clk [clk_assign]]
- statement = AST.IfSm resetn_is_low reset_statement clk_statement Nothing
-
+ then do
+ let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString res
+ type_mark_old_maybe <- MonadState.lift tsType $ vhdl_ty error_msg (Var.varType old)
+ let type_mark_old = Maybe.fromJust type_mark_old_maybe
+ type_mark_res_maybe <- MonadState.lift tsType $ vhdl_ty error_msg (Var.varType res)
+ let type_mark_res' = Maybe.fromJust 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 = mkVHDLBasicId $ 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] [statement]
+ let block = AST.CSBSm $ AST.BlockSm blocklabel [] (AST.PMapAspect []) [resvaldec] [reset_statement,stateupdate]
+ return ([block],[res])
+ else
+ return ([],[])
-- | Transforms a core binding into a VHDL concurrent statement
mkConcSm ::
-- binders in the alts and only variables in the case values and a variable
-- for a scrutinee. We check the constructor of the second alt, since the
-- first is the default case, if there is any.
-mkConcSm (bndr, (CoreSyn.Case (CoreSyn.Var scrut) b ty [(_, _, CoreSyn.Var false), (con, _, CoreSyn.Var true)])) = do
+
+-- mkConcSm (bndr, (CoreSyn.Case (CoreSyn.Var scrut) b ty [(_, _, CoreSyn.Var false), (con, _, CoreSyn.Var true)])) = do
+-- scrut' <- MonadState.lift tsType $ varToVHDLExpr scrut
+-- altcon <- MonadState.lift tsType $ altconToVHDLExpr con
+-- let cond_expr = scrut' AST.:=: altcon
+-- true_expr <- MonadState.lift tsType $ varToVHDLExpr true
+-- false_expr <- MonadState.lift tsType $ varToVHDLExpr false
+-- return ([mkCondAssign (Left bndr) cond_expr true_expr false_expr], [])
+mkConcSm (bndr, (CoreSyn.Case (CoreSyn.Var scrut) _ _ (alt:alts))) = do --error "\nVHDL.mkConcSm: Not in normal form: Case statement with more than two alternatives"
scrut' <- MonadState.lift tsType $ varToVHDLExpr scrut
- let cond_expr = scrut' AST.:=: (altconToVHDLExpr con)
- true_expr <- MonadState.lift tsType $ varToVHDLExpr true
- false_expr <- MonadState.lift tsType $ varToVHDLExpr false
- return ([mkCondAssign (Left bndr) cond_expr true_expr false_expr], [])
+ -- Omit first condition, which is the default
+ altcons <- MonadState.lift tsType $ mapM (altconToVHDLExpr . (\(con,_,_) -> con)) alts
+ let cond_exprs = map (\x -> scrut' AST.:=: x) altcons
+ -- Rotate expressions to the left, so that the expression related to the default case is the last
+ exprs <- MonadState.lift tsType $ mapM (varToVHDLExpr . (\(_,_,CoreSyn.Var expr) -> expr)) (alts ++ [alt])
+ return ([mkAltsAssign (Left bndr) cond_exprs exprs], [])
-mkConcSm (_, (CoreSyn.Case (CoreSyn.Var _) _ _ alts)) = error "\nVHDL.mkConcSm: Not in normal form: Case statement with more than two alternatives"
mkConcSm (_, CoreSyn.Case _ _ _ _) = error "\nVHDL.mkConcSm: Not in normal form: Case statement has does not have a simple variable as scrutinee"
mkConcSm (bndr, expr) = error $ "\nVHDL.mkConcSM: Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr
let name = Name.getOccString (TyCon.tyConName tycon)
case name of
"SizedInt" -> return $ AST.Neg arg1
- otherwise -> error $ "\nGenerate.genNegation': Negation allowed for type: " ++ show name
+ otherwise -> error $ "\nGenerate.genNegation': Negation not allowed for type: " ++ show name
-- | Generate a function call from the destination binder, function name and a
-- list of expressions (its arguments)
ramassign = AST.SigAssign ramloc wform
rising_edge_clk = genExprFCall rising_edge (AST.PrimName $ AST.NSimple clockId)
statement = AST.IfSm (AST.And rising_edge_clk wrenable) [ramassign] [] Nothing
-
+
+genSplit :: BuiltinBuilder
+genSplit = genNoInsts $ genVarArgs genSplit'
+
+genSplit' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
+genSplit' (Left res) f args@[vecIn] = do {
+ ; labels <- MonadState.lift tsType $ getFieldLabels (Var.varType res)
+ ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vecIn
+ ; let { block_label = mkVHDLExtId ("split" ++ (varToString vecIn))
+ ; 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))
+ ; resname = varToVHDLName res
+ ; resnameL = mkSelectedName resname (labels!!0)
+ ; resnameR = mkSelectedName resname (labels!!1)
+ ; argexprL = vhdlNameToVHDLExpr rangeL
+ ; argexprR = vhdlNameToVHDLExpr rangeR
+ ; out_assignL = mkUncondAssign (Right resnameL) argexprL
+ ; out_assignR = mkUncondAssign (Right resnameR) argexprR
+ ; block = AST.BlockSm block_label [] (AST.PMapAspect []) [] [out_assignL, out_assignR]
+ }
+ ; return [AST.CSBSm block]
+ }
+ where
+ vecSlice init last = AST.NSlice (AST.SliceName (varToVHDLName res)
+ (AST.ToRange init last))
-----------------------------------------------------------------------------
-- Function to generate VHDL for applications
-----------------------------------------------------------------------------
-- the VHDLState or something.
let vectorTM = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId elemTM)
typefuns <- getA tsTypeFuns
- case Map.lookup (OrdType el_ty, fname) typefuns of
+ case Map.lookup (StdType $ OrdType el_ty, fname) typefuns of
-- Function already generated, just return it
Just (id, _) -> return id
-- Function not generated yet, generate it
let functions = genUnconsVectorFuns elemTM vectorTM
case lookup fname functions of
Just body -> do
- modA tsTypeFuns $ Map.insert (OrdType el_ty, fname) (function_id, (fst body))
+ modA tsTypeFuns $ Map.insert (StdType $ OrdType el_ty, fname) (function_id, (fst body))
mapM_ (vectorFunId el_ty) (snd body)
return function_id
Nothing -> error $ "\nGenerate.vectorFunId: I don't know how to generate vector function " ++ fname
, (minusId , (2, genOperator2 (AST.:-:) ) )
, (fromSizedWordId , (1, genFromSizedWord ) )
, (fromIntegerId , (1, genFromInteger ) )
- , (resizeId , (1, genResize ) )
+ , (resizeWordId , (1, genResize ) )
+ , (resizeIntId , (1, genResize ) )
, (sizedIntId , (1, genSizedInt ) )
, (smallIntegerId , (1, genFromInteger ) )
, (fstId , (1, genFst ) )
, (sndId , (1, genSnd ) )
, (blockRAMId , (5, genBlockRAM ) )
+ , (splitId , (1, genSplit ) )
--, (tfvecId , (1, genTFVec ) )
, (minimumId , (2, error $ "\nFunction name: \"minimum\" is used internally, use another name"))
]
projects / matthijs / master-project / cλash.git / blobdiff