+ -- 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
+ argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr
+ argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr
+ in do
+ app_concsms <- genApplication (Right resname) zipped_f [Right argexpr1, Right argexpr2]
+ -- Return the generate functions
+ return [AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms]
+
+genFoldl :: BuiltinBuilder
+genFoldl = genFold True
+
+genFoldr :: BuiltinBuilder
+genFoldr = genFold False
+
+genFold :: Bool -> BuiltinBuilder
+genFold left = genVarArgs (genFold' left)
+genFold' :: Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
+-- Special case for an empty input vector, just assign start to res
+genFold' left (Left res) _ [_, start, vec] | len == 0 = return [mkUncondAssign (Left res) (varToVHDLExpr start)]
+ where len = (tfvec_len . Var.varType) vec
+genFold' left (Left res) f [folded_f, start, vec] = do
+ -- evec is (TFVec n), so it still needs an element type
+ let (nvec, _) = splitAppTy (Var.varType vec)
+ -- Put the type of the start value in nvec, this will be the type of our
+ -- temporary vector
+ let tmp_ty = Type.mkAppTy nvec (Var.varType start)
+ tmp_vhdl_ty <- vhdl_ty tmp_ty
+ -- Setup the generate scheme
+ let gen_label = mkVHDLExtId ("foldlVector" ++ (varToString vec))
+ let block_label = mkVHDLExtId ("foldlVector" ++ (varToString start))
+ let gen_range = if left then AST.ToRange (AST.PrimLit "0") len_min_expr
+ else AST.DownRange len_min_expr (AST.PrimLit "0")
+ let gen_scheme = AST.ForGn n_id gen_range
+ -- Make the intermediate vector
+ let tmp_dec = AST.BDISD $ AST.SigDec tmp_id tmp_vhdl_ty Nothing
+ -- Create the generate statement
+ cells <- sequence [genFirstCell, genOtherCell]
+ let gen_sm = AST.GenerateSm gen_label gen_scheme [] (map AST.CSGSm cells)
+ -- Assign tmp[len-1] or tmp[0] to res
+ let out_assign = mkUncondAssign (Left res) $ vhdlNameToVHDLExpr (if left then
+ (mkIndexedName tmp_name (AST.PrimLit $ show (len-1))) else
+ (mkIndexedName tmp_name (AST.PrimLit "0")))
+ let block = AST.BlockSm block_label [] (AST.PMapAspect []) [tmp_dec] [AST.CSGSm gen_sm, out_assign]
+ return [AST.CSBSm block]
+ where
+ -- The vector length
+ len = (tfvec_len . Var.varType) vec
+ -- An id for the counter
+ n_id = mkVHDLBasicId "n"
+ n_cur = idToVHDLExpr n_id
+ -- An expression for previous n
+ n_prev = if left then (n_cur AST.:-: (AST.PrimLit "1"))
+ else (n_cur AST.:+: (AST.PrimLit "1"))
+ -- An expression for len-1
+ len_min_expr = (AST.PrimLit $ show (len-1))
+ -- An id for the tmp result vector
+ tmp_id = mkVHDLBasicId "tmp"
+ tmp_name = AST.NSimple tmp_id
+ -- Generate parts of the fold
+ genFirstCell, genOtherCell :: VHDLSession AST.GenerateSm
+ genFirstCell = do
+ let cond_label = mkVHDLExtId "firstcell"
+ -- if n == 0 or n == len-1
+ let cond_scheme = AST.IfGn $ n_cur AST.:=: (if left then (AST.PrimLit "0")
+ else (AST.PrimLit $ show (len-1)))
+ -- Output to tmp[current n]
+ let resname = mkIndexedName tmp_name n_cur
+ -- Input from start
+ let argexpr1 = varToVHDLExpr start
+ -- Input from vec[current n]
+ let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName vec) n_cur
+ app_concsms <- genApplication (Right resname) folded_f ( if left then
+ [Right argexpr1, Right argexpr2]
+ else
+ [Right argexpr2, Right argexpr1]
+ )
+ -- Return the conditional generate part
+ return $ AST.GenerateSm cond_label cond_scheme [] app_concsms
+
+ genOtherCell = do
+ let cond_label = mkVHDLExtId "othercell"
+ -- if n > 0 or n < len-1
+ let cond_scheme = AST.IfGn $ n_cur AST.:/=: (if left then (AST.PrimLit "0")
+ else (AST.PrimLit $ show (len-1)))
+ -- Output to tmp[current n]
+ let resname = mkIndexedName tmp_name n_cur
+ -- Input from tmp[previous n]
+ let argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_prev
+ -- Input from vec[current n]
+ let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName vec) n_cur
+ app_concsms <- genApplication (Right resname) folded_f ( if left then
+ [Right argexpr1, Right argexpr2]
+ else
+ [Right argexpr2, Right argexpr1]
+ )
+ -- Return the conditional generate part
+ return $ AST.GenerateSm cond_label cond_scheme [] app_concsms
+
+-- | Generate a generate statement for the builtin function "zip"
+genZip :: BuiltinBuilder
+genZip = genVarArgs genZip'
+genZip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
+genZip' (Left res) f args@[arg1, arg2] =
+ let
+ -- Setup the generate scheme
+ len = (tfvec_len . Var.varType) res
+ -- TODO: Use something better than varToString
+ label = mkVHDLExtId ("zipVector" ++ (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' = mkIndexedName (varToVHDLName res) n_expr
+ argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr
+ argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr
+ in do
+ labels <- getFieldLabels (tfvec_elem (Var.varType res))
+ let resnameA = mkSelectedName resname' (labels!!0)
+ let resnameB = mkSelectedName resname' (labels!!1)
+ let resA_assign = mkUncondAssign (Right resnameA) argexpr1
+ let resB_assign = mkUncondAssign (Right resnameB) argexpr2
+ -- Return the generate functions
+ return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
+
+-- | Generate a generate statement for the builtin function "unzip"
+genUnzip :: BuiltinBuilder
+genUnzip = genVarArgs genUnzip'
+genUnzip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
+genUnzip' (Left res) f args@[arg] =
+ let
+ -- Setup the generate scheme
+ len = (tfvec_len . Var.varType) arg
+ -- TODO: Use something better than varToString
+ 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
+ in do
+ reslabels <- getFieldLabels (Var.varType res)
+ arglabels <- getFieldLabels (tfvec_elem (Var.varType arg))
+ let resnameA = mkIndexedName (mkSelectedName resname' (reslabels!!0)) n_expr
+ let resnameB = mkIndexedName (mkSelectedName resname' (reslabels!!1)) n_expr
+ let argexprA = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!0)
+ let argexprB = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!1)
+ let resA_assign = mkUncondAssign (Right resnameA) argexprA
+ let resB_assign = mkUncondAssign (Right resnameB) argexprB
+ -- Return the generate functions
+ return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
+
+-----------------------------------------------------------------------------
+-- Function to generate VHDL for applications
+-----------------------------------------------------------------------------
+genApplication ::
+ (Either CoreSyn.CoreBndr AST.VHDLName) -- ^ Where to store the result?
+ -> CoreSyn.CoreBndr -- ^ The function to apply
+ -> [Either CoreSyn.CoreExpr AST.Expr] -- ^ The arguments to apply
+ -> VHDLSession [AST.ConcSm] -- ^ The resulting concurrent statements
+genApplication dst f args =
+ case Var.globalIdVarDetails 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
+ labels <- getFieldLabels (Var.varType bndr)
+ return $ zipWith mkassign labels $ map (either exprToVHDLExpr id) 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
+ Right _ -> error $ "Generate.genApplication Can't generate dataconstructor application without an original binder"
+ IdInfo.VanillaGlobal -> 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...).
+ case (Map.lookup (varToString f) globalNameTable) of
+ Just (arg_count, builder) ->
+ if length args == arg_count then
+ builder dst f args
+ else
+ error $ "Generate.genApplication Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
+ Nothing -> error $ "Using function from another module that is not a known builtin: " ++ pprString f
+ IdInfo.NotGlobalId -> do
+ signatures <- getA vsSignatures
+ -- This is a local id, so it should be a function whose definition we
+ -- have and which can be turned into a component instantiation.
+ let
+ signature = Maybe.fromMaybe
+ (error $ "Using function '" ++ (varToString f) ++ "' without signature? This should not happen!")
+ (Map.lookup f signatures)
+ entity_id = ent_id signature
+ -- TODO: Using show here isn't really pretty, but we'll need some
+ -- unique-ish value...
+ label = "comp_ins_" ++ (either show prettyShow) dst
+ portmaps = mkAssocElems (map (either exprToVHDLExpr id) args) ((either varToVHDLName id) dst) signature
+ in
+ return [mkComponentInst label entity_id portmaps]
+ details -> error $ "Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details
+
+-----------------------------------------------------------------------------
+-- Functions to generate functions dealing with vectors.
+-----------------------------------------------------------------------------
+
+-- Returns the VHDLId of the vector function with the given name for the given
+-- element type. Generates -- this function if needed.
+vectorFunId :: Type.Type -> String -> VHDLSession AST.VHDLId
+vectorFunId el_ty fname = do
+ elemTM <- vhdl_ty 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 vsTypeFuns
+ case Map.lookup (OrdType el_ty, fname) typefuns of
+ -- Function already generated, just return it
+ Just (id, _) -> return id
+ -- Function not generated yet, generate it
+ Nothing -> do
+ let functions = genUnconsVectorFuns elemTM vectorTM
+ case lookup fname functions of
+ Just body -> do
+ modA vsTypeFuns $ Map.insert (OrdType el_ty, fname) (function_id, body)
+ return function_id
+ Nothing -> error $ "I don't know how to generate vector function " ++ fname
+ where
+ function_id = mkVHDLExtId fname