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 -}
 152
 153 {-
 154 createTestBench ::
 155   Maybe Int -- ^ Number of cycles to simulate
 156   -> [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] -- ^ Input stimuli
 157   -> CoreSyn.CoreBndr -- ^ Top Entity
 158   -> VHDLSession (AST.VHDLId, [AST.LibraryUnit]) -- ^ Testbench
 159 createTestBench mCycles stimuli topEntity = do
 160   ent@(AST.EntityDec id _) <- createTestBenchEntity topEntity
 161   arch <- createTestBenchArch mCycles stimuli topEntity
 162   return (id, [AST.LUEntity ent, AST.LUArch arch])
 163
 164
 165 createTestBenchEntity ::
 166   CoreSyn.CoreBndr -- ^ Top Entity
 167   -> VHDLSession AST.EntityDec -- ^ TB Entity
 168 createTestBenchEntity topEntity = do
 169   signaturemap <- getA vsSignatures
 170   let signature = Maybe.fromMaybe
 171         (error $ "\nTestbench.createTestBenchEntity: Generating testbench for function \n" ++ (pprString topEntity) ++ "\nwithout signature? This should not happen!")
 172         (Map.lookup topEntity signaturemap)
 173   let signaturename = ent_id signature
 174   return $ AST.EntityDec (AST.unsafeIdAppend signaturename "_tb") []
 175
 176 createTestBenchArch ::
 177   Maybe Int -- ^ Number of cycles to simulate
 178   -> [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] -- ^ Imput stimulie
 179   -> CoreSyn.CoreBndr -- ^ Top Entity
 180   -> VHDLSession AST.ArchBody
 181 createTestBenchArch mCycles stimuli topEntity = do
 182   signaturemap <- getA vsSignatures
 183   let signature = Maybe.fromMaybe
 184         (error $ "\nTestbench.createTestBenchArch: Generating testbench for function \n" ++ (pprString topEntity) ++ "\nwithout signature? This should not happen!")
 185         (Map.lookup topEntity signaturemap)
 186   let entId   = ent_id signature
 187       iIface  = ent_args signature
 188       oIface  = ent_res signature
 189       iIds    = map fst iIface
 190       oIds    = fst oIface
 191   let iDecs   = map (\(vId, tm) -> AST.SigDec vId tm Nothing) iIface
 192   let finalIDecs = iDecs ++
 193                     [AST.SigDec clockId std_logicTM (Just $ AST.PrimLit "'0'"),
 194                      AST.SigDec resetId std_logicTM (Just $ AST.PrimLit "'0'")]
 195   let oDecs   = AST.SigDec (fst oIface) (snd oIface) Nothing
 196   let portmaps = mkAssocElems (map idToVHDLExpr iIds) (AST.NSimple oIds) signature
 197   let mIns    = mkComponentInst "totest" entId portmaps
 198   (stimuliAssigns, stimuliDecs, cycles) <- createStimuliAssigns mCycles stimuli (head iIds)
 199   let finalAssigns = (AST.CSSASm (AST.NSimple resetId AST.:<==:
 200                       AST.ConWforms []
 201                                     (AST.Wform [AST.WformElem (AST.PrimLit "'1'") (Just $ AST.PrimLit "3 ns")])
 202                                     Nothing)) : stimuliAssigns
 203   let clkProc     = createClkProc
 204   let outputProc  = createOutputProc [oIds]
 205   return $ (AST.ArchBody
 206               (AST.unsafeVHDLBasicId "test")
 207               (AST.NSimple $ AST.unsafeIdAppend entId "_tb")
 208               (map AST.BDISD (finalIDecs ++ stimuliDecs ++ [oDecs]))
 209               (mIns :
 210                 ( (AST.CSPSm clkProc) : (AST.CSPSm outputProc) : finalAssigns ) ) )
 211
 212 createStimuliAssigns ::
 213   Maybe Int -- ^ Number of cycles to simulate
 214   -> [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] -- ^ Input stimuli
 215   -> AST.VHDLId -- ^ Input signal
 216   -> VHDLSession ([AST.ConcSm], [AST.SigDec], Int)
 217 createStimuliAssigns mCycles [] _ = return ([], [], Maybe.maybe 0 id mCycles)
 218
 219 createStimuliAssigns mCycles stimuli signal = do
 220   let genWformElem time stim = (AST.WformElem stim (Just $ AST.PrimLit (show time ++ " ns")))
 221   let inputlen = length stimuli
 222   assigns <- Monad.zipWithM createStimulans stimuli [0..inputlen]
 223   let resvars = (map snd assigns)
 224   sig_dec_maybes <- mapM mkSigDec resvars
 225   let sig_decs = Maybe.catMaybes sig_dec_maybes
 226   outps <- mapM (\x -> MonadState.lift vsType (varToVHDLExpr x)) resvars
 227   let wformelems = zipWith genWformElem [0,10..] outps
 228   let inassign = AST.CSSASm $ AST.NSimple signal AST.:<==: AST.ConWforms [] (AST.Wform wformelems) Nothing
 229   return ((map fst assigns) ++ [inassign], sig_decs, inputlen)
 230
 231 createStimulans :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> Int -> VHDLSession (AST.ConcSm, Var.Var)
 232 createStimulans (bndr, expr) cycl = do
 233   -- There must be a let at top level
 234   let (CoreSyn.Let (CoreSyn.Rec binds) (Var res)) = expr
 235   stimulansbinds <- Monad.mapM mkConcSm binds
 236   sig_dec_maybes <- mapM (mkSigDec . fst) (filter ((/=res).fst) binds)
 237   let sig_decs = map (AST.BDISD) (Maybe.catMaybes $ sig_dec_maybes)
 238   let block_label = mkVHDLExtId ("testcycle_" ++ (show cycl))
 239   let block = AST.BlockSm block_label [] (AST.PMapAspect []) sig_decs (concat stimulansbinds)
 240   return (AST.CSBSm block, res)
 241
 242 -- | generates a clock process with a period of 10ns
 243 createClkProc :: AST.ProcSm
 244 createClkProc = AST.ProcSm (AST.unsafeVHDLBasicId "clkproc") [] sms
 245  where sms = -- wait for 5 ns -- (half a cycle)
 246              [AST.WaitFor $ AST.PrimLit "5 ns",
 247               -- clk <= not clk;
 248               AST.NSimple clockId `AST.SigAssign`
 249                  AST.Wform [AST.WformElem (AST.Not (AST.PrimName $ AST.NSimple clockId)) Nothing]]
 250
 251 -- | generate the output process
 252 createOutputProc :: [AST.VHDLId] -- ^ output signal
 253               -> AST.ProcSm
 254 createOutputProc outs =
 255   AST.ProcSm (AST.unsafeVHDLBasicId "writeoutput")
 256          [clockId]
 257          [AST.IfSm clkPred (writeOuts outs) [] Nothing]
 258  where clkPred = AST.PrimName (AST.NAttribute $ AST.AttribName (AST.NSimple clockId)
 259                                                    (AST.NSimple $ eventId)
 260                                                    Nothing          ) `AST.And`
 261                  (AST.PrimName (AST.NSimple clockId) AST.:=: AST.PrimLit "'1'")
 262        writeOuts :: [AST.VHDLId] -> [AST.SeqSm]
 263        writeOuts []  = []
 264        writeOuts [i] = [writeOut i (AST.PrimLit "LF")]
 265        writeOuts (i:is) = writeOut i (AST.PrimLit "HT") : writeOuts is
 266        writeOut outSig suffix =
 267          genExprPCall2 writeId
 268                         (AST.PrimName $ AST.NSimple outputId)
 269                         ((genExprFCall showId (AST.PrimName $ AST.NSimple outSig)) AST.:&: suffix)
 270
 271 -}