Redo the global (state) structure of the translator.
authorMatthijs Kooijman <m.kooijman@student.utwente.nl>
Tue, 10 Mar 2009 14:42:38 +0000 (15:42 +0100)
committerMatthijs Kooijman <m.kooijman@student.utwente.nl>
Tue, 10 Mar 2009 14:57:01 +0000 (15:57 +0100)
This gives the VHDL module its own state and moves the Entity for each
function into that state. The AST.EntityDec and AST.ArchBody are no longer
stored in the state, but simply returned directly.

The State class used is changed from the one from the mtl library to the
one from the transformers library, since that one integrates nicely with
the data-accessors library. This integration (together with the
simplification of the states) pretty much removes the need for all
manually defined accessor function.

This change breaks support for builtin functions (hwxor, hwnot, etc.),
which will be fixed in a subsequent commit. Also, custom types are not
longer output right now, but there is infrastructure in place to do better
type collection.

Flatten.hs
FlattenTypes.hs
Pretty.hs
Translator.hs
TranslatorTypes.hs
VHDL.hs
VHDLTypes.hs

index 4bb6e71b268fd140c7f60df47754f12c9dffa6c8..8adce9fb0522f39780cc80aa8ac30e50b0a72e09 100644 (file)
@@ -15,7 +15,7 @@ import qualified Data.Traversable as Traversable
 import qualified Data.Foldable as Foldable
 import Control.Applicative
 import Outputable ( showSDoc, ppr )
-import qualified Control.Monad.State as State
+import qualified Control.Monad.Trans.State as State
 
 import HsValueMap
 import TranslatorTypes
@@ -222,7 +222,7 @@ flattenExpr binds app@(App _ _) = do
 
     flattenBuildTupleExpr binds args = do
       -- Flatten each of our args
-      flat_args <- (State.mapM (flattenExpr binds) args)
+      flat_args <- (mapM (flattenExpr binds) args)
       -- Check and split each of the arguments
       let (_, arg_ress) = unzip (zipWith checkArg args flat_args)
       let res = Tuple arg_ress
@@ -233,7 +233,7 @@ flattenExpr binds app@(App _ _) = do
       -- Find the function to call
       let func = appToHsFunction ty f args
       -- Flatten each of our args
-      flat_args <- (State.mapM (flattenExpr binds) args)
+      flat_args <- (mapM (flattenExpr binds) args)
       -- Check and split each of the arguments
       let (_, arg_ress) = unzip (zipWith checkArg args flat_args)
       -- Generate signals for our result
index 785704db15f4cca6deec39137d23e14ed8012bb9..f20fbc30f11f0c9bc8ac0379fa63d3b0d7af3c78 100644 (file)
@@ -3,7 +3,7 @@ module FlattenTypes where
 import qualified Maybe
 import Data.Traversable
 import qualified Data.Foldable as Foldable
-import qualified Control.Monad.State as State
+import qualified Control.Monad.Trans.State as State
 
 import CoreSyn
 import qualified Type
index edfe05b41be06c8c74519af88a8752b00f746dc9..43e0e49bf7aa6c2dc3ce6822bf47306d57136175 100644 (file)
--- a/Pretty.hs
+++ b/Pretty.hs
@@ -97,15 +97,15 @@ instance Pretty SigUse where
   pPrint SigSubState = text "s"
 
 instance Pretty TranslatorSession where
-  pPrint (VHDLSession mod nameCount funcs) =
+  pPrint (TranslatorSession mod nameCount flatfuncs) =
     text "Module: " $$ nest 15 (text modname)
     $+$ text "NameCount: " $$ nest 15 (int nameCount)
-    $+$ text "Functions: " $$ nest 15 (vcat (map ppfunc (Map.toList funcs)))
+    $+$ text "Functions: " $$ nest 15 (vcat (map ppfunc (Map.toList flatfuncs)))
     where
-      ppfunc (hsfunc, fdata) =
-        pPrint hsfunc $+$ nest 5 (pPrint fdata)
+      ppfunc (hsfunc, flatfunc) =
+        pPrint hsfunc $+$ nest 5 (pPrint flatfunc)
       modname = showSDoc $ Module.pprModule (HscTypes.cm_module mod)
-
+{-
 instance Pretty FuncData where
   pPrint (FuncData flatfunc entity arch) =
     text "Flattened: " $$ nest 15 (ppffunc flatfunc)
@@ -118,19 +118,13 @@ instance Pretty FuncData where
       ppent Nothing    = text "Nothing"
       pparch Nothing = text "VHDL architecture not present"
       pparch (Just _) = text "VHDL architecture present"
+-}
 
 instance Pretty Entity where
-  pPrint (Entity id args res decl pkg) =
+  pPrint (Entity id args res) =
     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) =
index aa8d0d9946c2eb11263d509544eea1ba2efe9dd5..1ecbdb9223b3c4267649f4705e1ffa000b358de0 100644 (file)
@@ -10,8 +10,8 @@ import qualified TyCon
 import qualified DataCon
 import qualified Maybe
 import qualified Module
-import qualified Control.Monad.State as State
 import qualified Data.Foldable as Foldable
+import qualified Control.Monad.Trans.State as State
 import Name
 import qualified Data.Map as Map
 import Data.Accessor
@@ -73,44 +73,38 @@ listBind filename name = do
 -- | Translate the binds with the given names from the given core module to
 --   VHDL. The Bool in the tuple makes the function stateful (True) or
 --   stateless (False).
-moduleToVHDL :: HscTypes.CoreModule -> [(String, Bool)] -> IO [AST.DesignFile]
+moduleToVHDL :: HscTypes.CoreModule -> [(String, Bool)] -> IO [(AST.VHDLId, AST.DesignFile)]
 moduleToVHDL core list = do
   let (names, statefuls) = unzip list
   --liftIO $ putStr $ prettyShow (cm_binds core)
   let binds = findBinds core names
   --putStr $ prettyShow binds
   -- Turn bind into VHDL
-  let (vhdl, sess) = State.runState (mkVHDL binds statefuls) (VHDLSession core 0 Map.empty)
-  mapM (putStr . render . ForSyDe.Backend.Ppr.ppr) vhdl
+  let (vhdl, sess) = State.runState (mkVHDL binds statefuls) (TranslatorSession core 0 Map.empty)
+  mapM (putStr . render . ForSyDe.Backend.Ppr.ppr . snd) vhdl
   putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n"
   return vhdl
-
   where
     -- Turns the given bind into VHDL
+    mkVHDL :: [CoreBind] -> [Bool] -> TranslatorState [(AST.VHDLId, AST.DesignFile)]
     mkVHDL binds statefuls = do
       -- Add the builtin functions
-      mapM addBuiltIn builtin_funcs
+      --mapM addBuiltIn builtin_funcs
       -- Create entities and architectures for them
       Monad.zipWithM processBind statefuls binds
-      modFuncMap $ Map.map (fdFlatFunc ^: (fmap nameFlatFunction))
-      modFuncMap $ Map.mapWithKey (\hsfunc fdata -> fdEntity ^= (VHDL.createEntity hsfunc fdata) $ fdata)
-      funcs <- getFuncMap
-      modFuncMap $ Map.mapWithKey (\hsfunc fdata -> fdArch ^= (VHDL.createArchitecture funcs hsfunc fdata) $ fdata)
-      funcs <- getFuncs
-      return $ VHDL.getDesignFiles (map snd funcs)
-
--- | Write the given design file to a file inside the given dir
---   The first library unit in the designfile must be an entity, whose name
---   will be used as a filename.
-writeVHDL :: String -> AST.DesignFile -> IO ()
-writeVHDL dir vhdl = do
+      modA tsFlatFuncs (Map.map nameFlatFunction)
+      flatfuncs <- getA tsFlatFuncs
+      return $ VHDL.createDesignFiles flatfuncs
+
+-- | Write the given design file to a file with the given name inside the
+--   given dir
+writeVHDL :: String -> (AST.VHDLId, AST.DesignFile) -> IO ()
+writeVHDL dir (name, vhdl) = do
   -- Create the dir if needed
   exists <- Directory.doesDirectoryExist dir
   Monad.unless exists $ Directory.createDirectory dir
   -- Find the filename
-  let AST.DesignFile _ (u:us) = vhdl
-  let AST.LUEntity (AST.EntityDec id _) = u
-  let fname = dir ++ AST.fromVHDLId id ++ ".vhdl"
+  let fname = dir ++ (AST.fromVHDLId name) ++ ".vhdl"
   -- Write the file
   ForSyDe.Backend.VHDL.FileIO.writeDesignFile vhdl fname
 
@@ -169,18 +163,15 @@ flattenBind ::
 flattenBind _ (Rec _) = error "Recursive binders not supported"
 
 flattenBind hsfunc bind@(NonRec var expr) = do
-  -- Add the function to the session
-  addFunc hsfunc
   -- Flatten the function
   let flatfunc = flattenFunction hsfunc bind
   -- Propagate state variables
   let flatfunc' = propagateState hsfunc flatfunc
   -- Store the flat function in the session
-  setFlatFunc hsfunc flatfunc'
+  modA tsFlatFuncs (Map.insert hsfunc flatfunc)
   -- Flatten any functions used
   let used_hsfuncs = Maybe.mapMaybe usedHsFunc (flat_defs flatfunc')
-  State.mapM resolvFunc used_hsfuncs
-  return ()
+  mapM_ resolvFunc used_hsfuncs
 
 -- | Decide which incoming state variables will become state in the
 --   given function, and which will be propagate to other applied
@@ -276,23 +267,18 @@ resolvFunc ::
   -> TranslatorState ()
 
 resolvFunc hsfunc = do
-  -- See if the function is already known
-  func <- getFunc hsfunc
-  case func of
-    -- Already known, do nothing
-    Just _ -> do
-      return ()
-    -- New function, resolve it
-    Nothing -> do
-      -- Get the current module
-      core <- getModule
-      -- Find the named function
-      let bind = findBind (cm_binds core) name
-      case bind of
-        Nothing -> error $ "Couldn't find function " ++ name ++ " in current module."
-        Just b  -> flattenBind hsfunc b
-  where
-    name = hsFuncName hsfunc
+  flatfuncmap <- getA tsFlatFuncs
+  -- Don't do anything if there is already a flat function for this hsfunc.
+  Monad.unless (Map.member hsfunc flatfuncmap) $ do
+  -- TODO: Builtin functions
+  -- New function, resolve it
+  core <- getA tsCoreModule
+  -- Find the named function
+  let name = (hsFuncName hsfunc)
+  let bind = findBind (cm_binds core) name 
+  case bind of
+    Nothing -> error $ "Couldn't find function " ++ name ++ " in current module."
+    Just b  -> flattenBind hsfunc b
 
 -- | Translate a top level function declaration to a HsFunction. i.e., which
 --   interface will be provided by this function. This function essentially
@@ -378,6 +364,7 @@ toVHDLSignalMap = fmap (\(name, ty) -> Just (VHDL.mkVHDLId name, ty))
 
 -- | Translate a concise representation of a builtin function to something
 --   that can be put into FuncMap directly.
+{-
 addBuiltIn :: BuiltIn -> TranslatorState ()
 addBuiltIn (BuiltIn name args res) = do
     addFunc hsfunc
@@ -393,5 +380,5 @@ builtin_funcs =
     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))
   ]
-
+-}
 -- vim: set ts=8 sw=2 sts=2 expandtab:
index fdd0e34fcd86f95e0f75afa0f8437a22d1ea8aea..37e86190a63f36b1b38acf1c75b193cda7fbdb44 100644 (file)
@@ -5,7 +5,7 @@
 {-# LANGUAGE TemplateHaskell #-}
 module TranslatorTypes where
 
-import qualified Control.Monad.State as State
+import qualified Control.Monad.Trans.State as State
 import qualified Data.Map as Map
 import qualified Data.Accessor.Template
 import Data.Accessor
@@ -21,105 +21,17 @@ import HsValueMap
 
 -- | A map from a HsFunction identifier to various stuff we collect about a
 --   function along the way.
-type FuncMap  = Map.Map HsFunction FuncData
+type FlatFuncMap  = Map.Map HsFunction FlatFunction
 
--- | Some stuff we collect about a function along the way.
-data FuncData = FuncData {
-  fdFlatFunc_ :: Maybe FlatFunction,
-  fdEntity_ :: Maybe Entity,
-  fdArch_ :: Maybe AST.ArchBody
-} deriving (Show)
+data TranslatorSession = TranslatorSession {
+  tsCoreModule_ :: HscTypes.CoreModule, -- ^ The current module
+  tsNameCount_ :: Int, -- ^ A counter that can be used to generate unique names
+  tsFlatFuncs_ :: FlatFuncMap -- ^ A map from HsFunction to FlatFunction
+}
 
 -- Derive accessors
-$( Data.Accessor.Template.deriveAccessors ''FuncData )
-
-data TranslatorSession = VHDLSession {
-  coreMod   :: HscTypes.CoreModule, -- The current module
-  nameCount :: Int,             -- A counter that can be used to generate unique names
-  funcs     :: FuncMap          -- A map from HsFunction to FlatFunction, HWFunction, VHDL Entity and Architecture
-}
+$( Data.Accessor.Template.deriveAccessors ''TranslatorSession )
 
 type TranslatorState = State.State TranslatorSession
 
--- | Add the function to the session
-addFunc :: HsFunction -> TranslatorState ()
-addFunc hsfunc =
-  modFuncMap (Map.insert hsfunc (FuncData Nothing Nothing Nothing))
-
--- | Find the given function in the current session
-getFunc :: HsFunction -> TranslatorState (Maybe FuncData)
-getFunc hsfunc = do
-  fs <- State.gets funcs -- Get the funcs element from the session
-  return $ Map.lookup hsfunc fs
-
--- | Gets all functions from the current session
-getFuncs :: TranslatorState [(HsFunction, FuncData)]
-getFuncs = do
-  fs <- State.gets funcs -- Get the funcs element from the session
-  return $ Map.toList fs
-
--- | Gets all the functions from the current session
-getHsFuncs :: TranslatorState [HsFunction]
-getHsFuncs = do
-  fs <- State.gets funcs -- Get the funcs element from the session
-  return $ Map.keys fs
-  
--- | Sets the FlatFunction for the given HsFunction in the current session.
-setFlatFunc :: HsFunction -> FlatFunction -> TranslatorState ()
-setFlatFunc hsfunc flatfunc =
-  modFunc (fdFlatFunc ^= Just flatfunc) hsfunc
-
--- | Sets the Entity for the given HsFunction in the current session.
-setEntity :: HsFunction -> Entity -> TranslatorState ()
-setEntity hsfunc entity =
-  modFunc (fdEntity ^= Just entity) hsfunc
-
--- | Sets the Entity for the given HsFunction in the current session.
-setArchitecture :: HsFunction -> AST.ArchBody -> TranslatorState ()
-setArchitecture hsfunc arch =
-  modFunc (fdArch ^= Just arch) hsfunc
-
--- | Modify a function in the map using the given function
-modFunc :: (FuncData -> FuncData) -> HsFunction -> TranslatorState ()
-modFunc f hsfunc =
-  modFuncMap (Map.adjust f hsfunc)
-
--- | Get the map of functions in the session
-getFuncMap :: TranslatorState FuncMap
-getFuncMap = State.gets funcs
-
--- | Modify the function map in the session using the given function
-modFuncMap :: (FuncMap -> FuncMap) -> TranslatorState ()
-modFuncMap f = do
-  fs <- State.gets funcs -- Get the funcs element from the session
-  let fs' = f fs
-  State.modify (\x -> x {funcs = fs' })
-
--- | Apply the given function to all functions in the map, and collect the
---   results. The function is allowed to change the function map in the
---   session, but any new functions added will not be mapped.
-modFuncs :: (HsFunction -> FuncData -> TranslatorState ()) -> TranslatorState ()
-modFuncs f = do
-  hsfuncs <- getHsFuncs
-  mapM doFunc hsfuncs
-  return ()
-  where
-    doFunc hsfunc = do
-      fdata_maybe <- getFunc hsfunc
-      case fdata_maybe of
-        Nothing -> do return ()
-        Just fdata -> f hsfunc fdata
-
-getModule :: TranslatorState HscTypes.CoreModule
-getModule = State.gets coreMod -- Get the coreMod element from the session
-
--- Makes the given name unique by appending a unique number.
--- This does not do any checking against existing names, so it only guarantees
--- uniqueness with other names generated by uniqueName.
-uniqueName :: String -> TranslatorState String
-uniqueName name = do
-  count <- State.gets nameCount -- Get the funcs element from the session
-  State.modify (\s -> s {nameCount = count + 1})
-  return $ name ++ "_" ++ (show count)
-
 -- vim: set ts=8 sw=2 sts=2 expandtab:
diff --git a/VHDL.hs b/VHDL.hs
index 418ac181fc95a4c6e0bb43f83410a463de7623b6..9a51c7a94ea4a63db3167fc79777cc39e7625078 100644 (file)
--- a/VHDL.hs
+++ b/VHDL.hs
@@ -9,6 +9,7 @@ import qualified Data.Map as Map
 import qualified Maybe
 import qualified Control.Monad as Monad
 import qualified Control.Arrow as Arrow
+import qualified Control.Monad.Trans.State as State
 import qualified Data.Traversable as Traversable
 import qualified Data.Monoid as Monoid
 import Data.Accessor
@@ -27,28 +28,44 @@ import FlattenTypes
 import TranslatorTypes
 import Pretty
 
-getDesignFiles :: [FuncData] -> [AST.DesignFile]
-getDesignFiles funcs =
-  map (AST.DesignFile context) units
+createDesignFiles ::
+  FlatFuncMap
+  -> [(AST.VHDLId, AST.DesignFile)]
+
+createDesignFiles flatfuncmap =
+  -- TODO: Output types
+  map (Arrow.second $ AST.DesignFile context) units
   where
-    units = filter (not.null) $ map getLibraryUnits funcs
+    init_session = VHDLSession Map.empty Map.empty
+    (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]
-  
+
+createLibraryUnits ::
+  FlatFuncMap
+  -> VHDLState [(AST.VHDLId, [AST.LibraryUnit])]
+
+createLibraryUnits flatfuncmap = do
+  let hsfuncs = Map.keys flatfuncmap
+  let flatfuncs = Map.elems flatfuncmap
+  entities <- Monad.zipWithM createEntity hsfuncs flatfuncs
+  archs <- Monad.zipWithM createArchitecture hsfuncs flatfuncs
+  return $ zipWith 
+    (\ent arch -> 
+      let AST.EntityDec id _ = ent in 
+      (id, [AST.LUEntity ent, AST.LUArch arch])
+    )
+    entities archs
+
 -- | Create an entity for a given function
 createEntity ::
-  HsFunction        -- | The function signature
-  -> FuncData       -- | The function data collected so far
-  -> Maybe Entity   -- | The resulting entity. Should return the existing
-                    ---  Entity for builtin functions.
-
-createEntity hsfunc fdata = 
-  case fdata ^. fdFlatFunc of
-    -- Skip (builtin) functions without a FlatFunction
-    Nothing -> fdata ^. fdEntity
-    -- Create an entity for all other functions
-    Just flatfunc ->
+  HsFunction -- | The function signature
+  -> FlatFunction -- | The FlatFunction
+  -> VHDLState AST.EntityDec -- | The resulting entity
+
+createEntity hsfunc flatfunc = 
       let 
         sigs    = flat_sigs flatfunc
         args    = flat_args flatfunc
@@ -61,9 +78,12 @@ createEntity hsfunc fdata =
         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' 
-      in 
-        Just $ Entity entity_id args' res' (Just ent_decl') pkg_decl
+        signature = Entity entity_id args' res'
+      in do
+        modA vsSignatures (Map.insert hsfunc signature)
+        return ent_decl'
   where
     mkMap :: 
       [(SignalId, SignalInfo)] 
@@ -125,36 +145,30 @@ mkEntityId hsfunc =
 
 -- | Create an architecture for a given function
 createArchitecture ::
-  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 funcs hsfunc fdata = 
-  case fdata ^. fdFlatFunc of
-    -- Skip (builtin) functions without a FlatFunction
-    Nothing -> fdata ^. fdArch
-    -- Create an architecture for all other functions
-    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)
-        -- 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')
+  HsFunction -- ^ The function signature
+  -> FlatFunction -- ^ The FlatFunction
+  -> VHDLState AST.ArchBody -- ^ The architecture for this function
+
+createArchitecture hsfunc flatfunc = do
+  signaturemap <- getA vsSignatures
+  let signature = Maybe.fromMaybe 
+        (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
+  let statements = zipWith (mkConcSm signaturemap sigs) defs [0..]
+  return $ AST.ArchBody (mkVHDLId "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
+    -- 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
 
 -- | Looks up all pairs of old state, new state signals, together with
 --   the state id they represent.
@@ -204,27 +218,23 @@ getSignalId info =
 
 -- | Transforms a signal definition into a VHDL concurrent statement
 mkConcSm ::
-  FuncMap                  -- ^ The functions in the current session
+  SignatureMap             -- ^ The interfaces of functions in the 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 =
+mkConcSm signatures 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
-    entity = Maybe.fromMaybe
-        (error $ "Using function '" ++ (prettyShow hsfunc) ++ "' without entity declaration? This should not happen!")
-        (fdata ^. fdEntity)
-    entity_id = ent_id entity
+    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 entity ++ (if hasState hsfunc then [clk_port] else [])
+    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)
 
@@ -305,32 +315,6 @@ mkAssocElem :: Maybe AST.VHDLId -> String -> Maybe AST.AssocElem
 mkAssocElem (Just port) signal = Just $ Just port AST.:=>: (AST.ADName (AST.NSimple (mkVHDLId signal))) 
 mkAssocElem Nothing _ = Nothing
 
--- | Extracts the generated entity id from the given funcdata
-getEntityId :: FuncData -> Maybe AST.VHDLId
-getEntityId fdata =
-  case fdata ^. fdEntity of
-    Nothing -> Nothing
-    Just e  -> case ent_decl e of
-      Nothing -> Nothing
-      Just (AST.EntityDec id _) -> Just id
-
-getLibraryUnits ::
-  FuncData                    -- | A function from the session
-  -> [AST.LibraryUnit]  -- | The entity, architecture and optional package for the function
-
-getLibraryUnits fdata =
-  case fdata ^. fdEntity of 
-    Nothing -> []
-    Just ent -> 
-      case ent_decl ent of
-      Nothing -> []
-      Just decl ->
-        case fdata ^. fdArch of
-          Nothing -> []
-          Just arch ->
-              [AST.LUEntity decl, AST.LUArch arch]
-              ++ (Maybe.maybeToList (fmap AST.LUPackageDec $ ent_pkg_decl ent))
-
 -- | The VHDL Bit type
 bit_ty :: AST.TypeMark
 bit_ty = AST.unsafeVHDLBasicId "Bit"
index 74084864dc8c3c9f8d8a1aa27a433e4a7cf8132a..948b3a1447b0320f01c2599b12b15875d8d4112d 100644 (file)
@@ -1,10 +1,22 @@
 --
 -- Some types used by the VHDL module.
 --
+{-# LANGUAGE TemplateHaskell #-}
 module VHDLTypes where
 
+-- Standard imports
+import qualified Control.Monad.Trans.State as State
+import qualified Data.Map as Map
+import Data.Accessor
+import qualified Data.Accessor.Template
+
+-- GHC API imports
+import qualified Type
+
+-- ForSyDe imports
 import qualified ForSyDe.Backend.VHDL.AST as AST
 
+-- Local imports
 import FlattenTypes
 import HsValueMap
 
@@ -18,7 +30,34 @@ type VHDLSignalMap = HsValueMap (Maybe (AST.VHDLId, AST.TypeMark))
 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_pkg_decl :: Maybe AST.PackageDec -- A package declaration with types for this entity
+  ent_res    :: VHDLSignalMap         -- A mapping of the function result to port names
 } deriving (Show);
+
+-- A orderable equivalent of CoreSyn's Type for use as a map key
+newtype OrdType = OrdType Type.Type
+instance Eq OrdType where
+  (OrdType a) == (OrdType b) = Type.tcEqType a b
+instance Ord OrdType where
+  compare (OrdType a) (OrdType b) = Type.tcCmpType a b
+
+-- A map of a Core type to the corresponding type name (and optionally, it's
+-- declaration for non-primitive types).
+type TypeMap = Map.Map OrdType (AST.VHDLId, AST.TypeDec)
+
+-- A map of a Haskell function to a hardware signature
+type SignatureMap = Map.Map HsFunction Entity
+
+data VHDLSession = VHDLSession {
+  -- | A map of Core type -> VHDL Type
+  vsTypes_ :: TypeMap,
+  -- | A map of HsFunction -> hardware signature (entity name, port names,
+  --   etc.)
+  vsSignatures_ :: SignatureMap
+}
+
+-- Derive accessors
+$( Data.Accessor.Template.deriveAccessors ''VHDLSession )
+
+type VHDLState = State.State VHDLSession
+
+-- vim: set ts=8 sw=2 sts=2 expandtab: