Cabalized clash

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

diff --git a/VHDL.hs b/VHDL.hs
index c952dddf5e2f6a9485e2fdf076a1a0bd6eb057d2..c5635046998c196f4ed4cded551dd0ddf827a002 100644 (file)
--- a/VHDL.hs
+++ b/VHDL.hs
@@ -3,6 +3,7 @@
 --
 module VHDL where
 
 --
 module VHDL where
 

+-- Standard modules

 import qualified Data.Foldable as Foldable
 import qualified Data.List as List
 import qualified Data.Map as Map
 import qualified Data.Foldable as Foldable
 import qualified Data.List as List
 import qualified Data.Map as Map


@@ -14,28 +15,35 @@ import qualified Data.Traversable as Traversable
 import qualified Data.Monoid as Monoid
 import Data.Accessor
 import qualified Data.Accessor.MonadState as MonadState
 import qualified Data.Monoid as Monoid
 import Data.Accessor
 import qualified Data.Accessor.MonadState as MonadState

+import Text.Regex.Posix

 
 

+-- ForSyDe
+import qualified ForSyDe.Backend.VHDL.AST as AST
+
+-- GHC API

 import qualified Type
 import qualified Type

-import qualified TysWiredIn

 import qualified Name
 import qualified TyCon
 import Outputable ( showSDoc, ppr )
 
 import qualified Name
 import qualified TyCon
 import Outputable ( showSDoc, ppr )
 

-import qualified ForSyDe.Backend.VHDL.AST as AST
-
+-- Local imports

 import VHDLTypes
 import Flatten
 import FlattenTypes
 import TranslatorTypes
 import HsValueMap
 import Pretty
 import VHDLTypes
 import Flatten
 import FlattenTypes
 import TranslatorTypes
 import HsValueMap
 import Pretty

+import CoreTools
+import Constants
+import Generate
+import GlobalNameTable

 
 createDesignFiles ::
   FlatFuncMap
   -> [(AST.VHDLId, AST.DesignFile)]
 
 createDesignFiles flatfuncmap =
 
 createDesignFiles ::
   FlatFuncMap
   -> [(AST.VHDLId, AST.DesignFile)]
 
 createDesignFiles flatfuncmap =

-  (mkVHDLId "types", AST.DesignFile ieee_context [type_package]) :
+  (mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package]) :

   map (Arrow.second $ AST.DesignFile full_context) units
   
   where
   map (Arrow.second $ AST.DesignFile full_context) units
   
   where


@@ -44,14 +52,25 @@ createDesignFiles flatfuncmap =
       State.runState (createLibraryUnits flatfuncmap) init_session
     ty_decls = Map.elems (final_session ^. vsTypes)
     ieee_context = [
       State.runState (createLibraryUnits flatfuncmap) init_session
     ty_decls = Map.elems (final_session ^. vsTypes)
     ieee_context = [

-        AST.Library $ mkVHDLId "IEEE",
-        AST.Use $ (AST.NSimple $ mkVHDLId "IEEE.std_logic_1164") AST.:.: AST.All
+        AST.Library $ mkVHDLBasicId "IEEE",
+        mkUseAll ["IEEE", "std_logic_1164"],
+        mkUseAll ["IEEE", "numeric_std"]

       ]
     full_context =
       ]
     full_context =

-      (AST.Use $ (AST.NSimple $ mkVHDLId "work.types") AST.:.: AST.All)
+      mkUseAll ["work", "types"]

       : ieee_context
       : ieee_context

-    type_package = AST.LUPackageDec $ AST.PackageDec (mkVHDLId "types") (map (AST.PDITD . snd) ty_decls)
+    type_package = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") (map (AST.PDITD . snd) ty_decls)

 
 

+-- Create a use foo.bar.all statement. Takes a list of components in the used
+-- name. Must contain at least two components
+mkUseAll :: [String] -> AST.ContextItem
+mkUseAll ss = 
+  AST.Use $ from AST.:.: AST.All
+  where
+    base_prefix = (AST.NSimple $ mkVHDLBasicId $ head ss)
+    from = foldl select base_prefix (tail ss)
+    select prefix s = AST.NSelected $ prefix AST.:.: (AST.SSimple $ mkVHDLBasicId s)
+      

 createLibraryUnits ::
   FlatFuncMap
   -> VHDLState [(AST.VHDLId, [AST.LibraryUnit])]
 createLibraryUnits ::
   FlatFuncMap
   -> VHDLState [(AST.VHDLId, [AST.LibraryUnit])]


@@ -104,7 +123,7 @@ createEntity hsfunc flatfunc = do
         if isPortSigUse $ sigUse info
           then do
             type_mark <- vhdl_ty ty
         if isPortSigUse $ sigUse info
           then do
             type_mark <- vhdl_ty ty

-            return $ Just (mkVHDLId nm, type_mark)
+            return $ Just (mkVHDLExtId nm, type_mark)

           else
             return $ Nothing
        )
           else
             return $ Nothing
        )


@@ -129,7 +148,7 @@ createEntityAST hsfunc args res =
     -- Add a clk port if we have state
     clk_port = if hasState hsfunc
       then
     -- Add a clk port if we have state
     clk_port = if hasState hsfunc
       then

-        [AST.IfaceSigDec (mkVHDLId "clk") AST.In VHDL.std_logic_ty]
+        [AST.IfaceSigDec (mkVHDLExtId "clk") AST.In VHDL.std_logic_ty]

       else
         []
 
       else
         []
 


@@ -145,7 +164,9 @@ mkIfaceSigDec _ Nothing = Nothing
 -- | Generate a VHDL entity name for the given hsfunc
 mkEntityId hsfunc =
   -- TODO: This doesn't work for functions with multiple signatures!
 -- | Generate a VHDL entity name for the given hsfunc
 mkEntityId hsfunc =
   -- TODO: This doesn't work for functions with multiple signatures!

-  mkVHDLId $ hsFuncName hsfunc
+  -- Use a Basic Id, since using extended id's for entities throws off
+  -- precision and causes problems when generating filenames.
+  mkVHDLBasicId $ hsFuncName hsfunc

 
 -- | Create an architecture for a given function
 createArchitecture ::
 
 -- | Create an architecture for a given function
 createArchitecture ::


@@ -163,8 +184,8 @@ createArchitecture hsfunc flatfunc = do
   sig_dec_maybes <- mapM (mkSigDec' . snd) sigs
   let sig_decs = Maybe.catMaybes $ sig_dec_maybes
   -- Create concurrent statements for all signal definitions
   sig_dec_maybes <- mapM (mkSigDec' . snd) sigs
   let sig_decs = Maybe.catMaybes $ sig_dec_maybes
   -- Create concurrent statements for all signal definitions

-  let statements = zipWith (mkConcSm signaturemap sigs) defs [0..]
-  return $ AST.ArchBody (mkVHDLId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
+  statements <- Monad.zipWithM (mkConcSm sigs) defs [0..]
+  return $ AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')

   where
     sigs = flat_sigs flatfunc
     args = flat_args flatfunc
   where
     sigs = flat_sigs flatfunc
     args = flat_args flatfunc


@@ -194,9 +215,9 @@ mkStateProcSm :: (StateId, SignalInfo, SignalInfo) -> AST.ProcSm
 mkStateProcSm (num, old, new) =
   AST.ProcSm label [clk] [statement]
   where
 mkStateProcSm (num, old, new) =
   AST.ProcSm label [clk] [statement]
   where

-    label       = mkVHDLId $ "state_" ++ (show num)
-    clk         = mkVHDLId "clk"
-    rising_edge = AST.NSimple $ mkVHDLId "rising_edge"
+    label       = mkVHDLExtId $ "state_" ++ (show num)
+    clk         = mkVHDLExtId "clk"
+    rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"

     wform       = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple $ getSignalId new) Nothing]
     assign      = AST.SigAssign (AST.NSimple $ getSignalId old) wform
     rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
     wform       = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple $ getSignalId new) Nothing]
     assign      = AST.SigAssign (AST.NSimple $ getSignalId old) wform
     rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]


@@ -217,52 +238,58 @@ mkSigDec info =
 --   is not named.
 getSignalId :: SignalInfo -> AST.VHDLId
 getSignalId info =
 --   is not named.
 getSignalId :: SignalInfo -> AST.VHDLId
 getSignalId info =

-    mkVHDLId $ Maybe.fromMaybe
+    mkVHDLExtId $ Maybe.fromMaybe

       (error $ "Unnamed signal? This should not happen!")
       (sigName info)
 
 -- | Transforms a signal definition into a VHDL concurrent statement
 mkConcSm ::
       (error $ "Unnamed signal? This should not happen!")
       (sigName info)
 
 -- | Transforms a signal definition into a VHDL concurrent statement
 mkConcSm ::

-  SignatureMap             -- ^ The interfaces of functions in the session
-  -> [(SignalId, SignalInfo)] -- ^ The signals in the current architecture
+  [(SignalId, SignalInfo)] -- ^ The signals in the current architecture

   -> SigDef                -- ^ The signal definition 
   -> Int                   -- ^ A number that will be unique for all
                            --   concurrent statements in the architecture.
   -> SigDef                -- ^ The signal definition 
   -> Int                   -- ^ A number that will be unique for all
                            --   concurrent statements in the architecture.

-  -> AST.ConcSm            -- ^ The corresponding VHDL component instantiation.
+  -> VHDLState AST.ConcSm  -- ^ The corresponding VHDL component instantiation.

 
 

-mkConcSm signatures sigs (FApp hsfunc args res) num =
+mkConcSm sigs (FApp hsfunc args res) num = do
+  signatures <- getA vsSignatures

   let 
   let 

-    signature = Maybe.fromMaybe
-        (error $ "Using function '" ++ (prettyShow hsfunc) ++ "' without signature? This should not happen!")
-        (Map.lookup hsfunc signatures)
-    entity_id = ent_id signature
-    label = (AST.fromVHDLId entity_id) ++ "_" ++ (show num)
-    -- Add a clk port if we have state
-    clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLId "clk") "clk"
-    portmaps = mkAssocElems sigs args res signature ++ (if hasState hsfunc then [clk_port] else [])
-  in
-    AST.CSISm $ AST.CompInsSm (mkVHDLId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)
-
-mkConcSm _ sigs (UncondDef src dst) _ =
-  let
-    src_expr  = vhdl_expr src
-    src_wform = AST.Wform [AST.WformElem src_expr Nothing]
-    dst_name  = AST.NSimple (getSignalId $ signalInfo sigs dst)
-    assign    = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
-  in
-    AST.CSSASm assign
+      signature = Maybe.fromMaybe
+          (error $ "Using function '" ++ (prettyShow hsfunc) ++ "' without signature? This should not happen!")
+          (Map.lookup hsfunc signatures)
+      entity_id = ent_id signature
+      label = (AST.fromVHDLId entity_id) ++ "_" ++ (show num)
+      -- Add a clk port if we have state
+      clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
+      portmaps = mkAssocElems sigs args res signature ++ (if hasState hsfunc then [clk_port] else [])
+    in
+      return $ AST.CSISm $ AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)
+
+mkConcSm sigs (UncondDef src dst) _ = do
+  src_expr <- vhdl_expr src
+  let src_wform = AST.Wform [AST.WformElem src_expr Nothing]
+  let dst_name  = AST.NSimple (getSignalId $ signalInfo sigs dst)
+  let assign    = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
+  return $ AST.CSSASm assign

   where
   where

-    vhdl_expr (Left id) = mkIdExpr sigs id
+    vhdl_expr (Left id) = return $ mkIdExpr sigs id

     vhdl_expr (Right expr) =
       case expr of
         (EqLit id lit) ->
     vhdl_expr (Right expr) =
       case expr of
         (EqLit id lit) ->

-          (mkIdExpr sigs id) AST.:=: (AST.PrimLit lit)
-        (Literal lit) ->
-          AST.PrimLit lit
+          return $ (mkIdExpr sigs id) AST.:=: (AST.PrimLit lit)
+        (Literal lit Nothing) ->
+          return $ AST.PrimLit lit
+        (Literal lit (Just ty)) -> do
+          -- Create a cast expression, which is just a function call using the
+          -- type name as the function name.
+          let litexpr = AST.PrimLit lit
+          ty_id <- MonadState.lift vsTypes (vhdl_ty ty)
+          let ty_name = AST.NSimple ty_id
+          let args = [Nothing AST.:=>: (AST.ADExpr litexpr)] 
+          return $ AST.PrimFCall $ AST.FCall ty_name args

         (Eq a b) ->
         (Eq a b) ->

-          (mkIdExpr sigs a) AST.:=: (mkIdExpr sigs b)
+         return $  (mkIdExpr sigs a) AST.:=: (mkIdExpr sigs b)

 
 

-mkConcSm _ sigs (CondDef cond true false dst) _ =
+mkConcSm sigs (CondDef cond true false dst) _ =

   let
     cond_expr  = mkIdExpr sigs cond
     true_expr  = mkIdExpr sigs true
   let
     cond_expr  = mkIdExpr sigs cond
     true_expr  = mkIdExpr sigs true


@@ -273,7 +300,7 @@ mkConcSm _ sigs (CondDef cond true false dst) _ =
     dst_name  = AST.NSimple (getSignalId $ signalInfo sigs dst)
     assign    = dst_name AST.:<==: (AST.ConWforms [whenelse] false_wform Nothing)
   in
     dst_name  = AST.NSimple (getSignalId $ signalInfo sigs dst)
     assign    = dst_name AST.:<==: (AST.ConWforms [whenelse] false_wform Nothing)
   in

-    AST.CSSASm assign
+    return $ AST.CSSASm assign

 
 -- | Turn a SignalId into a VHDL Expr
 mkIdExpr :: [(SignalId, SignalInfo)] -> SignalId -> AST.Expr
 
 -- | Turn a SignalId into a VHDL Expr
 mkIdExpr :: [(SignalId, SignalInfo)] -> SignalId -> AST.Expr


@@ -317,7 +344,7 @@ lookupSigName sigs sig = name
 
 -- | Create an VHDL port -> signal association
 mkAssocElem :: Maybe AST.VHDLId -> String -> Maybe AST.AssocElem
 
 -- | Create an VHDL port -> signal association
 mkAssocElem :: Maybe AST.VHDLId -> String -> Maybe AST.AssocElem

-mkAssocElem (Just port) signal = Just $ Just port AST.:=>: (AST.ADName (AST.NSimple (mkVHDLId signal))) 
+mkAssocElem (Just port) signal = Just $ Just port AST.:=>: (AST.ADName (AST.NSimple (mkVHDLExtId signal))) 

 mkAssocElem Nothing _ = Nothing
 
 -- | The VHDL Bit type
 mkAssocElem Nothing _ = Nothing
 
 -- | The VHDL Bit type


@@ -352,27 +379,25 @@ vhdl_ty ty = do
             (tycon, args) <- Type.splitTyConApp_maybe ty
             let name = Name.getOccString (TyCon.tyConName tycon)
             case name of
             (tycon, args) <- Type.splitTyConApp_maybe ty
             let name = Name.getOccString (TyCon.tyConName tycon)
             case name of

-              "FSVec" -> Just $ mk_fsvec_ty ty args
+              "FSVec" -> Just $ mk_vector_ty (fsvec_len ty) ty
+              "SizedWord" -> Just $ mk_vector_ty (sized_word_len ty) ty

               otherwise -> Nothing
       -- Return new_ty when a new type was successfully created
       Maybe.fromMaybe 
         (error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty))
         new_ty
 
               otherwise -> Nothing
       -- Return new_ty when a new type was successfully created
       Maybe.fromMaybe 
         (error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty))
         new_ty
 

--- | Create a VHDL type belonging to a FSVec Haskell type
-mk_fsvec_ty ::
-  Type.Type -- ^ The Haskell type to create a VHDL type for
-  -> [Type.Type] -- ^ Type arguments to the FSVec type constructor
+-- | Create a VHDL vector type
+mk_vector_ty ::
+  Int -- ^ The length of the vector
+  -> Type.Type -- ^ The Haskell type to create a VHDL type for

   -> TypeState AST.TypeMark -- The typemark created.
 
   -> TypeState AST.TypeMark -- The typemark created.
 

-mk_fsvec_ty ty args = do
-  -- Assume there are two type arguments
-  let [len, el_ty] = args 
-  -- TODO: Find actual number
-  -- Construct the type id, but filter out dots (since these are not allowed).
-  let ty_id = mkVHDLId $ filter (/='.') ("vector_" ++ (show len))
+mk_vector_ty len ty = do
+  -- Assume there is a single type argument
+  let ty_id = mkVHDLExtId $ "vector_" ++ (show len)

   -- TODO: Use el_ty
   -- TODO: Use el_ty

-  let range = AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "16")]
+  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
   let ty_dec = AST.TypeDec ty_id ty_def
   -- TODO: Check name uniqueness
   let ty_def = AST.TDA $ AST.ConsArrayDef range std_logic_ty
   let ty_dec = AST.TypeDec ty_id ty_def
   -- TODO: Check name uniqueness


@@ -386,13 +411,19 @@ builtin_types =
     ("Bool", bool_ty) -- TysWiredIn.boolTy
   ]
 
     ("Bool", bool_ty) -- TysWiredIn.boolTy
   ]
 

--- Shortcut
-mkVHDLId :: String -> AST.VHDLId
-mkVHDLId s = 
-  AST.unsafeVHDLBasicId $ (strip_multiscore . strip_invalid) s
+-- Shortcut for 
+-- Can only contain alphanumerics and underscores. The supplied string must be
+-- a valid basic id, otherwise an error value is returned. This function is
+-- not meant to be passed identifiers from a source file, use mkVHDLExtId for
+-- that.
+mkVHDLBasicId :: String -> AST.VHDLId
+mkVHDLBasicId s = 
+  AST.unsafeVHDLBasicId $ (strip_multiscore . strip_leading . strip_invalid) s

   where
     -- Strip invalid characters.
     strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
   where
     -- Strip invalid characters.
     strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")

+    -- Strip leading numbers and underscores
+    strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")

     -- Strip multiple adjacent underscores
     strip_multiscore = concat . map (\cs -> 
         case cs of 
     -- Strip multiple adjacent underscores
     strip_multiscore = concat . map (\cs -> 
         case cs of 


@@ -400,6 +431,18 @@ mkVHDLId s =
           _ -> cs
       ) . List.group
 
           _ -> cs
       ) . List.group
 

+-- Shortcut for Extended VHDL Id's. These Id's can contain a lot more
+-- different characters than basic ids, but can never be used to refer to
+-- basic ids.
+-- Use extended Ids for any values that are taken from the source file.
+mkVHDLExtId :: String -> AST.VHDLId
+mkVHDLExtId s = 
+  AST.unsafeVHDLExtId $ strip_invalid s
+  where 
+    -- Allowed characters, taken from ForSyde's mkVHDLExtId
+    allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&\\'()*+,./:;<=>_|!$%@?[]^`{}~-"
+    strip_invalid = filter (`elem` allowed)
+

 -- | A consise representation of a (set of) ports on a builtin function
 type PortMap = HsValueMap (String, AST.TypeMark)
 -- | A consise representation of a builtin function
 -- | A consise representation of a (set of) ports on a builtin function
 type PortMap = HsValueMap (String, AST.TypeMark)
 -- | A consise representation of a builtin function


@@ -410,7 +453,7 @@ data BuiltIn = BuiltIn String [PortMap] PortMap
 mkBuiltins :: [BuiltIn] -> SignatureMap
 mkBuiltins = Map.fromList . map (\(BuiltIn name args res) ->
     (HsFunction name (map useAsPort args) (useAsPort res),
 mkBuiltins :: [BuiltIn] -> SignatureMap
 mkBuiltins = Map.fromList . map (\(BuiltIn name args res) ->
     (HsFunction name (map useAsPort args) (useAsPort res),

-     Entity (VHDL.mkVHDLId name) (map toVHDLSignalMap args) (toVHDLSignalMap res))
+     Entity (VHDL.mkVHDLBasicId name) (map toVHDLSignalMap args) (toVHDLSignalMap res))

   )
 
 builtin_hsfuncs = Map.keys builtin_funcs
   )
 
 builtin_hsfuncs = Map.keys builtin_funcs


@@ -425,4 +468,4 @@ builtin_funcs = mkBuiltins
 -- | Map a port specification of a builtin function to a VHDL Signal to put in
 --   a VHDLSignalMap
 toVHDLSignalMap :: HsValueMap (String, AST.TypeMark) -> VHDLSignalMap
 -- | Map a port specification of a builtin function to a VHDL Signal to put in
 --   a VHDLSignalMap
 toVHDLSignalMap :: HsValueMap (String, AST.TypeMark) -> VHDLSignalMap

-toVHDLSignalMap = fmap (\(name, ty) -> Just (mkVHDLId name, ty))
+toVHDLSignalMap = fmap (\(name, ty) -> Just (mkVHDLBasicId name, ty))