cλash/CLasH/VHDL.hs

   1 --
   2 -- Functions to generate VHDL from FlatFunctions
   3 --
   4 module CLasH.VHDL where
   5
   6 -- Standard modules
   7 import qualified Data.Map as Map
   8 import qualified Maybe
   9 import qualified Control.Monad as Monad
  10 import qualified Control.Arrow as Arrow
  11 import qualified Control.Monad.Trans.State as State
  12 import qualified Data.Monoid as Monoid
  13 import Data.Accessor
  14 import Data.Accessor.MonadState as MonadState
  15 import Debug.Trace
  16
  17 -- ForSyDe
  18 import qualified Language.VHDL.AST as AST
  19
  20 -- GHC API
  21 import CoreSyn
  22 --import qualified Type
  23 import qualified Name
  24 import qualified Var
  25 import qualified IdInfo
  26 import qualified TyCon
  27 import qualified DataCon
  28 --import qualified CoreSubst
  29 import qualified CoreUtils
  30 import Outputable ( showSDoc, ppr )
  31
  32 -- Local imports
  33 import CLasH.Translator.TranslatorTypes
  34 import CLasH.VHDL.VHDLTypes
  35 import CLasH.VHDL.VHDLTools
  36 import CLasH.Utils.Pretty
  37 import CLasH.Utils.Core.CoreTools
  38 import CLasH.VHDL.Constants
  39 import CLasH.VHDL.Generate
  40 import CLasH.VHDL.Testbench
  41
  42 createDesignFiles ::
  43   [CoreSyn.CoreBndr] -- ^ Top binders
  44   -> TranslatorSession [(AST.VHDLId, AST.DesignFile)]
  45
  46 createDesignFiles topbndrs = do
  47   bndrss <- mapM recurseArchitectures topbndrs
  48   let bndrs = concat bndrss
  49   lunits <- mapM createLibraryUnit bndrs
  50   typepackage <- createTypesPackage
  51   let files = map (Arrow.second $ AST.DesignFile full_context) lunits
  52   return $ typepackage : files
  53   where
  54     full_context =
  55       mkUseAll ["work", "types"]
  56       : (mkUseAll ["work"]
  57       : ieee_context)
  58
  59 ieee_context = [
  60     AST.Library $ mkVHDLBasicId "IEEE",
  61     mkUseAll ["IEEE", "std_logic_1164"],
  62     mkUseAll ["IEEE", "numeric_std"],
  63     mkUseAll ["std", "textio"]
  64   ]
  65
  66 -- | Find out which entities are needed for the given top level binders.
  67 recurseArchitectures ::
  68   CoreSyn.CoreBndr -- ^ The top level binder
  69   -> TranslatorSession [CoreSyn.CoreBndr]
  70   -- ^ The binders of all needed functions.
  71 recurseArchitectures bndr = do
  72   -- See what this binder directly uses
  73   (_, used) <- getArchitecture bndr
  74   -- Recursively check what each of the used functions uses
  75   useds <- mapM recurseArchitectures used
  76   -- And return all of them
  77   return $ bndr : (concat useds)
  78
  79 -- | Creates the types package, based on the current type state.
  80 createTypesPackage ::
  81   TranslatorSession (AST.VHDLId, AST.DesignFile)
  82   -- ^ The id and content of the types package
  83
  84 createTypesPackage = do
  85   tyfuns <- getA (tsType .> tsTypeFuns)
  86   let tyfun_decls = mkBuiltInShow ++ (map snd $ Map.elems tyfuns)
  87   ty_decls <- getA (tsType .> tsTypeDecls)
  88   let subProgSpecs = map (\(AST.SubProgBody spec _ _) -> AST.PDISS spec) tyfun_decls
  89   let type_package_dec = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") ([tfvec_index_decl] ++ ty_decls ++ subProgSpecs)
  90   let type_package_body = AST.LUPackageBody $ AST.PackageBody typesId tyfun_decls
  91   return $ (mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package_dec, type_package_body])
  92   where
  93     tfvec_index_decl = AST.PDISD $ AST.SubtypeDec tfvec_indexTM tfvec_index_def
  94     tfvec_range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit "-1") (AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerTM) (AST.NSimple $ highId) Nothing)
  95     tfvec_index_def = AST.SubtypeIn integerTM (Just tfvec_range)
  96
  97 -- Create a use foo.bar.all statement. Takes a list of components in the used
  98 -- name. Must contain at least two components
  99 mkUseAll :: [String] -> AST.ContextItem
 100 mkUseAll ss =
 101   AST.Use $ from AST.:.: AST.All
 102   where
 103     base_prefix = (AST.NSimple $ mkVHDLBasicId $ head ss)
 104     from = foldl select base_prefix (tail ss)
 105     select prefix s = AST.NSelected $ prefix AST.:.: (AST.SSimple $ mkVHDLBasicId s)
 106
 107 createLibraryUnit ::
 108   CoreSyn.CoreBndr
 109   -> TranslatorSession (AST.VHDLId, [AST.LibraryUnit])
 110
 111 createLibraryUnit bndr = do
 112   entity <- getEntity bndr
 113   (arch, _) <- getArchitecture bndr
 114   return (ent_id entity, [AST.LUEntity (ent_dec entity), AST.LUArch arch])
 115
 116 {-
 117 -- | Looks up all pairs of old state, new state signals, together with
 118 --   the state id they represent.
 119 makeStatePairs :: FlatFunction -> [(StateId, SignalInfo, SignalInfo)]
 120 makeStatePairs flatfunc =
 121   [(Maybe.fromJust $ oldStateId $ sigUse old_info, old_info, new_info)
 122     | old_info <- map snd (flat_sigs flatfunc)
 123     , new_info <- map snd (flat_sigs flatfunc)
 124         -- old_info must be an old state (and, because of the next equality,
 125         -- new_info must be a new state).
 126         , Maybe.isJust $ oldStateId $ sigUse old_info
 127         -- And the state numbers must match
 128     , (oldStateId $ sigUse old_info) == (newStateId $ sigUse new_info)]
 129
 130     -- Replace the second tuple element with the corresponding SignalInfo
 131     --args_states = map (Arrow.second $ signalInfo sigs) args
 132 mkStateProcSm :: (StateId, SignalInfo, SignalInfo) -> AST.ProcSm
 133 mkStateProcSm (num, old, new) =
 134   AST.ProcSm label [clk] [statement]
 135   where
 136     label       = mkVHDLExtId $ "state_" ++ (show num)
 137     clk         = mkVHDLExtId "clk"
 138     rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
 139     wform       = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple $ getSignalId new) Nothing]
 140     assign      = AST.SigAssign (AST.NSimple $ getSignalId old) wform
 141     rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
 142     statement   = AST.IfSm rising_edge_clk [assign] [] Nothing
 143
 144 -- | Creates a VHDL Id from a named SignalInfo. Errors out if the SignalInfo
 145 --   is not named.
 146 getSignalId :: SignalInfo -> AST.VHDLId
 147 getSignalId info =
 148   mkVHDLExtId $ Maybe.fromMaybe
 149     (error $ "Unnamed signal? This should not happen!")
 150     (sigName info)
 151 -}