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 Debug.Trace
+import qualified Data.Accessor.Monad.Trans.State as MonadState
--- ForSyDe
+-- VHDL Imports
import qualified Language.VHDL.AST as AST
-- GHC API
import CLasH.VHDL.Constants
import CLasH.VHDL.VHDLTypes
import CLasH.VHDL.VHDLTools
-import CLasH.Utils as Utils
+import CLasH.Utils
import CLasH.Utils.Core.CoreTools
import CLasH.Utils.Pretty
import qualified CLasH.Normalize as Normalize
CoreSyn.CoreBndr
-> TranslatorSession Entity -- ^ The resulting entity
-getEntity fname = Utils.makeCached fname tsEntities $ do
+getEntity fname = makeCached fname tsEntities $ do
expr <- Normalize.getNormalized fname
-- Split the normalized expression
let (args, binds, res) = Normalize.splitNormalized expr
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
-> TranslatorSession (Architecture, [CoreSyn.CoreBndr])
-- ^ The architecture for this function
-getArchitecture fname = Utils.makeCached fname tsArchitectures $ do
+getArchitecture fname = makeCached fname tsArchitectures $ do
expr <- Normalize.getNormalized fname
-- Split the normalized expression
let (args, binds, res) = Normalize.splitNormalized expr
-- for the output port (that will already have an output port declared in
-- the entity).
sig_dec_maybes <- mapM (mkSigDec . fst) (filter ((/=res).fst) binds)
- let sig_decs = Maybe.catMaybes $ sig_dec_maybes
+ let sig_decs = Maybe.catMaybes sig_dec_maybes
-- Process each bind, resulting in info about state variables and concurrent
-- statements.
(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
+ initSmap <- MonadState.get tsInitStates
let init_state = Map.lookup fname initSmap
-- Create a state proc, if needed
(state_proc, resbndr) <- case (Maybe.catMaybes in_state_maybes, Maybe.catMaybes out_state_maybes, init_state) of
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 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
-- Simple a = b assignments are just like applications, but without arguments.
-- We can't just generate an unconditional assignment here, since b might be a
-- top level binding (e.g., a function with no arguments).
-mkConcSm (bndr, CoreSyn.Var v) = do
+mkConcSm (bndr, CoreSyn.Var v) =
genApplication (Left bndr) v []
mkConcSm (bndr, app@(CoreSyn.App _ _))= do
let sel_name = varToVHDLName scrut
let sel_expr = AST.PrimName sel_name
return ([mkUncondAssign (Left bndr) sel_expr], [])
- otherwise -> do
+ otherwise ->
case htypeScrt of
Right (AggrType _ _) -> do
labels <- MonadState.lift tsType $ getFieldLabels (Id.idType scrut)
Just _ -> do
vhdl_expr <- varToVHDLExpr $ exprToVar expr
return $ Just vhdl_expr
- Nothing -> return $ Nothing
+ Nothing -> return Nothing
argToVHDLExpr (Right expr) = return $ Just expr
(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 $ getA tsHscEnv
+ 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 litargs = concatMap (getLiterals hscenv) exprargs
let args' = map exprToLit litargs
- concsms <- wrap dst func args'
- return concsms
+ wrap dst func args'
-- | A function to wrap a builder-like function that produces an expression
-- and expects it to be assigned to the destination.
-> ((Either CoreSyn.CoreBndr AST.VHDLName) -> func -> [arg] -> TranslatorSession [AST.ConcSm])
genExprRes wrap dst func args = do
expr <- wrap dst func args
- return $ [mkUncondAssign dst expr]
+ return [mkUncondAssign dst expr]
-- | Generate a binary operator application. The first argument should be a
-- constructor from the AST.Expr type, e.g. AST.And.
genFromSizedWord :: BuiltinBuilder
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]
+genFromSizedWord' (Left res) f args@[arg] =
+ 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
}
genResize' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
+genTimes :: BuiltinBuilder
+genTimes = genNoInsts $ genExprArgs $ genExprRes genTimes'
+genTimes' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
+genTimes' (Left res) f [arg1,arg2] = do {
+ ; let { ty = Var.varType res
+ ; (tycon, args) = Type.splitTyConApp ty
+ ; name = Name.getOccString (TyCon.tyConName tycon)
+ } ;
+ ; 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 { ubound <- MonadState.lift tsType $ tfp_to_int (ranged_word_bound_ty ty)
+ ; let bitsize = floor (logBase 2 (fromInteger (toInteger ubound)))
+ ; return bitsize
+ }
+ ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId resizeId))
+ [Nothing AST.:=>: AST.ADExpr (arg1 AST.:*: arg2), Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
+ }
+genTimes' (Right name) _ _ = error $ "\nGenerate.genTimes': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
+
-- FIXME: I'm calling genLitArgs which is very specific function,
-- which needs to be fixed as well
genFromInteger :: BuiltinBuilder
genFold' :: Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
genFold' left res f args@[folded_f , start ,vec]= do
- len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty (Var.varType vec))
+ len <- MonadState.lift tsType $ tfp_to_int (tfvec_len_ty (Var.varType vec))
genFold'' len left res f args
genFold'' :: Int -> Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
[Right argexpr2, Right argexpr1]
)
-- Return the conditional generate part
- return $ (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
+ return (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
genOtherCell = do
len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
[Right argexpr2, Right argexpr1]
)
-- Return the conditional generate part
- return $ (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
+ return (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
-- | Generate a generate statement for the builtin function "zip"
genZip :: BuiltinBuilder
genUnzip :: BuiltinBuilder
genUnzip = genNoInsts $ genVarArgs genUnzip'
genUnzip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
-genUnzip' (Left res) f args@[arg] = do {
- -- Setup the generate scheme
- ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg
- -- TODO: Use something better than varToString
- ; let { label = mkVHDLExtId ("unzipVector" ++ (varToString res))
- ; n_id = mkVHDLBasicId "n"
- ; n_expr = idToVHDLExpr n_id
- ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
- ; genScheme = AST.ForGn n_id range
- ; resname' = varToVHDLName res
- ; argexpr' = mkIndexedName (varToVHDLName arg) n_expr
- } ;
- ; reslabels <- MonadState.lift tsType $ getFieldLabels (Var.varType res)
- ; arglabels <- MonadState.lift tsType $ getFieldLabels (tfvec_elem (Var.varType arg))
- ; let { resnameA = mkIndexedName (mkSelectedName resname' (reslabels!!0)) n_expr
- ; resnameB = mkIndexedName (mkSelectedName resname' (reslabels!!1)) n_expr
- ; argexprA = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!0)
- ; argexprB = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!1)
- ; resA_assign = mkUncondAssign (Right resnameA) argexprA
- ; resB_assign = mkUncondAssign (Right resnameB) argexprB
- } ;
- -- Return the generate functions
- ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
- }
+genUnzip' (Left res) f args@[arg] = do
+ let error_msg = "\nGenerate.genUnzip: Cannot generate unzip call: " ++ pprString res ++ " = " ++ pprString f ++ " " ++ pprString arg
+ htype <- MonadState.lift tsType $ mkHType error_msg (Var.varType arg)
+ -- Prepare a unconditional assignment, for the case when either part
+ -- of the unzip is a state variable, which will disappear in the
+ -- resulting VHDL, making the the unzip no longer required.
+ case htype of
+ -- A normal vector containing two-tuples
+ VecType _ (AggrType _ [_, _]) -> do {
+ -- Setup the generate scheme
+ ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg
+ -- TODO: Use something better than varToString
+ ; let { label = mkVHDLExtId ("unzipVector" ++ (varToString res))
+ ; n_id = mkVHDLBasicId "n"
+ ; n_expr = idToVHDLExpr n_id
+ ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
+ ; genScheme = AST.ForGn n_id range
+ ; resname' = varToVHDLName res
+ ; argexpr' = mkIndexedName (varToVHDLName arg) n_expr
+ } ;
+ ; reslabels <- MonadState.lift tsType $ getFieldLabels (Var.varType res)
+ ; arglabels <- MonadState.lift tsType $ getFieldLabels (tfvec_elem (Var.varType arg))
+ ; let { resnameA = mkIndexedName (mkSelectedName resname' (reslabels!!0)) n_expr
+ ; resnameB = mkIndexedName (mkSelectedName resname' (reslabels!!1)) n_expr
+ ; argexprA = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!0)
+ ; argexprB = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!1)
+ ; resA_assign = mkUncondAssign (Right resnameA) argexprA
+ ; resB_assign = mkUncondAssign (Right resnameB) argexprB
+ } ;
+ -- Return the generate functions
+ ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
+ }
+ -- Both elements of the tuple were state, so they've disappeared. No
+ -- need to do anything
+ VecType _ (AggrType _ []) -> return []
+ -- A vector containing aggregates with more than two elements?
+ VecType _ (AggrType _ _) -> error $ "Unzipping a value that is not a vector of two-tuples? Value: " ++ pprString arg ++ "\nType: " ++ pprString (Var.varType arg)
+ -- One of the elements of the tuple was state, so there won't be a
+ -- tuple (record) in the VHDL output. We can just do a plain
+ -- assignment, then.
+ VecType _ _ -> do
+ argexpr <- MonadState.lift tsType $ varToVHDLExpr arg
+ return [mkUncondAssign (Left res) argexpr]
+ _ -> error $ "Unzipping a value that is not a vector? Value: " ++ pprString arg ++ "\nType: " ++ pprString (Var.varType arg) ++ "\nhtype: " ++ show htype
genCopy :: BuiltinBuilder
genCopy = genNoInsts $ genVarArgs genCopy'
genCopy' (Left res) f args@[arg] =
let
resExpr = AST.Aggregate [AST.ElemAssoc (Just AST.Others)
- (AST.PrimName $ (varToVHDLName arg))]
+ (AST.PrimName (varToVHDLName arg))]
out_assign = mkUncondAssign (Left res) resExpr
in
return [out_assign]
let argexpr = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_prev
(app_concsms, used) <- genApplication (Right resname) app_f [Right argexpr]
-- Return the conditional generate part
- return $ (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
+ return (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
genBlockRAM :: BuiltinBuilder
genBlockRAM = genNoInsts $ genExprArgs genBlockRAM'
-> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
-- ^ The corresponding VHDL concurrent statements and entities
-- instantiated.
-genApplication dst f args = do
- case Var.isGlobalId f of
- False -> do
- top <- isTopLevelBinder f
- case top of
- True -> do
- -- Local binder that references a top level binding. Generate a
- -- component instantiation.
- signature <- getEntity f
- 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 (prettyShow . varToVHDLName) prettyShow) dst
- let 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.
- -- It should have a representable type (and thus, no arguments) and a
- -- signal should be generated for it. Just generate an unconditional
- -- assignment here.
- f' <- MonadState.lift tsType $ varToVHDLExpr f
- return $ ([mkUncondAssign dst f'], [])
- True ->
- 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
- 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.
- Left bndr -> do
- case (Map.lookup (varToString f) globalNameTable) of
- Just (arg_count, builder) ->
- if length args == arg_count then
- builder dst f args
- else
- error $ "\nGenerate.genApplication(DataConWrapId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
- Nothing -> error $ "\nGenerate.genApplication: Can't generate dataconwrapper: " ++ (show dc)
- Right _ -> error $ "\nGenerate.genApplication: Can't generate dataconwrapper application without an original binder"
- IdInfo.VanillaId -> do
- -- It's a global value imported from elsewhere. These can be builtin
- -- functions. Look up the function name in the name table and execute
- -- the associated builder if there is any and the argument count matches
- -- (this should always be the case if it typechecks, but just to be
- -- sure...).
+genApplication dst f args =
+ if Var.isGlobalId f then
+ 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
+ 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 ->
+ 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(DataConWorkId): 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.
+ Left bndr ->
case (Map.lookup (varToString f) globalNameTable) of
- Just (arg_count, builder) ->
- if length args == arg_count then
- builder dst f args
+ Just (arg_count, builder) ->
+ if length args == arg_count then
+ builder dst f args
+ else
+ error $ "\nGenerate.genApplication(DataConWrapId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
+ Nothing -> error $ "\nGenerate.genApplication(DataConWrapId): Can't generate dataconwrapper: " ++ (show dc)
+ Right _ -> error "\nGenerate.genApplication(DataConWrapId): Can't generate dataconwrapper application without an original binder"
+ IdInfo.VanillaId ->
+ -- It's a global value imported from elsewhere. These can be builtin
+ -- functions. Look up the function name in the name table and execute
+ -- the associated builder if there is any and the argument count matches
+ -- (this should always be the case if it typechecks, but just to be
+ -- sure...).
+ case (Map.lookup (varToString f) globalNameTable) of
+ Just (arg_count, builder) ->
+ if length args == arg_count then
+ builder dst f args
+ else
+ error $ "\nGenerate.genApplication(VanillaId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
+ Nothing -> do
+ top <- isTopLevelBinder f
+ if top then
+ do
+ -- Local binder that references a top level binding. Generate a
+ -- component instantiation.
+ signature <- getEntity f
+ 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
+ return ([mkComponentInst label entity_id portmaps], [f])
else
- error $ "\nGenerate.genApplication(VanillaId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
- Nothing -> do
- top <- isTopLevelBinder f
- case top of
- True -> do
- -- Local binder that references a top level binding. Generate a
- -- component instantiation.
- signature <- getEntity f
- 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
- return ([mkComponentInst label entity_id portmaps], [f])
- False -> do
- -- Not a top level binder, so this must be a local variable reference.
- -- It should have a representable type (and thus, no arguments) and a
- -- signal should be generated for it. Just generate an unconditional
- -- assignment here.
- -- 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'], [])
- errtype <- case dst of
+ -- Not a top level binder, so this must be a local variable reference.
+ -- It should have a representable type (and thus, no arguments) and a
+ -- signal should be generated for it. Just generate an unconditional
+ -- assignment here.
+ -- 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'], [])
+ do 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.
- case (Map.lookup (varToString f) globalNameTable) of
- Just (arg_count, builder) ->
- if length args == arg_count then
- builder dst f args
- else
- 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
+ error ("\nGenerate.genApplication(VanillaId): Using function from another module that is not a known builtin: " ++ (pprString f) ++ "::" ++ errtype)
+ IdInfo.ClassOpId cls ->
+ -- FIXME: Not looking for what instance this class op is called for
+ -- Is quite stupid of course.
+ case (Map.lookup (varToString f) globalNameTable) of
+ Just (arg_count, builder) ->
+ if length args == arg_count then
+ builder dst f args
+ else
+ 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
+ else do
+ top <- isTopLevelBinder f
+ if top then
+ do
+ -- Local binder that references a top level binding. Generate a
+ -- component instantiation.
+ signature <- getEntity f
+ 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 (prettyShow . varToVHDLName) prettyShow) dst
+ let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature
+ return ([mkComponentInst label entity_id portmaps], [f])
+ else
+ -- Not a top level binder, so this must be a local variable reference.
+ -- It should have a representable type (and thus, no arguments) and a
+ -- signal should be generated for it. Just generate an unconditional
+ -- assignment here.
+ do f' <- MonadState.lift tsType $ varToVHDLExpr f
+ return ([mkUncondAssign dst f'], [])
-----------------------------------------------------------------------------
-- Functions to generate functions dealing with vectors.
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 <- vhdlTy error_msg el_ty
+ elemTM_maybe <- vhdlTy error_msg el_ty
+ let elemTM = Maybe.fromMaybe
+ (error $ "\nGenerate.vectorFunId: Cannot generate vector function \"" ++ fname ++ "\" for the empty type \"" ++ (pprString el_ty) ++ "\"")
+ elemTM_maybe
-- 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
+ 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
let functions = genUnconsVectorFuns elemTM vectorTM
case lookup fname functions of
Just body -> do
- modA tsTypeFuns $ Map.insert (UVecType el_htype, 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
exSpec = AST.Function (mkVHDLExtId exId) [AST.IfaceVarDec vecPar vectorTM,
AST.IfaceVarDec ixPar unsignedTM] elemTM
exExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NIndexed
- (AST.IndexedName (AST.NSimple vecPar) [genExprFCall (mkVHDLBasicId toIntegerId) (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 unsignedTM
, AST.IfaceVarDec aPar elemTM
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) [genExprFCall (mkVHDLBasicId toIntegerId) (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
(AST.ToRange init last)))
lastSpec = AST.Function (mkVHDLExtId lastId) [AST.IfaceVarDec vecPar vectorTM] elemTM
-- return vec(vec'length-1);
- lastExpr = AST.ReturnSm (Just $ (AST.PrimName $ AST.NIndexed (AST.IndexedName
+ lastExpr = AST.ReturnSm (Just (AST.PrimName $ AST.NIndexed (AST.IndexedName
(AST.NSimple vecPar)
[AST.PrimName (AST.NAttribute $
AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
-- for i res'range loop
-- res(i) := vec(f+i*s);
-- end loop;
- selFor = AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) (AST.NSimple $ rangeId) Nothing) [selAssign]
+ selFor = AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) (AST.NSimple rangeId) Nothing) [selAssign]
-- res(i) := vec(f+i*s);
selAssign = let origExp = AST.PrimName (AST.NSimple fPar) AST.:+:
(AST.PrimName (AST.NSimple iId) AST.:*:
-- res(vec'length-i-1) := vec(i);
-- end loop;
reverseFor =
- AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) (AST.NSimple $ rangeId) Nothing) [reverseAssign]
+ AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) (AST.NSimple rangeId) Nothing) [reverseAssign]
-- res(vec'length-i-1) := vec(i);
reverseAssign = AST.NIndexed (AST.IndexedName (AST.NSimple resId) [destExp]) AST.:=
(AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar)
, (boolOrId , (2, genOperator2 AST.Or ) )
, (boolAndId , (2, genOperator2 AST.And ) )
, (plusId , (2, genOperator2 (AST.:+:) ) )
- , (timesId , (2, genOperator2 (AST.:*:) ) )
+ , (timesId , (2, genTimes ) )
, (negateId , (1, genNegation ) )
, (minusId , (2, genOperator2 (AST.:-:) ) )
, (fromSizedWordId , (1, genFromSizedWord ) )
, (blockRAMId , (5, genBlockRAM ) )
, (splitId , (1, genSplit ) )
--, (tfvecId , (1, genTFVec ) )
- , (minimumId , (2, error $ "\nFunction name: \"minimum\" is used internally, use another name"))
+ , (minimumId , (2, error "\nFunction name: \"minimum\" is used internally, use another name"))
]
projects / matthijs / master-project / cλash.git / blobdiff