-> TranslatorSession Entity -- ^ The resulting entity
getEntity fname = makeCached fname tsEntities $ do
- expr <- Normalize.getNormalized fname
+ expr <- Normalize.getNormalized False fname
-- Split the normalized expression
let (args, binds, res) = Normalize.splitNormalized expr
-- Generate ports for all non-empty types
-- ^ The architecture for this function
getArchitecture fname = makeCached fname tsArchitectures $ do
- expr <- Normalize.getNormalized fname
+ expr <- Normalize.getNormalized False fname
-- Split the normalized expression
let (args, binds, res) = Normalize.splitNormalized expr
(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)
+ if nonEmpty
+ then error ("No initial state defined for: " ++ show fname)
+ else return ([],[])
+ ([in_state], [out_state], Just resetval) -> do
+ nonEmpty <- hasNonEmptyType in_state
+ if nonEmpty
+ then mkStateProcSm (in_state, out_state, resetval)
+ else error ("Initial state defined for function with only substate: " ++ show fname)
([], [], 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
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
+ 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.fromJust type_mark_res_maybe
+ 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
| otherwise =
case alt of
(CoreSyn.DataAlt dc, bndrs, (CoreSyn.Var sel_bndr)) -> do
- bndrs' <- Monad.filterM hasNonEmptyType bndrs
- case List.elemIndex sel_bndr bndrs' of
- Just i -> do
- 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 ->
- 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!"
+ nonemptysel <- hasNonEmptyType sel_bndr
+ if nonemptysel
+ then do
+ bndrs' <- Monad.filterM hasNonEmptyType bndrs
+ case List.elemIndex sel_bndr bndrs' of
+ Just i -> do
+ 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], [])
- Nothing -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
+ otherwise ->
+ 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: result is not one of the binders\n" ++ (pprString expr)
+ else
+ -- A selector case that selects a state value, ignore it.
+ return ([], [])
_ -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
exprs <- MonadState.lift tsType $ mapM (varToVHDLExpr . (\(_,_,CoreSyn.Var expr) -> expr)) (alts ++ [alt])
return ([mkAltsAssign (Left bndr) cond_exprs exprs], [])
-mkConcSm (_, CoreSyn.Case _ _ _ _) = error "\nVHDL.mkConcSm: Not in normal form: Case statement has does not have a simple variable as scrutinee"
+mkConcSm (_, CoreSyn.Case _ _ _ _) = error "\nVHDL.mkConcSm: Not in normal form: Case statement does not have a simple variable as scrutinee"
mkConcSm (bndr, expr) = error $ "\nVHDL.mkConcSM: Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr
-----------------------------------------------------------------------------
genVarArgs ::
(dst -> func -> [Var.Var] -> res)
-> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> res)
-genVarArgs wrap dst func args = wrap dst func args'
+genVarArgs wrap = genCoreArgs $ \dst func args -> let
+ args' = map exprToVar args
+ in
+ wrap dst func args'
+
+-- | A function to wrap a builder-like function that expects its arguments to
+-- be core expressions.
+genCoreArgs ::
+ (dst -> func -> [CoreSyn.CoreExpr] -> res)
+ -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> res)
+genCoreArgs wrap dst func args = wrap dst func args'
where
- args' = map exprToVar exprargs
-- Check (rather crudely) that all arguments are CoreExprs
- (exprargs, []) = Either.partitionEithers args
+ args' = case Either.partitionEithers args of
+ (exprargs, []) -> exprargs
+ (exprsargs, rest) -> error $ "\nGenerate.genCoreArgs: expect core expression arguments but found ast exprs:" ++ (show rest)
-- | A function to wrap a builder-like function that expects its arguments to
-- be Literals
-- 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
+genFromRangedWord :: BuiltinBuilder
+genFromRangedWord = genNoInsts $ genExprArgs $ genExprRes genFromRangedWord'
+genFromRangedWord' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
+genFromRangedWord' (Left res) f [arg] = do {
+ ; let { ty = Var.varType res
+ ; (tycon, args) = Type.splitTyConApp ty
+ ; name = Name.getOccString (TyCon.tyConName tycon)
+ } ;
+ ; len <- MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
+ ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId resizeId))
+ [Nothing AST.:=>: AST.ADExpr arg, Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
+ }
+genFromRangedWord' (Right name) _ _ = error $ "\nGenerate.genFromRangedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
+
genResize :: BuiltinBuilder
genResize = genNoInsts $ genExprArgs $ genExprRes genResize'
genResize' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
}
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
genMap' (Right name) _ _ = error $ "\nGenerate.genMap': Cannot generate map function call assigned to a VHDLName: " ++ show name
genZipWith :: BuiltinBuilder
-genZipWith = genVarArgs genZipWith'
-genZipWith' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
-genZipWith' (Left res) f args@[zipped_f, arg1, arg2] = do {
+genZipWith (Left res) f args@[Left zipped_f, Left (CoreSyn.Var arg1), Left (CoreSyn.Var arg2)] = do {
-- Setup the generate scheme
; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
-- TODO: Use something better than varToString
-- Create the content of the generate statement: Applying the zipped_f to
-- each of the elements in arg1 and arg2, storing to each element in res
; resname = mkIndexedName (varToVHDLName res) n_expr
+ ; (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs zipped_f
+ ; valargs = get_val_args (Var.varType real_f) already_mapped_args
; argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr
; argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr
} ;
- ; (app_concsms, used) <- genApplication (Right resname) zipped_f [Right argexpr1, Right argexpr2]
+ ; (app_concsms, used) <- genApplication (Right resname) real_f (map Left valargs ++ [Right argexpr1, Right argexpr2])
-- Return the generate functions
; return ([AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms], used)
}
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' :: (Either CoreSyn.CoreBndr AST.VHDLName ) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
-genCopy' (Left res) f args@[arg] =
- let
- resExpr = AST.Aggregate [AST.ElemAssoc (Just AST.Others)
- (AST.PrimName (varToVHDLName arg))]
- out_assign = mkUncondAssign (Left res) resExpr
- in
- return [out_assign]
+genCopy = genNoInsts genCopy'
+genCopy' :: (Either CoreSyn.CoreBndr AST.VHDLName ) -> CoreSyn.CoreBndr -> [Either CoreSyn.CoreExpr AST.Expr] -> TranslatorSession [AST.ConcSm]
+genCopy' (Left res) f [arg] = do {
+ ; [arg'] <- argsToVHDLExprs [arg]
+ ; let { resExpr = AST.Aggregate [AST.ElemAssoc (Just AST.Others) arg']
+ ; out_assign = mkUncondAssign (Left res) resExpr
+ }
+ ; return [out_assign]
+ }
genConcat :: BuiltinBuilder
genConcat = genNoInsts $ genVarArgs genConcat'
-> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
-- ^ The corresponding VHDL concurrent statements and entities
-- instantiated.
-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
- 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
+genApplication dst f args = do
+ nonemptydst <- case dst of
+ Left bndr -> hasNonEmptyType bndr
+ Right _ -> return True
+ if nonemptydst
+ then
+ 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
+ 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
+ -- 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 ->
+ -- 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
- 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
- -- 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 ->
- -- 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'], [])
-
+ -- 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'], [])
+ else -- Destination has empty type, don't generate anything
+ return ([], [])
-----------------------------------------------------------------------------
-- 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)
type NameTable = Map.Map String (Int, BuiltinBuilder )
-- | The builtin functions we support. Maps a name to an argument count and a
--- builder function.
+-- builder function. If you add a name to this map, don't forget to add
+-- it to VHDL.Constants/builtinIds as well.
globalNameTable :: NameTable
globalNameTable = Map.fromList
[ (exId , (2, genFCall True ) )
, (gteqId , (2, genOperator2 (AST.:>=:) ) )
, (boolOrId , (2, genOperator2 AST.Or ) )
, (boolAndId , (2, genOperator2 AST.And ) )
+ , (boolNot , (1, genOperator1 AST.Not ) )
, (plusId , (2, genOperator2 (AST.:+:) ) )
- , (timesId , (2, genOperator2 (AST.:*:) ) )
+ , (timesId , (2, genTimes ) )
, (negateId , (1, genNegation ) )
, (minusId , (2, genOperator2 (AST.:-:) ) )
, (fromSizedWordId , (1, genFromSizedWord ) )
+ , (fromRangedWordId , (1, genFromRangedWord ) )
, (fromIntegerId , (1, genFromInteger ) )
, (resizeWordId , (1, genResize ) )
, (resizeIntId , (1, genResize ) )
projects / matthijs / master-project / cλash.git / blobdiff