-{-# LANGUAGE PackageImports #-}
-
module CLasH.VHDL.Generate where
-- Standard modules
-import qualified Control.Monad as Monad
import qualified Data.Map as Map
import qualified Maybe
import qualified Data.Either as Either
-import qualified Control.Monad.Trans.State as State
-import qualified "transformers" Control.Monad.Identity as Identity
import Data.Accessor
import Data.Accessor.MonadState as MonadState
import Debug.Trace
import qualified Language.VHDL.AST as AST
-- GHC API
-import CoreSyn
-import Type
+import qualified CoreSyn
+import qualified Type
import qualified Var
import qualified IdInfo
import qualified Literal
genFromInteger' (Right name) _ _ = error $ "\nGenerate.genFromInteger': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
+genSizedInt :: BuiltinBuilder
+genSizedInt = genFromInteger
+
+genTFVec :: BuiltinBuilder
+genTFVec (Left res) f [Left veclist] = do {
+ ; let (CoreSyn.Let (CoreSyn.Rec letbndrs) rez) = veclist
+ ; letapps <- mapM genLetApp letbndrs
+ ; let bndrs = Maybe.catMaybes (map fst letapps)
+ ; (aap,kooi) <- reduceFSVECListToHsList rez
+ ; sigs <- mapM (\x -> MonadState.lift vsType $ varToVHDLExpr x) (bndrs ++ aap)
+ ; let vecsigns = concatsigs sigs
+ ; let vecassign = mkUncondAssign (Left res) vecsigns
+ ; sig_dec_maybes <- mapM mkSigDec (bndrs ++ aap)
+ ; let sig_decs = map (AST.BDISD) (Maybe.catMaybes $ sig_dec_maybes)
+ ; let block_label = mkVHDLExtId ("FSVec_" ++ (show (map varToString (bndrs ++ aap))))
+ ; let block = AST.BlockSm block_label [] (AST.PMapAspect []) sig_decs ((concat (map snd letapps)) ++ kooi ++ [vecassign])
+ ; return $ [AST.CSBSm block]
+ }
+ where
+ concatsigs x = AST.Aggregate (map (\z -> AST.ElemAssoc Nothing z) x)
+
+genLetApp :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> VHDLSession (Maybe CoreSyn.CoreBndr, [AST.ConcSm])
+genLetApp (bndr, app@(CoreSyn.App _ _)) = do
+ let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
+ let valargs = get_val_args (Var.varType f) args
+ apps <- genApplication (Left bndr) f (map Left valargs)
+ return (Just bndr, apps)
+
+genLetApp _ = return (Nothing,[])
+
+reduceFSVECListToHsList :: CoreSyn.CoreExpr -> VHDLSession ([CoreSyn.CoreBndr], [AST.ConcSm])
+reduceFSVECListToHsList app@(CoreSyn.App _ letexpr) = do
+ case letexpr of
+ (CoreSyn.Let (CoreSyn.Rec letbndrs) rez) -> do
+ letapps <- mapM genLetApp letbndrs
+ let bndrs = Maybe.catMaybes (map fst letapps)
+ let app = (map snd letapps)
+ (vars, apps) <- reduceFSVECListToHsList rez
+ return ((bndrs ++ vars),((concat app) ++ apps))
+ otherwise -> return ([],[])
+
-- | Generate a generate statement for the builtin function "map"
genMap :: BuiltinBuilder
-genMap (Left res) f [Left mapped_f, Left (Var arg)] = do {
+genMap (Left res) f [Left mapped_f, Left (CoreSyn.Var arg)] = do {
-- mapped_f must be a CoreExpr (since we can't represent functions as VHDL
-- expressions). arg must be a CoreExpr (and should be a CoreSyn.Var), since
-- we must index it (which we couldn't if it was a VHDL Expr, since only
-- An expression for len-1
let len_min_expr = (AST.PrimLit $ show (len-1))
-- evec is (TFVec n), so it still needs an element type
- let (nvec, _) = splitAppTy (Var.varType vec)
+ let (nvec, _) = Type.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)
genConcat' (Left res) f args@[arg] = do {
-- Setup the generate scheme
; len1 <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg
- ; let (_, nvec) = splitAppTy (Var.varType arg)
+ ; let (_, nvec) = Type.splitAppTy (Var.varType arg)
; len2 <- MonadState.lift vsType $ tfp_to_int $ tfvec_len_ty nvec
-- TODO: Use something better than varToString
; let { label = mkVHDLExtId ("concatVector" ++ (varToString res))
let sel_name = mkSelectedName ((either varToVHDLName id) dst) label in
mkUncondAssign (Right sel_name) arg
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
builder dst f args
else
error $ "\nGenerate.genApplication(VanillaGlobal): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
- Nothing -> error $ "\nGenerate.genApplication(VanillaGlobal): Using function from another module that is not a known builtin: " ++ pprString f
+ Nothing -> error $ ("\nGenerate.genApplication(VanillaGlobal): Using function from another module that is not a known builtin: " ++ (pprString f))
IdInfo.ClassOpId cls -> do
-- FIXME: Not looking for what instance this class op is called for
-- Is quite stupid of course.
, (fromSizedWordId , (1, genFromSizedWord ) )
, (fromIntegerId , (1, genFromInteger ) )
, (resizeId , (1, genResize ) )
+ , (sizedIntId , (1, genSizedInt ) )
+ , (tfvecId , (1, genTFVec ) )
]