Filter non-value variables for built-in functions

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

diff --git a/VHDL.hs b/VHDL.hs
index 229ba5caff3f83d643745156b818aad868055c0a..5603f8c8a21c14ea70f0bd0c531197cb41bda2e4 100644 (file)
--- a/VHDL.hs
+++ b/VHDL.hs
@@ -30,6 +30,7 @@ import qualified Var
 import qualified Id
 import qualified IdInfo
 import qualified TyCon
+import qualified TcType
 import qualified DataCon
 import qualified CoreSubst
 import qualified CoreUtils
@@ -56,11 +57,12 @@ createDesignFiles binds =
   map (Arrow.second $ AST.DesignFile full_context) units
   
   where
-    init_session = VHDLSession Map.empty Map.empty builtin_funcs globalNameTable
+    init_session = VHDLSession Map.empty Map.empty Map.empty builtin_funcs globalNameTable
     (units, final_session) = 
       State.runState (createLibraryUnits binds) init_session
     tyfun_decls = Map.elems (final_session ^.vsTypeFuns)
     ty_decls = map mktydecl $ Map.elems (final_session ^. vsTypes)
+    vec_decls = map (\(v_id, v_def) -> AST.PDITD $ AST.TypeDec v_id v_def) (Map.elems (final_session ^. vsElemTypes))
     ieee_context = [
         AST.Library $ mkVHDLBasicId "IEEE",
         mkUseAll ["IEEE", "std_logic_1164"],
@@ -69,7 +71,7 @@ createDesignFiles binds =
     full_context =
       mkUseAll ["work", "types"]
       : ieee_context
-    type_package_dec = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") (ty_decls ++ subProgSpecs)
+    type_package_dec = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") (vec_decls ++ ty_decls ++ subProgSpecs)
     type_package_body = AST.LUPackageBody $ AST.PackageBody typesId (concat tyfun_decls)
     subProgSpecs = concat (map subProgSpec tyfun_decls)
     subProgSpec = map (\(AST.SubProgBody spec _ _) -> AST.PDISS spec)
@@ -258,13 +260,15 @@ mkConcSm ::
 
 mkConcSm (bndr, app@(CoreSyn.App _ _))= do
   let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
+  let valargs' = filter isValArg args
+  let valargs = filter (\(CoreSyn.Var bndr) -> not (Id.isDictId bndr)) valargs'
   case Var.globalIdVarDetails f of
     IdInfo.DataConWorkId dc ->
         -- It's a datacon. Create a record from its arguments.
         -- First, filter out type args. TODO: Is this the best way to do this?
         -- The types should already have been taken into acocunt when creating
         -- the signal, so this should probably work...
-        let valargs = filter isValArg args in
+        --let valargs = filter isValArg args in
         if all is_var valargs then do
           labels <- getFieldLabels (CoreUtils.exprType app)
           let assigns = zipWith mkassign labels valargs
@@ -284,9 +288,9 @@ mkConcSm (bndr, app@(CoreSyn.App _ _))= do
       funSignatures <- getA vsNameTable
       case (Map.lookup (bndrToString f) funSignatures) of
         Just (arg_count, builder) ->
-          if length args == arg_count then
+          if length valargs == arg_count then
             let
-              sigs = map (bndrToString.varBndr) args
+              sigs = map (bndrToString.varBndr) valargs
               sigsNames = map (\signal -> (AST.PrimName (AST.NSimple (mkVHDLExtId signal)))) sigs
               func = builder sigsNames
               src_wform = AST.Wform [AST.WformElem func Nothing]
@@ -295,7 +299,7 @@ mkConcSm (bndr, app@(CoreSyn.App _ _))= do
             in
               return $ AST.CSSASm assign
           else
-            error $ "VHDL.mkConcSm Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ pprString args
+            error $ "VHDL.mkConcSm Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ pprString valargs
         Nothing -> error $ "Using function from another module that is not a known builtin: " ++ pprString f
     IdInfo.NotGlobalId -> do
       signatures <- getA vsSignatures
@@ -567,11 +571,11 @@ construct_vhdl_ty ty = do
       let name = Name.getOccString (TyCon.tyConName tycon)
       case name of
         "TFVec" -> do
-          res <- mk_vector_ty (tfvec_len ty) ty
-          return $ Just $ (Arrow.second Left) res
-        "SizedWord" -> do
-          res <- mk_vector_ty (sized_word_len ty) ty
-          return $ Just $ (Arrow.second Left) res
+          res <- mk_vector_ty (tfvec_len ty) (tfvec_elem ty) ty
+          return $ Just $ (Arrow.second Right) res
+        -- "SizedWord" -> do
+        --   res <- mk_vector_ty (sized_word_len ty) ty
+        --   return $ Just $ (Arrow.second Left) res
         "RangedWord" -> do 
           res <- mk_natural_ty 0 (ranged_word_bound ty) ty
           return $ Just $ (Arrow.second Right) res
@@ -611,17 +615,27 @@ mk_tycon_ty tycon args =
 -- | Create a VHDL vector type
 mk_vector_ty ::
   Int -- ^ The length of the vector
+  -> Type.Type -- ^ The Haskell element type of the Vector
   -> Type.Type -- ^ The Haskell type to create a VHDL type for
-  -> VHDLState (AST.TypeMark, AST.TypeDef) -- The typemark created.
+  -> VHDLState (AST.TypeMark, AST.SubtypeIn) -- The typemark created.
 
-mk_vector_ty len ty = do
-  -- Assume there is a single type argument
-  let ty_id = mkVHDLExtId $ "vector_" ++ (show len)
-  -- TODO: Use el_ty
+mk_vector_ty len el_ty ty = do
+  elem_types_map <- getA vsElemTypes
+  el_ty_tm <- vhdl_ty el_ty
+  let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId el_ty_tm) ++ "-0_to_" ++ (show len)
   let range = AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
-  let ty_def = AST.TDA $ AST.ConsArrayDef range std_logic_ty
-  modA vsTypeFuns (Map.insert (OrdType ty) (genUnconsVectorFuns std_logic_ty ty_id))
-  return (ty_id, ty_def)
+  let existing_elem_ty = (fmap fst) $ Map.lookup (OrdType el_ty) elem_types_map
+  case existing_elem_ty of
+    Just t -> do
+      let ty_def = AST.SubtypeIn t (Just range)
+      return (ty_id, ty_def)
+    Nothing -> do
+      let vec_id = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId el_ty_tm)
+      let vec_def = AST.TDA $ AST.UnconsArrayDef [naturalTM] el_ty_tm
+      modA vsElemTypes (Map.insert (OrdType el_ty) (vec_id, vec_def))
+      modA vsTypeFuns (Map.insert (OrdType ty) (genUnconsVectorFuns el_ty_tm vec_id)) 
+      let ty_def = AST.SubtypeIn vec_id (Just range)
+      return (ty_id, ty_def)
 
 mk_natural_ty ::
   Int -- ^ The minimum bound (> 0)