X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=Translator.hs;h=d11d29e4d09559c97528c8a8e8c09f3520da4589;hb=56b4b2edb9bd1d06cafefc12a06feb7ef5622291;hp=3cf456e0ea6118145796430b19d0487c24f630d9;hpb=77ce22fc9dc9cab9afe56b5a093590359e38e5cb;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

diff --git a/Translator.hs b/Translator.hs
index 3cf456e..d11d29e 100644
--- a/Translator.hs
+++ b/Translator.hs
@@ -1,5 +1,5 @@
 module Translator where
-import GHC hiding (loadModule)
+import GHC hiding (loadModule, sigName)
 import CoreSyn
 import qualified CoreUtils
 import qualified Var
@@ -42,23 +42,38 @@ import VHDLTypes
 import qualified VHDL
 
 main = do
+  makeVHDL "Alu.hs" "register_bank"
+
+makeVHDL :: String -> String -> IO ()
+makeVHDL filename name = do
   -- Load the module
-  core <- loadModule "Adders.hs"
+  core <- loadModule filename
   -- Translate to VHDL
-  vhdl <- moduleToVHDL core ["sfull_adder"]
+  vhdl <- moduleToVHDL core [name]
   -- Write VHDL to file
-  writeVHDL vhdl "../vhdl/vhdl/output.vhdl"
+  mapM (writeVHDL "../vhdl/vhdl/") vhdl
+  return ()
+
+-- | Show the core structure of the given binds in the given file.
+listBind :: String -> String -> IO ()
+listBind filename name = do
+  core <- loadModule filename
+  let binds = findBinds core [name]
+  putStr "\n"
+  putStr $ prettyShow binds
+  putStr $ showSDoc $ ppr binds
+  putStr "\n\n"
 
 -- | Translate the binds with the given names from the given core module to
 --   VHDL
-moduleToVHDL :: HscTypes.CoreModule -> [String] -> IO AST.DesignFile
+moduleToVHDL :: HscTypes.CoreModule -> [String] -> IO [AST.DesignFile]
 moduleToVHDL core names = do
   --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) (VHDLSession core 0 Map.empty)
-  putStr $ render $ ForSyDe.Backend.Ppr.ppr vhdl
+  mapM (putStr . render . ForSyDe.Backend.Ppr.ppr) vhdl
   putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n"
   return vhdl
 
@@ -72,11 +87,17 @@ moduleToVHDL core names = do
       modFuncs nameFlatFunction
       modFuncs VHDL.createEntity
       modFuncs VHDL.createArchitecture
-      VHDL.getDesignFile
+      VHDL.getDesignFiles
 
--- | Write the given design file to the given file
-writeVHDL :: AST.DesignFile -> String -> IO ()
-writeVHDL = ForSyDe.Backend.VHDL.FileIO.writeDesignFile
+-- | 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
+  let AST.DesignFile _ (u:us) = vhdl
+  let AST.LUEntity (AST.EntityDec id _) = u
+  let fname = dir ++ AST.fromVHDLId id ++ ".vhdl"
+  ForSyDe.Backend.VHDL.FileIO.writeDesignFile vhdl fname
 
 -- | Loads the given file and turns it into a core module.
 loadModule :: String -> IO HscTypes.CoreModule
@@ -207,9 +228,16 @@ nameFlatFunction hsfunc fdata =
     -- Name the signals in all other functions
     Just flatfunc ->
       let s = flat_sigs flatfunc in
-      let s' = map (\(id, (SignalInfo Nothing use ty)) -> (id, SignalInfo (Just $ "sig_" ++ (show id)) use ty)) s in
+      let s' = map nameSignal s in
       let flatfunc' = flatfunc { flat_sigs = s' } in
       setFlatFunc hsfunc flatfunc'
+  where
+    nameSignal :: (SignalId, SignalInfo) -> (SignalId, SignalInfo)
+    nameSignal (id, info) =
+      let hints = nameHints info in
+      let parts = ("sig" : hints) ++ [show id] in
+      let name = concat $ List.intersperse "_" parts in
+      (id, info {sigName = Just name})
 
 -- | Splits a tuple type into a list of element types, or Nothing if the type
 --   is not a tuple type.