Remove createArchitecture from the VHDLState Monad.

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

diff --git a/VHDL.hs b/VHDL.hs
index f5ab7cd25cd23046d6e95887036c6f50d3e51331..f176b9eea6be2c9457280f7e720a678d4fe3f420 100644 (file)
--- a/VHDL.hs
+++ b/VHDL.hs
@@ -4,6 +4,8 @@
 module VHDL where
 
 import qualified Data.Foldable as Foldable
 module VHDL where
 
 import qualified Data.Foldable as Foldable

+import qualified Data.List as List
+import qualified Data.Map as Map

 import qualified Maybe
 import qualified Control.Monad as Monad
 import qualified Control.Arrow as Arrow
 import qualified Maybe
 import qualified Control.Monad as Monad
 import qualified Control.Arrow as Arrow


@@ -24,28 +26,26 @@ import FlattenTypes
 import TranslatorTypes
 import Pretty
 
 import TranslatorTypes
 import Pretty
 

-getDesignFiles :: VHDLState [AST.DesignFile]
-getDesignFiles = do
-  -- Extract the library units generated from all the functions in the
-  -- session.
-  funcs <- getFuncs
-  let units = Maybe.mapMaybe getLibraryUnits funcs
-  let context = [
-        AST.Library $ mkVHDLId "IEEE",
-        AST.Use $ (AST.NSimple $ mkVHDLId "IEEE.std_logic_1164") AST.:.: AST.All]
-  return $ map (AST.DesignFile context) units
+getDesignFiles :: [FuncData] -> [AST.DesignFile]
+getDesignFiles funcs =
+  map (AST.DesignFile context) units
+  where
+    units = filter (not.null) $ map getLibraryUnits funcs
+    context = [
+      AST.Library $ mkVHDLId "IEEE",
+      AST.Use $ (AST.NSimple $ mkVHDLId "IEEE.std_logic_1164") AST.:.: AST.All]

   
 -- | Create an entity for a given function
 createEntity ::
   HsFunction        -- | The function signature
   -> FuncData       -- | The function data collected so far
   
 -- | Create an entity for a given function
 createEntity ::
   HsFunction        -- | The function signature
   -> FuncData       -- | The function data collected so far

-  -> VHDLState ()
+  -> Maybe Entity   -- | The resulting entity. Should return the existing
+                    ---  Entity for builtin functions.

 
 createEntity hsfunc fdata = 
 
 createEntity hsfunc fdata = 

-  let func = flatFunc fdata in
-  case func of
+  case flatFunc fdata of

     -- Skip (builtin) functions without a FlatFunction
     -- Skip (builtin) functions without a FlatFunction

-    Nothing -> do return ()
+    Nothing -> funcEntity fdata

     -- Create an entity for all other functions
     Just flatfunc ->
       let 
     -- Create an entity for all other functions
     Just flatfunc ->
       let 


@@ -61,9 +61,8 @@ createEntity hsfunc fdata =
           then Nothing
           else Just $ AST.PackageDec pkg_id (map AST.PDITD $ ty_decls ++ ty_decls')
         AST.EntityDec entity_id _ = ent_decl' 
           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') pkg_decl
-      in do
-        setEntity hsfunc entity'
+      in 
+        Just $ Entity entity_id args' res' (Just ent_decl') pkg_decl

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


@@ -125,35 +124,36 @@ mkEntityId hsfunc =
 
 -- | Create an architecture for a given function
 createArchitecture ::
 
 -- | Create an architecture for a given function
 createArchitecture ::

-  HsFunction        -- | The function signature
-  -> FuncData       -- | The function data collected so far
-  -> VHDLState ()
+  FuncMap           -- ^ The functions in the current session
+  -> HsFunction     -- ^ The function signature
+  -> FuncData       -- ^ The function data collected so far
+  -> Maybe AST.ArchBody -- ^ The architecture for this function

 
 

-createArchitecture hsfunc fdata = 
-  let func = flatFunc fdata in
-  case func of
+createArchitecture funcs hsfunc fdata = 
+  case flatFunc fdata of

     -- Skip (builtin) functions without a FlatFunction
     -- Skip (builtin) functions without a FlatFunction

-    Nothing -> do return ()
+    Nothing -> funcArch fdata

     -- Create an architecture for all other functions
     -- Create an architecture for all other functions

-    Just flatfunc -> do
-      let sigs = flat_sigs flatfunc
-      let args = flat_args flatfunc
-      let res  = flat_res  flatfunc
-      let defs = flat_defs flatfunc
-      let entity_id = Maybe.fromMaybe
+    Just flatfunc ->
+      let
+        sigs = flat_sigs flatfunc
+        args = flat_args flatfunc
+        res  = flat_res  flatfunc
+        defs = flat_defs flatfunc
+        entity_id = Maybe.fromMaybe

                       (error $ "Building architecture without an entity? This should not happen!")
                       (getEntityId fdata)
                       (error $ "Building architecture without an entity? This should not happen!")
                       (getEntityId fdata)

-      -- Create signal declarations for all signals that are not in args and
-      -- res
-      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)
-      let procs' = map AST.CSPSm procs
-      let arch = AST.ArchBody (mkVHDLId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
-      setArchitecture hsfunc arch
+        -- Create signal declarations for all signals that are not in args and
+        -- res
+        (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 = zipWith (mkConcSm funcs sigs) defs [0..]
+        procs = map mkStateProcSm (makeStatePairs flatfunc)
+        procs' = map AST.CSPSm procs
+      in
+        Just $ AST.ArchBody (mkVHDLId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')

 
 -- | 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.


@@ -203,31 +203,38 @@ getSignalId info =
 
 -- | Transforms a signal definition into a VHDL concurrent statement
 mkConcSm ::
 
 -- | Transforms a signal definition into a VHDL concurrent statement
 mkConcSm ::

-  [(SignalId, SignalInfo)] -- | The signals in the current architecture
-  -> SigDef                -- | The signal definition
-  -> VHDLState AST.ConcSm    -- | The corresponding VHDL component instantiation.
-
-mkConcSm sigs (FApp hsfunc args res) = do
-  fdata_maybe <- getFunc hsfunc
-  let fdata = Maybe.fromMaybe
+  FuncMap                  -- ^ The functions in the current session
+  -> [(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.
+  -> AST.ConcSm            -- ^ The corresponding VHDL component instantiation.
+
+mkConcSm funcs sigs (FApp hsfunc args res) num =
+  let 
+    fdata_maybe = Map.lookup hsfunc funcs
+    fdata = Maybe.fromMaybe

         (error $ "Using function '" ++ (prettyShow hsfunc) ++ "' that is not in the session? This should not happen!")
         fdata_maybe
         (error $ "Using function '" ++ (prettyShow hsfunc) ++ "' that is not in the session? This should not happen!")
         fdata_maybe

-  let entity = Maybe.fromMaybe
+    entity = Maybe.fromMaybe

         (error $ "Using function '" ++ (prettyShow hsfunc) ++ "' without entity declaration? This should not happen!")
         (funcEntity fdata)
         (error $ "Using function '" ++ (prettyShow hsfunc) ++ "' without entity declaration? This should not happen!")
         (funcEntity fdata)

-  let entity_id = ent_id entity
-  label <- uniqueName (AST.fromVHDLId entity_id)
-  -- Add a clk port if we have state
-  let clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLId "clk") "clk"
-  let portmaps = mkAssocElems sigs args res entity ++ (if hasState hsfunc then [clk_port] else [])
-  return $ AST.CSISm $ AST.CompInsSm (mkVHDLId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)
-
-mkConcSm sigs (UncondDef src dst) = do
-  let 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
+    entity_id = ent_id entity
+    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 entity ++ (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

   where
     vhdl_expr (Left id) = mkIdExpr sigs id
     vhdl_expr (Right expr) =
   where
     vhdl_expr (Left id) = mkIdExpr sigs id
     vhdl_expr (Right expr) =


@@ -239,16 +246,18 @@ mkConcSm sigs (UncondDef src dst) = do
         (Eq a b) ->
           (mkIdExpr sigs a) AST.:=: (mkIdExpr sigs b)
 
         (Eq a b) ->
           (mkIdExpr sigs a) AST.:=: (mkIdExpr sigs b)
 

-mkConcSm sigs (CondDef cond true false dst) = do
-  let cond_expr  = mkIdExpr sigs cond
-  let true_expr  = mkIdExpr sigs true
-  let false_expr  = mkIdExpr sigs false
-  let false_wform = AST.Wform [AST.WformElem false_expr Nothing]
-  let true_wform = AST.Wform [AST.WformElem true_expr Nothing]
-  let whenelse = AST.WhenElse true_wform cond_expr
-  let dst_name  = AST.NSimple (getSignalId $ signalInfo sigs dst)
-  let assign    = dst_name AST.:<==: (AST.ConWforms [whenelse] false_wform Nothing)
-  return $ AST.CSSASm assign
+mkConcSm _ sigs (CondDef cond true false dst) _ =
+  let
+    cond_expr  = mkIdExpr sigs cond
+    true_expr  = mkIdExpr sigs true
+    false_expr  = mkIdExpr sigs false
+    false_wform = AST.Wform [AST.WformElem false_expr Nothing]
+    true_wform = AST.Wform [AST.WformElem true_expr Nothing]
+    whenelse = AST.WhenElse true_wform cond_expr
+    dst_name  = AST.NSimple (getSignalId $ signalInfo sigs dst)
+    assign    = dst_name AST.:<==: (AST.ConWforms [whenelse] false_wform Nothing)
+  in
+    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


@@ -305,20 +314,19 @@ getEntityId fdata =
       Just (AST.EntityDec id _) -> Just id
 
 getLibraryUnits ::
       Just (AST.EntityDec id _) -> Just id
 
 getLibraryUnits ::

-  (HsFunction, FuncData)      -- | A function from the session
-  -> Maybe [AST.LibraryUnit]  -- | The entity, architecture and optional package for the function
+  FuncData                    -- | A function from the session
+  -> [AST.LibraryUnit]  -- | The entity, architecture and optional package for the function

 
 

-getLibraryUnits (hsfunc, fdata) =
+getLibraryUnits fdata =

   case funcEntity fdata of 
   case funcEntity fdata of 

-    Nothing -> Nothing
+    Nothing -> []

     Just ent -> 
       case ent_decl ent of
     Just ent -> 
       case ent_decl ent of

-      Nothing -> Nothing
+      Nothing -> []

       Just decl ->
         case funcArch fdata of
       Just decl ->
         case funcArch fdata of

-          Nothing -> Nothing
+          Nothing -> []

           Just arch ->
           Just arch ->

-            Just $

               [AST.LUEntity decl, AST.LUArch arch]
               ++ (Maybe.maybeToList (fmap AST.LUPackageDec $ ent_pkg_decl ent))
 
               [AST.LUEntity decl, AST.LUArch arch]
               ++ (Maybe.maybeToList (fmap AST.LUPackageDec $ ent_pkg_decl ent))
 


@@ -371,7 +379,13 @@ vhdl_ty_maybe ty =
 -- Shortcut
 mkVHDLId :: String -> AST.VHDLId
 mkVHDLId s = 
 -- Shortcut
 mkVHDLId :: String -> AST.VHDLId
 mkVHDLId s = 

-  AST.unsafeVHDLBasicId s'
+  AST.unsafeVHDLBasicId $ (strip_multiscore . strip_invalid) s

   where
     -- Strip invalid characters.
   where
     -- Strip invalid characters.

-    s' = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.") s
+    strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
+    -- Strip multiple adjacent underscores
+    strip_multiscore = concat . map (\cs -> 
+        case cs of 
+          ('_':_) -> "_"
+          _ -> cs
+      ) . List.group