Use extended VHDL identifiers where possible.

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

diff --git a/VHDL.hs b/VHDL.hs
index 9a51c7a94ea4a63db3167fc79777cc39e7625078..263bae867f85138f3d77fc72e1bbd31972903c3b 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


@@ -13,36 +14,59 @@ import qualified Control.Monad.Trans.State as State
 import qualified Data.Traversable as Traversable
 import qualified Data.Monoid as Monoid
 import Data.Accessor
 import qualified Data.Traversable as Traversable
 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 VHDLTypes
 import Flatten
 import FlattenTypes
 import TranslatorTypes

+import HsValueMap

 import Pretty
 import Pretty

+import HsTools

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

-  -- TODO: Output types
-  map (Arrow.second $ AST.DesignFile context) units
+  (mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package]) :
+  map (Arrow.second $ AST.DesignFile full_context) units
+  

   where
   where

-    init_session = VHDLSession Map.empty Map.empty
+    init_session = VHDLSession Map.empty builtin_funcs

     (units, final_session) = 
       State.runState (createLibraryUnits flatfuncmap) init_session
     (units, final_session) = 
       State.runState (createLibraryUnits flatfuncmap) init_session

-    context = [
-      AST.Library $ mkVHDLId "IEEE",
-      AST.Use $ (AST.NSimple $ mkVHDLId "IEEE.std_logic_1164") AST.:.: AST.All]
-
+    ty_decls = Map.elems (final_session ^. vsTypes)
+    ieee_context = [
+        AST.Library $ mkVHDLBasicId "IEEE",
+        mkUseAll ["IEEE", "std_logic_1164"]
+      ]
+    full_context =
+      mkUseAll ["work", "types"]
+      : ieee_context
+    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])]


@@ -65,38 +89,25 @@ createEntity ::
   -> FlatFunction -- | The FlatFunction
   -> VHDLState AST.EntityDec -- | The resulting entity
 
   -> FlatFunction -- | The FlatFunction
   -> VHDLState AST.EntityDec -- | The resulting entity
 

-createEntity hsfunc flatfunc = 
-      let 
-        sigs    = flat_sigs flatfunc
-        args    = flat_args flatfunc
-        res     = flat_res  flatfunc
-        (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')
-        -- TODO: Output package
-        AST.EntityDec entity_id _ = ent_decl' 
-        signature = Entity entity_id args' res'
-      in do
-        modA vsSignatures (Map.insert hsfunc signature)
-        return ent_decl'
+createEntity hsfunc flatfunc = do
+      let sigs    = flat_sigs flatfunc
+      let args    = flat_args flatfunc
+      let res     = flat_res  flatfunc
+      args' <- Traversable.traverse (Traversable.traverse (mkMap sigs)) args
+      res' <- Traversable.traverse (mkMap sigs) res
+      let ent_decl' = createEntityAST hsfunc args' res'
+      let AST.EntityDec entity_id _ = ent_decl' 
+      let signature = Entity entity_id args' res'
+      modA vsSignatures (Map.insert hsfunc signature)
+      return ent_decl'

   where
     mkMap :: 
       [(SignalId, SignalInfo)] 
       -> SignalId 
   where
     mkMap :: 
       [(SignalId, SignalInfo)] 
       -> SignalId 

-      -> ([AST.TypeDec], Maybe (AST.VHDLId, AST.TypeMark))
-    mkMap sigmap id =
-      if isPortSigUse $ sigUse info
-        then
-          let (decs, type_mark) = vhdl_ty ty in
-          (decs, Just (mkVHDLId nm, type_mark))
-        else
-          (Monoid.mempty, Nothing)
-      where
+      -> VHDLState VHDLSignalMapElement
+    -- We only need the vsTypes element from the state
+    mkMap sigmap = MonadState.lift vsTypes . (\id ->
+      let

         info = Maybe.fromMaybe
           (error $ "Signal not found in the name map? This should not happen!")
           (lookup id sigmap)
         info = Maybe.fromMaybe
           (error $ "Signal not found in the name map? This should not happen!")
           (lookup id sigmap)


@@ -104,6 +115,14 @@ createEntity hsfunc flatfunc =
           (error $ "Signal not named? This should not happen!")
           (sigName info)
         ty = sigTy info
           (error $ "Signal not named? This should not happen!")
           (sigName info)
         ty = sigTy info

+      in
+        if isPortSigUse $ sigUse info
+          then do
+            type_mark <- vhdl_ty ty
+            return $ Just (mkVHDLExtId nm, type_mark)
+          else
+            return $ Nothing
+       )

 
   -- | Create the VHDL AST for an entity
 createEntityAST ::
 
   -- | Create the VHDL AST for an entity
 createEntityAST ::


@@ -125,7 +144,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
         []
 


@@ -141,7 +160,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 ::


@@ -155,20 +176,21 @@ createArchitecture hsfunc flatfunc = do
         (error $ "Generating architecture for function " ++ (prettyShow hsfunc) ++ "without signature? This should not happen!")
         (Map.lookup hsfunc signaturemap)
   let entity_id = ent_id signature
         (error $ "Generating architecture for function " ++ (prettyShow hsfunc) ++ "without signature? This should not happen!")
         (Map.lookup hsfunc signaturemap)
   let entity_id = ent_id signature

-    -- Create concurrent statements for all signal definitions
+  -- Create signal declarations for all internal and state signals
+  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..]
   let statements = zipWith (mkConcSm signaturemap sigs) defs [0..]

-  return $ AST.ArchBody (mkVHDLId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
+  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
     res  = flat_res  flatfunc
     defs = flat_defs flatfunc
   where
     sigs = flat_sigs flatfunc
     args = flat_args flatfunc
     res  = flat_res  flatfunc
     defs = flat_defs flatfunc

-    -- Create signal declarations for all internal and state signals
-    (ty_decls, sig_decs)  = Arrow.second Maybe.catMaybes $ Traversable.traverse (mkSigDec . snd) sigs
-    -- TODO: Unique ty_decls
-    -- TODO: Store ty_decls somewhere

     procs = map mkStateProcSm (makeStatePairs flatfunc)
     procs' = map AST.CSPSm procs
     procs = map mkStateProcSm (makeStatePairs flatfunc)
     procs' = map AST.CSPSm procs

+    -- mkSigDec only uses vsTypes from the state
+    mkSigDec' = MonadState.lift vsTypes . mkSigDec

 
 -- | Looks up all pairs of old state, new state signals, together with
 --   the state id they represent.
 
 -- | Looks up all pairs of old state, new state signals, together with
 --   the state id they represent.


@@ -189,22 +211,22 @@ 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)]
     statement   = AST.IfSm rising_edge_clk [assign] [] Nothing
 
     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)]
     statement   = AST.IfSm rising_edge_clk [assign] [] Nothing
 

-mkSigDec :: SignalInfo -> ([AST.TypeDec], Maybe AST.SigDec)
+mkSigDec :: SignalInfo -> TypeState (Maybe AST.SigDec)

 mkSigDec info =
   let use = sigUse info in
 mkSigDec info =
   let use = sigUse info in

-  if isInternalSigUse use || isStateSigUse use then
-    let (ty_decls, type_mark) = vhdl_ty ty in
-    (ty_decls, Just $ AST.SigDec (getSignalId info) type_mark Nothing)
+  if isInternalSigUse use || isStateSigUse use then do
+    type_mark <- vhdl_ty ty
+    return $ Just (AST.SigDec (getSignalId info) type_mark Nothing)

   else
   else

-    ([], Nothing)
+    return Nothing

   where
     ty = sigTy info
 
   where
     ty = sigTy info
 


@@ -212,7 +234,7 @@ 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)
 
       (error $ "Unnamed signal? This should not happen!")
       (sigName info)
 


@@ -233,10 +255,10 @@ mkConcSm signatures sigs (FApp hsfunc args res) num =
     entity_id = ent_id signature
     label = (AST.fromVHDLId entity_id) ++ "_" ++ (show num)
     -- Add a clk port if we have state
     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"
+    clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") "clk"

     portmaps = mkAssocElems sigs args res signature ++ (if hasState hsfunc then [clk_port] else [])
   in
     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)
+    AST.CSISm $ AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)

 
 mkConcSm _ sigs (UncondDef src dst) _ =
   let
 
 mkConcSm _ sigs (UncondDef src dst) _ =
   let


@@ -312,7 +334,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


@@ -328,49 +350,113 @@ std_logic_ty :: AST.TypeMark
 std_logic_ty = AST.unsafeVHDLBasicId "std_logic"
 
 -- Translate a Haskell type to a VHDL type
 std_logic_ty = AST.unsafeVHDLBasicId "std_logic"
 
 -- Translate a Haskell type to a VHDL type

-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, 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)
-    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)
-              "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
-
--- Shortcut
-mkVHDLId :: String -> AST.VHDLId
-mkVHDLId s = 
-  AST.unsafeVHDLBasicId $ (strip_multiscore . strip_invalid) s
+vhdl_ty :: Type.Type -> TypeState AST.TypeMark
+vhdl_ty ty = do
+  typemap <- State.get
+  let builtin_ty = do -- See if this is a tycon and lookup its name
+        (tycon, args) <- Type.splitTyConApp_maybe ty
+        let name = Name.getOccString (TyCon.tyConName tycon)
+        Map.lookup name builtin_types
+  -- If not a builtin type, try the custom types
+  let existing_ty = (fmap fst) $ Map.lookup (OrdType ty) typemap
+  case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of
+    -- Found a type, return it
+    Just t -> return t
+    -- No type yet, try to construct it
+    Nothing -> do
+      let new_ty = do
+            -- Use the Maybe Monad for failing when one of these fails
+            (tycon, args) <- Type.splitTyConApp_maybe ty
+            let name = Name.getOccString (TyCon.tyConName tycon)
+            case name of
+              "FSVec" -> Just $ mk_fsvec_ty ty args
+              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
+  -> TypeState AST.TypeMark -- The typemark created.
+
+mk_fsvec_ty ty args = do
+  -- Assume there are two type arguments
+  let [len, el_ty] = args 
+  let len_int = eval_type_level_int len
+  let ty_id = mkVHDLExtId $ "vector_" ++ (show len_int)
+  -- TODO: Use el_ty
+  let range = AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len_int - 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
+  State.modify (Map.insert (OrdType ty) (ty_id, ty_dec))
+  return ty_id
+
+
+builtin_types = 
+  Map.fromList [
+    ("Bit", std_logic_ty),
+    ("Bool", bool_ty) -- TysWiredIn.boolTy
+  ]
+
+-- 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 
           ('_':_) -> "_"
           _ -> cs
       ) . List.group
     -- Strip multiple adjacent underscores
     strip_multiscore = concat . map (\cs -> 
         case cs of 
           ('_':_) -> "_"
           _ -> 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
+data BuiltIn = BuiltIn String [PortMap] PortMap
+
+-- | Translate a list of concise representation of builtin functions to a
+--   SignatureMap
+mkBuiltins :: [BuiltIn] -> SignatureMap
+mkBuiltins = Map.fromList . map (\(BuiltIn name args res) ->
+    (HsFunction name (map useAsPort args) (useAsPort res),
+     Entity (VHDL.mkVHDLExtId name) (map toVHDLSignalMap args) (toVHDLSignalMap res))
+  )
+
+builtin_hsfuncs = Map.keys builtin_funcs
+builtin_funcs = mkBuiltins
+  [ 
+    BuiltIn "hwxor" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)),
+    BuiltIn "hwand" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)),
+    BuiltIn "hwor" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)),
+    BuiltIn "hwnot" [(Single ("a", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty))
+  ]
+
+-- | 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 (mkVHDLExtId name, ty))