Clean up imports in Generate.hs

[matthijs/master-project/cλash.git] / cλash / CLasH / VHDL / Generate.hs

diff --git a/cλash/CLasH/VHDL/Generate.hs b/cλash/CLasH/VHDL/Generate.hs
index a2f2fb1dc4991716b3072b885d62287a6eadb3a2..25eac722e714566346f3bf9e634f1aad89de72d1 100644 (file)
--- a/cλash/CLasH/VHDL/Generate.hs
+++ b/cλash/CLasH/VHDL/Generate.hs
@@ -1,14 +1,9 @@
-{-# LANGUAGE PackageImports #-}
-

 module CLasH.VHDL.Generate where
 
 -- Standard modules
 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 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 Data.Accessor
 import Data.Accessor.MonadState as MonadState
 import Debug.Trace


@@ -17,8 +12,8 @@ import Debug.Trace
 import qualified Language.VHDL.AST as AST
 
 -- GHC API
 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
 import qualified Var
 import qualified IdInfo
 import qualified Literal


@@ -161,10 +156,51 @@ genFromInteger' (Left res) f lits = do {
 
 genFromInteger' (Right name) _ _ = error $ "\nGenerate.genFromInteger': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
 
 
 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
 
 -- | 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
   -- 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


@@ -240,7 +276,7 @@ genFold'' len left (Left res) f [folded_f, start, vec] = do
   -- 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
   -- 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)
   -- 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)


@@ -388,7 +424,7 @@ genConcat' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var
 genConcat' (Left res) f args@[arg] = do {
     -- Setup the generate scheme
   ; len1 <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg
 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))
   ; len2 <- MonadState.lift vsType $ tfp_to_int $ tfvec_len_ty nvec
           -- TODO: Use something better than varToString
   ; let { label       = mkVHDLExtId ("concatVector" ++ (varToString res))


@@ -549,6 +585,17 @@ genApplication dst f args = do
                 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"
                 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
         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


@@ -561,7 +608,7 @@ genApplication dst f args = do
                 builder dst f args
               else
                 error $ "\nGenerate.genApplication(VanillaGlobal): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
                 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.
         IdInfo.ClassOpId cls -> do
           -- FIXME: Not looking for what instance this class op is called for
           -- Is quite stupid of course.


@@ -1012,4 +1059,6 @@ globalNameTable = Map.fromList
   , (fromSizedWordId  , (1, genFromSizedWord        ) )
   , (fromIntegerId    , (1, genFromInteger          ) )
   , (resizeId         , (1, genResize               ) )
   , (fromSizedWordId  , (1, genFromSizedWord        ) )
   , (fromIntegerId    , (1, genFromInteger          ) )
   , (resizeId         , (1, genResize               ) )

+  , (sizedIntId       , (1, genSizedInt             ) )
+  , (tfvecId          , (1, genTFVec                ) )

   ]
   ]