Rename cλash dir to clash so it behaves well within the ghc build tree

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

diff --git a/clash/CLasH/VHDL.hs b/clash/CLasH/VHDL.hs
new file mode 100644 (file)
index 0000000..56342fc
--- /dev/null
+++ b/clash/CLasH/VHDL.hs
@@ -0,0 +1,99 @@
+--
+-- Functions to generate VHDL from FlatFunctions
+--
+module CLasH.VHDL where
+
+-- Standard modules
+import qualified Data.Map as Map
+import qualified Maybe
+import qualified Control.Arrow as Arrow
+import Data.Accessor
+import qualified Data.Accessor.Monad.Trans.State as MonadState
+
+-- VHDL Imports
+import qualified Language.VHDL.AST as AST
+
+-- GHC API
+import qualified CoreSyn
+
+-- Local imports
+import CLasH.Translator.TranslatorTypes
+import CLasH.VHDL.VHDLTypes
+import CLasH.VHDL.VHDLTools
+import CLasH.VHDL.Constants
+import CLasH.VHDL.Generate
+
+createDesignFiles ::
+  [CoreSyn.CoreBndr] -- ^ Top binders
+  -> TranslatorSession [(AST.VHDLId, AST.DesignFile)]
+
+createDesignFiles topbndrs = do
+  bndrss <- mapM recurseArchitectures topbndrs
+  let bndrs = concat bndrss
+  lunits <- mapM createLibraryUnit bndrs
+  typepackage <- createTypesPackage
+  let files = map (Arrow.second $ AST.DesignFile full_context) lunits
+  return $ typepackage : files
+  where
+    full_context =
+      mkUseAll ["work", "types"]
+      : (mkUseAll ["work"]
+      : ieee_context)
+
+ieee_context = [
+    AST.Library $ mkVHDLBasicId "IEEE",
+    mkUseAll ["IEEE", "std_logic_1164"],
+    mkUseAll ["IEEE", "numeric_std"],
+    mkUseAll ["std", "textio"]
+  ]
+
+-- | Find out which entities are needed for the given top level binders.
+recurseArchitectures ::
+  CoreSyn.CoreBndr -- ^ The top level binder
+  -> TranslatorSession [CoreSyn.CoreBndr] 
+  -- ^ The binders of all needed functions.
+recurseArchitectures bndr = do
+  -- See what this binder directly uses
+  (_, used) <- getArchitecture bndr
+  -- Recursively check what each of the used functions uses
+  useds <- mapM recurseArchitectures used
+  -- And return all of them
+  return $ bndr : (concat useds)
+
+-- | Creates the types package, based on the current type state.
+createTypesPackage ::
+  TranslatorSession (AST.VHDLId, AST.DesignFile) 
+  -- ^ The id and content of the types package
+ 
+createTypesPackage = do
+  tyfuns <- MonadState.get (tsType .> tsTypeFuns)
+  let tyfun_decls = mkBuiltInShow ++ map snd (Map.elems tyfuns)
+  ty_decls_maybes <- MonadState.get (tsType .> tsTypeDecls)
+  let ty_decls = Maybe.catMaybes ty_decls_maybes
+  let subProgSpecs = map (\(AST.SubProgBody spec _ _) -> AST.PDISS spec) tyfun_decls
+  let type_package_dec = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") ([tfvec_index_decl] ++ ty_decls ++ subProgSpecs)
+  let type_package_body = AST.LUPackageBody $ AST.PackageBody typesId tyfun_decls
+  return (mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package_dec, type_package_body])
+  where
+    tfvec_index_decl = AST.PDISD $ AST.SubtypeDec tfvec_indexTM tfvec_index_def
+    tfvec_range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit "-1") (AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerTM) (AST.NSimple highId) Nothing)
+    tfvec_index_def = AST.SubtypeIn integerTM (Just tfvec_range)
+
+-- 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)
+      
+createLibraryUnit ::
+  CoreSyn.CoreBndr
+  -> TranslatorSession (AST.VHDLId, [AST.LibraryUnit])
+
+createLibraryUnit bndr = do
+  entity <- getEntity bndr
+  (arch, _) <- getArchitecture bndr
+  return (ent_id entity, [AST.LUEntity (ent_dec entity), AST.LUArch arch])