import qualified Control.Monad as Monad
import qualified Maybe
import qualified Data.Either as Either
-import Data.Accessor
-import Data.Accessor.MonadState as MonadState
+import Data.Accessor.Monad.Trans.State as MonadState
import Debug.Trace
-- ForSyDe
args' <- catMaybesM $ mapM mkMap args
-- TODO: Handle Nothing
res' <- mkMap res
- count <- getA tsEntityCounter
+ count <- MonadState.get tsEntityCounter
let vhdl_id = mkVHDLBasicId $ varToString fname ++ "Component_" ++ show count
- putA tsEntityCounter (count + 1)
+ MonadState.set tsEntityCounter (count + 1)
let ent_decl = createEntityAST vhdl_id args' res'
let signature = Entity vhdl_id args' res' ent_decl
return signature
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_maybe <- MonadState.lift tsType $ vhdl_ty error_msg ty
+ type_mark_maybe <- MonadState.lift tsType $ vhdlTy error_msg ty
case type_mark_maybe of
Just type_mark -> return $ Just (id, type_mark)
Nothing -> return Nothing
-- Create a basic Id, since VHDL doesn't grok filenames with extended Ids.
ports = map (mkIfaceSigDec AST.In) args
++ (Maybe.maybeToList res_port)
- ++ [clk_port]
+ ++ [clk_port,resetn_port]
-- Add a clk port if we have state
clk_port = AST.IfaceSigDec clockId AST.In std_logicTM
+ resetn_port = AST.IfaceSigDec resetId AST.In std_logicTM
res_port = fmap (mkIfaceSigDec AST.Out) res
-- | Create a port declaration
(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 <- MonadState.get 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) -> do
+ nonEmpty <- hasNonEmptyType in_state
+ if nonEmpty then error ("No initial state defined for: " ++ show fname) else return ([],[])
+ ([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
- if nonempty
- then return [AST.CSPSm $ AST.ProcSm label [clk] [statement]]
- else return []
- where
- label = mkVHDLBasicId $ "state"
- clk = mkVHDLBasicId "clock"
- rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
- wform = AST.Wform [AST.WformElem (AST.PrimName $ varToVHDLName new) Nothing]
- assign = AST.SigAssign (varToVHDLName old) wform
- rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
- statement = AST.IfSm rising_edge_clk [assign] [] Nothing
-
+ (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.fromJust type_mark_old_maybe
+ type_mark_res_maybe <- MonadState.lift tsType $ vhdlTy 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 = 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])
-- | Transforms a core binding into a VHDL concurrent statement
mkConcSm ::
let valargs = get_val_args (Var.varType f) args
genApplication (Left bndr) f (map Left valargs)
--- A single alt case must be a selector. This means thee scrutinee is a simple
+-- A single alt case must be a selector. This means the 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]))
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
- let sel_name = mkSelectedName (varToVHDLName scrut) label
- let sel_expr = AST.PrimName sel_name
- return ([mkUncondAssign (Left bndr) sel_expr], [])
+ htypeScrt <- MonadState.lift tsType $ mkHTypeEither (Var.varType scrut)
+ htypeBndr <- MonadState.lift tsType $ mkHTypeEither (Var.varType bndr)
+ case htypeScrt == htypeBndr of
+ True -> do
+ let sel_name = varToVHDLName scrut
+ let sel_expr = AST.PrimName sel_name
+ return ([mkUncondAssign (Left bndr) sel_expr], [])
+ otherwise -> do
+ case htypeScrt of
+ Right (AggrType _ _) -> do
+ labels <- MonadState.lift tsType $ getFieldLabels (Id.idType scrut)
+ let label = labels!!i
+ let sel_name = mkSelectedName (varToVHDLName scrut) label
+ let sel_expr = AST.PrimName sel_name
+ return ([mkUncondAssign (Left bndr) sel_expr], [])
+ _ -> do -- error $ "DIE!"
+ let sel_name = varToVHDLName scrut
+ let sel_expr = AST.PrimName sel_name
+ return ([mkUncondAssign (Left bndr) sel_expr], [])
Nothing -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
_ -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
-- 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
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
+ ty_maybe <- vhdlTy errmsg expr
case ty_maybe of
Just _ -> do
vhdl_expr <- varToVHDLExpr $ exprToVar expr
-- | A function to wrap a builder-like function that expects its arguments to
-- be Literals
genLitArgs ::
- (dst -> func -> [Literal.Literal] -> res)
- -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> res)
-genLitArgs wrap dst func args = wrap dst func args'
- where
- args' = map exprToLit litargs
- -- FIXME: Check if we were passed an CoreSyn.App
- litargs = concat (map getLiterals exprargs)
- (exprargs, []) = Either.partitionEithers args
+ (dst -> func -> [Literal.Literal] -> TranslatorSession [AST.ConcSm])
+ -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> TranslatorSession [AST.ConcSm])
+genLitArgs wrap dst func args = do
+ hscenv <- MonadState.lift tsType $ MonadState.get tsHscEnv
+ let (exprargs, []) = Either.partitionEithers args
+ -- FIXME: Check if we were passed an CoreSyn.App
+ let litargs = concat (map (getLiterals hscenv) exprargs)
+ let args' = map exprToLit litargs
+ concsms <- wrap dst func args'
+ return concsms
-- | A function to wrap a builder-like function that produces an expression
-- and expects it to be assigned to the destination.
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)
genFCall' _ (Right name) _ _ = error $ "\nGenerate.genFCall': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
genFromSizedWord :: BuiltinBuilder
-genFromSizedWord = genNoInsts $ genExprArgs $ genExprRes genFromSizedWord'
-genFromSizedWord' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
-genFromSizedWord' (Left res) f args = do
- let fname = varToString f
- return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId toIntegerId)) $
- map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
+genFromSizedWord = genNoInsts $ genExprArgs genFromSizedWord'
+genFromSizedWord' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession [AST.ConcSm]
+genFromSizedWord' (Left res) f args@[arg] = do
+ return $ [mkUncondAssign (Left res) arg]
+ -- let fname = varToString f
+ -- return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId toIntegerId)) $
+ -- map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
genFromSizedWord' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
genResize :: BuiltinBuilder
; (tycon, args) = Type.splitTyConApp ty
; name = Name.getOccString (TyCon.tyConName tycon)
} ;
- ; case name of
- "RangedWord" -> return $ AST.PrimLit (show (last lits))
- otherwise -> do {
- ; len <- case name of
- "SizedInt" -> MonadState.lift tsType $ tfp_to_int (sized_int_len_ty ty)
- "SizedWord" -> MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
- "RangedWord" -> MonadState.lift tsType $ tfp_to_int (ranged_word_bound_ty ty)
- ; let fname = case name of "SizedInt" -> toSignedId ; "SizedWord" -> toUnsignedId
- ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId fname))
- [Nothing AST.:=>: AST.ADExpr (AST.PrimLit (show (last lits))), Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
+ ; len <- case name of
+ "SizedInt" -> MonadState.lift tsType $ tfp_to_int (sized_int_len_ty ty)
+ "SizedWord" -> MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
+ "RangedWord" -> do {
+ ; bound <- MonadState.lift tsType $ tfp_to_int (ranged_word_bound_ty ty)
+ ; return $ floor (logBase 2 (fromInteger (toInteger (bound)))) + 1
}
+ ; let fname = case name of "SizedInt" -> toSignedId ; "SizedWord" -> toUnsignedId ; "RangedWord" -> toUnsignedId
+ ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId fname))
+ [Nothing AST.:=>: AST.ADExpr (AST.PrimLit (show (last lits))), Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
+
}
genFromInteger' (Right name) _ _ = error $ "\nGenerate.genFromInteger': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
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
-- TODO: Handle Nothing
- Just tmp_vhdl_ty <- MonadState.lift tsType $ vhdl_ty error_msg tmp_ty
+ Just tmp_vhdl_ty <- MonadState.lift tsType $ vhdlTy error_msg tmp_ty
-- Setup the generate scheme
let gen_label = mkVHDLExtId ("foldlVector" ++ (varToString vec))
let block_label = mkVHDLExtId ("foldlVector" ++ (varToString res))
let tmp_ty = Var.varType res
let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty
-- TODO: Handle Nothing
- Just tmp_vhdl_ty <- MonadState.lift tsType $ vhdl_ty error_msg tmp_ty
+ Just tmp_vhdl_ty <- MonadState.lift tsType $ vhdlTy error_msg tmp_ty
-- Setup the generate scheme
let gen_label = mkVHDLExtId ("iterateVector" ++ (varToString start))
let block_label = mkVHDLExtId ("iterateVector" ++ (varToString res))
let (tup',ramvec) = Type.splitAppTy tup
let Just realram = Type.coreView ramvec
let Just (tycon, types) = Type.splitTyConApp_maybe realram
- Just ram_vhdl_ty <- MonadState.lift tsType $ vhdl_ty "wtf" (head types)
+ Just ram_vhdl_ty <- MonadState.lift tsType $ vhdlTy "wtf" (head types)
-- Make the intermediate vector
let ram_dec = AST.BDISD $ AST.SigDec ram_id ram_vhdl_ty Nothing
-- Get the data_out name
- reslabels <- MonadState.lift tsType $ getFieldLabels (Var.varType res)
- let resname' = varToVHDLName res
- let resname = mkSelectedName resname' (reslabels!!0)
- let argexpr = vhdlNameToVHDLExpr $ mkIndexedName (AST.NSimple ram_id) rdaddr
+ -- reslabels <- MonadState.lift tsType $ getFieldLabels (Var.varType res)
+ let resname = varToVHDLName res
+ -- let resname = mkSelectedName resname' (reslabels!!0)
+ let rdaddr_int = genExprFCall (mkVHDLBasicId toIntegerId) rdaddr
+ let argexpr = vhdlNameToVHDLExpr $ mkIndexedName (AST.NSimple ram_id) rdaddr_int
let assign = mkUncondAssign (Right resname) argexpr
let block_label = mkVHDLExtId ("blockRAM" ++ (varToString res))
let block = AST.BlockSm block_label [] (AST.PMapAspect []) [ram_dec] [assign, mkUpdateProcSm]
where
proclabel = mkVHDLBasicId "updateRAM"
rising_edge = mkVHDLBasicId "rising_edge"
- ramloc = mkIndexedName (AST.NSimple ram_id) wraddr
+ wraddr_int = genExprFCall (mkVHDLBasicId toIntegerId) wraddr
+ ramloc = mkIndexedName (AST.NSimple ram_id) wraddr_int
wform = AST.Wform [AST.WformElem data_in Nothing]
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 AST.:=: AST.PrimLit "'1'")) [ramassign] [] Nothing
-
+ 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
-----------------------------------------------------------------------------
-- 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' <- argsToVHDLExprs args
- return $ (zipWith mkassign labels $ args', [])
- where
- mkassign :: AST.VHDLId -> AST.Expr -> AST.ConcSm
- mkassign label arg =
- let sel_name = mkSelectedName ((either varToVHDLName id) dst) label in
- mkUncondAssign (Right sel_name) arg
+ htype <- MonadState.lift tsType $ mkHTypeEither (Var.varType bndr)
+ let argsNostate = filter (\x -> not (either hasStateType (\x -> False) x)) args
+ case argsNostate of
+ [arg] -> do
+ [arg'] <- argsToVHDLExprs [arg]
+ return $ ([mkUncondAssign dst arg'], [])
+ otherwise -> do
+ case htype of
+ Right (AggrType _ _) -> do
+ labels <- MonadState.lift tsType $ getFieldLabels (Var.varType bndr)
+ args' <- argsToVHDLExprs argsNostate
+ return $ (zipWith mkassign labels $ args', [])
+ where
+ mkassign :: AST.VHDLId -> AST.Expr -> AST.ConcSm
+ mkassign label arg =
+ let sel_name = mkSelectedName ((either varToVHDLName id) dst) label in
+ mkUncondAssign (Right sel_name) arg
+ _ -> do -- error $ "DIE!"
+ args' <- argsToVHDLExprs argsNostate
+ return $ ([mkUncondAssign dst (head args')], [])
Right _ -> error $ "\nGenerate.genApplication: Can't generate dataconstructor application without an original binder"
IdInfo.DataConWrapId dc -> case dst of
-- It's a datacon. Create a record from its arguments.
-- FIXME : I DONT KNOW IF THE ABOVE COMMENT HOLDS HERE, SO FOR NOW JUST ERROR!
-- f' <- MonadState.lift tsType $ varToVHDLExpr f
-- return $ ([mkUncondAssign dst f'], [])
- error $ ("\nGenerate.genApplication(VanillaId): Using function from another module that is not a known builtin: " ++ (pprString f))
+ errtype <- case dst of
+ Left bndr -> do
+ htype <- MonadState.lift tsType $ mkHTypeEither (Var.varType bndr)
+ return (show htype)
+ Right vhd -> return $ show vhd
+ error $ ("\nGenerate.genApplication(VanillaId): Using function from another module that is not a known builtin: " ++ (pprString f) ++ "::" ++ errtype)
IdInfo.ClassOpId cls -> do
-- FIXME: Not looking for what instance this class op is called for
-- Is quite stupid of course.
vectorFunId el_ty fname = do
let error_msg = "\nGenerate.vectorFunId: Can not construct vector function for element: " ++ pprString el_ty
-- TODO: Handle the Nothing case?
- Just elemTM <- vhdl_ty error_msg el_ty
+ Just elemTM <- vhdlTy 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)
- typefuns <- getA tsTypeFuns
- case Map.lookup (OrdType el_ty, fname) typefuns of
+ typefuns <- MonadState.get tsTypeFuns
+ el_htype <- mkHType error_msg el_ty
+ case Map.lookup (UVecType el_htype, 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))
+ MonadState.modify tsTypeFuns $ Map.insert (UVecType el_htype, 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
sPar = AST.unsafeVHDLBasicId "s"
resId = AST.unsafeVHDLBasicId "res"
exSpec = AST.Function (mkVHDLExtId exId) [AST.IfaceVarDec vecPar vectorTM,
- AST.IfaceVarDec ixPar naturalTM] elemTM
+ AST.IfaceVarDec ixPar unsignedTM] elemTM
exExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NIndexed
- (AST.IndexedName (AST.NSimple vecPar) [AST.PrimName $
- AST.NSimple ixPar]))
+ (AST.IndexedName (AST.NSimple vecPar) [genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple $ ixPar)]))
replaceSpec = AST.Function (mkVHDLExtId replaceId) [ AST.IfaceVarDec vecPar vectorTM
- , AST.IfaceVarDec iPar naturalTM
+ , AST.IfaceVarDec iPar unsignedTM
, AST.IfaceVarDec aPar elemTM
] vectorTM
-- variable res : fsvec_x (0 to vec'length-1);
Nothing
-- res AST.:= vec(0 to i-1) & a & vec(i+1 to length'vec-1)
replaceExpr1 = AST.NSimple resId AST.:= AST.PrimName (AST.NSimple vecPar)
- replaceExpr2 = AST.NIndexed (AST.IndexedName (AST.NSimple resId) [AST.PrimName $ AST.NSimple iPar]) AST.:= AST.PrimName (AST.NSimple aPar)
+ replaceExpr2 = AST.NIndexed (AST.IndexedName (AST.NSimple resId) [genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple $ iPar)]) AST.:= AST.PrimName (AST.NSimple aPar)
replaceRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
vecSlice init last = AST.PrimName (AST.NSlice
(AST.SliceName
, (hwnotId , (1, genOperator1 AST.Not ) )
, (equalityId , (2, genOperator2 (AST.:=:) ) )
, (inEqualityId , (2, genOperator2 (AST.:/=:) ) )
+ , (ltId , (2, genOperator2 (AST.:<:) ) )
+ , (lteqId , (2, genOperator2 (AST.:<=:) ) )
+ , (gtId , (2, genOperator2 (AST.:>:) ) )
+ , (gteqId , (2, genOperator2 (AST.:>=:) ) )
, (boolOrId , (2, genOperator2 AST.Or ) )
, (boolAndId , (2, genOperator2 AST.And ) )
, (plusId , (2, genOperator2 (AST.:+:) ) )
, (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