Provide preliminary support for list types.

Lot's of TODO's are left...

diff --git a/Bits.hs b/Bits.hs
index 99131d063ceffb834d2eec05451fac449feaf38b..50f6aa4c3f6766749e0a6e590080f62437c78591 100644 (file)
--- a/Bits.hs
+++ b/Bits.hs
@@ -1,5 +1,10 @@
+{-# LANGUAGE FlexibleContexts,GADTs,ExistentialQuantification,LiberalTypeSynonyms #-}
+
 module Bits where
 
+import qualified Data.Param.FSVec as FSVec
+import qualified Data.TypeLevel as TypeLevel
+
 --class Signal a where
 --     hwand :: a -> a -> a
 --     hwor  :: a -> a -> a
@@ -53,4 +58,8 @@ type Stream a = [a]
 lows  = Low : lows
 highs = High : highs
 
+dontcare = undefined
+
+type BitVec len = FSVec.FSVec len Bit
+
 -- vim: set ts=8 sw=2 sts=2 expandtab:

diff --git a/Pretty.hs b/Pretty.hs
index d23081e4f1ebcaec65ce960070d1579e8b477e35..75c73cc095e422f0b52456d75350853738cdfe18 100644 (file)
--- a/Pretty.hs
+++ b/Pretty.hs
@@ -124,14 +124,17 @@ instance Pretty FuncData where
       pparch (Just _) = text "VHDL architecture present"
 
 instance Pretty Entity where
-  pPrint (Entity id args res decl) =
+  pPrint (Entity id args res decl pkg) =
     text "Entity: " $$ nest 10 (pPrint id)
     $+$ text "Args: " $$ nest 10 (pPrint args)
     $+$ text "Result: " $$ nest 10 (pPrint res)
     $+$ ppdecl decl
+    $+$ pppkg pkg
     where
       ppdecl Nothing = text "VHDL entity not present"
       ppdecl (Just _) = text "VHDL entity present"
+      pppkg Nothing = text "VHDL package not present"
+      pppkg (Just _) = text "VHDL package present"
 
 instance (OutputableBndr b, Show b) => Pretty (CoreSyn.Bind b) where
   pPrint (CoreSyn.NonRec b expr) =

diff --git a/Translator.hs b/Translator.hs
index 841f63b892c2f330adfa88bca5c837cf5a7ada23..383c477282e04fa3429c153520cf13064eca1d0d 100644 (file)
--- a/Translator.hs
+++ b/Translator.hs
@@ -387,7 +387,7 @@ addBuiltIn (BuiltIn name args res) = do
     setEntity hsfunc entity
   where
     hsfunc = HsFunction name (map useAsPort args) (useAsPort res)
-    entity = Entity (VHDL.mkVHDLId name) (map toVHDLSignalMap args) (toVHDLSignalMap res) Nothing
+    entity = Entity (VHDL.mkVHDLId name) (map toVHDLSignalMap args) (toVHDLSignalMap res) Nothing Nothing
 
 builtin_funcs = 
   [ 

diff --git a/VHDL.hs b/VHDL.hs
index b448672131c980bbe0df173fe86938235ce50ea7..f5ab7cd25cd23046d6e95887036c6f50d3e51331 100644 (file)
--- a/VHDL.hs
+++ b/VHDL.hs
@@ -6,6 +6,9 @@ module VHDL where
 import qualified Data.Foldable as Foldable
 import qualified Maybe
 import qualified Control.Monad as Monad
+import qualified Control.Arrow as Arrow
+import qualified Data.Traversable as Traversable
+import qualified Data.Monoid as Monoid
 
 import qualified Type
 import qualified TysWiredIn
@@ -30,7 +33,7 @@ getDesignFiles = do
   let context = [
         AST.Library $ mkVHDLId "IEEE",
         AST.Use $ (AST.NSimple $ mkVHDLId "IEEE.std_logic_1164") AST.:.: AST.All]
-  return $ map (\(ent, arch) -> AST.DesignFile context [ent, arch]) units
+  return $ map (AST.DesignFile context) units
   
 -- | Create an entity for a given function
 createEntity ::
@@ -45,26 +48,34 @@ createEntity hsfunc fdata =
     Nothing -> do return ()
     -- Create an entity for all other functions
     Just flatfunc ->
-      
       let 
         sigs    = flat_sigs flatfunc
         args    = flat_args flatfunc
         res     = flat_res  flatfunc
-        args'   = map (fmap (mkMap sigs)) args
-        res'    = fmap (mkMap sigs) res
+        (ty_decls, args') = Traversable.traverse (Traversable.traverse (mkMap sigs)) args
+        (ty_decls', res') = Traversable.traverse (mkMap sigs) res
+        -- TODO: Unique ty_decls
         ent_decl' = createEntityAST hsfunc args' res'
+        pkg_id = mkVHDLId $ (AST.fromVHDLId entity_id) ++ "_types"
+        pkg_decl = if null ty_decls && null ty_decls'
+          then Nothing
+          else Just $ AST.PackageDec pkg_id (map AST.PDITD $ ty_decls ++ ty_decls')
         AST.EntityDec entity_id _ = ent_decl' 
-        entity' = Entity entity_id args' res' (Just ent_decl')
-      in
+        entity' = Entity entity_id args' res' (Just ent_decl') pkg_decl
+      in do
         setEntity hsfunc entity'
   where
-    mkMap :: Eq id => [(id, SignalInfo)] -> id -> Maybe (AST.VHDLId, AST.TypeMark)
+    mkMap :: 
+      [(SignalId, SignalInfo)] 
+      -> SignalId 
+      -> ([AST.TypeDec], Maybe (AST.VHDLId, AST.TypeMark))
     mkMap sigmap id =
       if isPortSigUse $ sigUse info
         then
-          Just (mkVHDLId nm, vhdl_ty ty)
+          let (decs, type_mark) = vhdl_ty ty in
+          (decs, Just (mkVHDLId nm, type_mark))
         else
-          Nothing
+          (Monoid.mempty, Nothing)
       where
         info = Maybe.fromMaybe
           (error $ "Signal not found in the name map? This should not happen!")
@@ -134,7 +145,9 @@ createArchitecture hsfunc fdata =
                       (getEntityId fdata)
       -- Create signal declarations for all signals that are not in args and
       -- res
-      let sig_decs = Maybe.catMaybes $ map (mkSigDec . snd) sigs
+      let (ty_decls, sig_decs)  = Arrow.second Maybe.catMaybes $ Traversable.traverse (mkSigDec . snd) sigs
+      -- TODO: Unique ty_decls
+      -- TODO: Store ty_decls somewhere
       -- Create concurrent statements for all signal definitions
       statements <- mapM (mkConcSm sigs) defs
       let procs = map mkStateProcSm (makeStatePairs flatfunc)
@@ -169,13 +182,14 @@ mkStateProcSm (num, old, new) =
     rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
     statement   = AST.IfSm rising_edge_clk [assign] [] Nothing
 
-mkSigDec :: SignalInfo -> Maybe AST.SigDec
+mkSigDec :: SignalInfo -> ([AST.TypeDec], Maybe AST.SigDec)
 mkSigDec info =
   let use = sigUse info in
   if isInternalSigUse use || isStateSigUse use then
-    Just $ AST.SigDec (getSignalId info) (vhdl_ty ty) Nothing
+    let (ty_decls, type_mark) = vhdl_ty ty in
+    (ty_decls, Just $ AST.SigDec (getSignalId info) type_mark Nothing)
   else
-    Nothing
+    ([], Nothing)
   where
     ty = sigTy info
 
@@ -292,7 +306,7 @@ getEntityId fdata =
 
 getLibraryUnits ::
   (HsFunction, FuncData)      -- | A function from the session
-  -> Maybe (AST.LibraryUnit, AST.LibraryUnit) -- | The entity and architecture for the function
+  -> Maybe [AST.LibraryUnit]  -- | The entity, architecture and optional package for the function
 
 getLibraryUnits (hsfunc, fdata) =
   case funcEntity fdata of 
@@ -304,7 +318,9 @@ getLibraryUnits (hsfunc, fdata) =
         case funcArch fdata of
           Nothing -> Nothing
           Just arch ->
-            Just (AST.LUEntity decl, AST.LUArch arch)
+            Just $
+              [AST.LUEntity decl, AST.LUArch arch]
+              ++ (Maybe.maybeToList (fmap AST.LUPackageDec $ ent_pkg_decl ent))
 
 -- | The VHDL Bit type
 bit_ty :: AST.TypeMark
@@ -319,24 +335,36 @@ std_logic_ty :: AST.TypeMark
 std_logic_ty = AST.unsafeVHDLBasicId "std_logic"
 
 -- Translate a Haskell type to a VHDL type
-vhdl_ty :: Type.Type -> AST.TypeMark
+vhdl_ty :: Type.Type -> ([AST.TypeDec], AST.TypeMark)
 vhdl_ty ty = Maybe.fromMaybe
   (error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty))
   (vhdl_ty_maybe ty)
 
--- Translate a Haskell type to a VHDL type
-vhdl_ty_maybe :: Type.Type -> Maybe AST.TypeMark
+-- Translate a Haskell type to a VHDL type, optionally generating a type
+-- declaration for the type.
+vhdl_ty_maybe :: Type.Type -> Maybe ([AST.TypeDec], AST.TypeMark)
 vhdl_ty_maybe ty =
   if Type.coreEqType ty TysWiredIn.boolTy
     then
-      Just bool_ty
+      Just ([], bool_ty)
     else
       case Type.splitTyConApp_maybe ty of
         Just (tycon, args) ->
           let name = TyCon.tyConName tycon in
             -- TODO: Do something more robust than string matching
             case Name.getOccString name of
-              "Bit"      -> Just std_logic_ty
+              "Bit"      -> Just ([], std_logic_ty)
+              "FSVec"    ->
+                let 
+                  [len, el_ty] = args 
+                  -- TODO: Find actual number
+                  ty_id = mkVHDLId ("vector_" ++ (show len))
+                  -- TODO: Use el_ty
+                  range = AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "16")]
+                  ty_def = AST.TDA $ AST.ConsArrayDef range std_logic_ty
+                  ty_dec = AST.TypeDec ty_id ty_def
+                in
+                  Just ([ty_dec], ty_id)
               otherwise  -> Nothing
         otherwise -> Nothing
 

diff --git a/VHDLTypes.hs b/VHDLTypes.hs
index 26ed823d904f35dd6653513f84cf2788e81ddac2..9fdfbf1b0c34ef35679675680c1902f8c2e5db42 100644 (file)
--- a/VHDLTypes.hs
+++ b/VHDLTypes.hs
@@ -19,5 +19,6 @@ data Entity = Entity {
   ent_id     :: AST.VHDLId,           -- The id of the entity
   ent_args   :: [VHDLSignalMap],      -- A mapping of each function argument to port names
   ent_res    :: VHDLSignalMap,        -- A mapping of the function result to port names
-  ent_decl   :: Maybe AST.EntityDec   -- The actual entity declaration. Can be empty for builtin functions.
+  ent_decl   :: Maybe AST.EntityDec,  -- The actual entity declaration. Can be empty for builtin functions.
+  ent_pkg_decl :: Maybe AST.PackageDec -- A package declaration with types for this entity
 }