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.List as List
   8 import qualified Data.Map as Map
   9 import qualified Maybe
  10 import qualified Control.Monad as Monad
  11 import qualified Control.Arrow as Arrow
  12 import qualified Control.Monad.Trans.State as State
  13 import qualified Data.Monoid as Monoid
  14 import Data.Accessor
  15 import Data.Accessor.MonadState as MonadState
  16 import Debug.Trace
  17
  18 -- ForSyDe
  19 import qualified Language.VHDL.AST as AST
  20
  21 -- GHC API
  22 import CoreSyn
  23 --import qualified Type
  24 import qualified Name
  25 import qualified Var
  26 import qualified Id
  27 import qualified IdInfo
  28 import qualified TyCon
  29 import qualified DataCon
  30 --import qualified CoreSubst
  31 import qualified CoreUtils
  32 import Outputable ( showSDoc, ppr )
  33
  34 -- Local imports
  35 import CLasH.VHDL.VHDLTypes
  36 import CLasH.VHDL.VHDLTools
  37 import CLasH.Utils.Pretty
  38 import CLasH.Utils.Core.CoreTools
  39 import CLasH.VHDL.Constants
  40 import CLasH.VHDL.Generate
  41 -- import CLasH.VHDL.Testbench
  42
  43 createDesignFiles ::
  44   TypeState
  45   -> [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
  46   -> CoreSyn.CoreBndr -- ^ Top binder
  47   -> [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] -- ^ Test Input
  48   -> [(AST.VHDLId, AST.DesignFile)]
  49
  50 createDesignFiles init_typestate binds topbind testinput =
  51   (mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package_dec, type_package_body]) :
  52   map (Arrow.second $ AST.DesignFile full_context) (units ++ [testbench])
  53
  54   where
  55     init_session = VHDLState init_typestate Map.empty
  56     (units, final_session') =
  57       State.runState (createLibraryUnits binds) init_session
  58     (testbench, final_session) =
  59       State.runState (createTestBench Nothing testinput topbind) final_session'
  60     tyfun_decls = mkBuiltInShow ++ (map snd $ Map.elems (final_session ^. vsType ^. vsTypeFuns))
  61     ty_decls = final_session ^. vsType ^. vsTypeDecls
  62     tfvec_index_decl = AST.PDISD $ AST.SubtypeDec tfvec_indexTM tfvec_index_def
  63     tfvec_range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit "-1") (AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerTM) (AST.NSimple $ highId) Nothing)
  64     tfvec_index_def = AST.SubtypeIn integerTM (Just tfvec_range)
  65     ieee_context = [
  66         AST.Library $ mkVHDLBasicId "IEEE",
  67         mkUseAll ["IEEE", "std_logic_1164"],
  68         mkUseAll ["IEEE", "numeric_std"],
  69         mkUseAll ["std", "textio"]
  70       ]
  71     full_context =
  72       mkUseAll ["work", "types"]
  73       : (mkUseAll ["work"]
  74       : ieee_context)
  75     type_package_dec = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") ([tfvec_index_decl] ++ ty_decls ++ subProgSpecs)
  76     type_package_body = AST.LUPackageBody $ AST.PackageBody typesId tyfun_decls
  77     subProgSpecs = map subProgSpec tyfun_decls
  78     subProgSpec = \(AST.SubProgBody spec _ _) -> AST.PDISS spec
  79
  80 -- Create a use foo.bar.all statement. Takes a list of components in the used
  81 -- name. Must contain at least two components
  82 mkUseAll :: [String] -> AST.ContextItem
  83 mkUseAll ss =
  84   AST.Use $ from AST.:.: AST.All
  85   where
  86     base_prefix = (AST.NSimple $ mkVHDLBasicId $ head ss)
  87     from = foldl select base_prefix (tail ss)
  88     select prefix s = AST.NSelected $ prefix AST.:.: (AST.SSimple $ mkVHDLBasicId s)
  89
  90 createLibraryUnits ::
  91   [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
  92   -> VHDLSession [(AST.VHDLId, [AST.LibraryUnit])]
  93
  94 createLibraryUnits binds = do
  95   entities <- Monad.mapM createEntity binds
  96   archs <- Monad.mapM createArchitecture binds
  97   return $ zipWith
  98     (\ent arch ->
  99       let AST.EntityDec id _ = ent in
 100       (id, [AST.LUEntity ent, AST.LUArch arch])
 101     )
 102     entities archs
 103
 104 -- | Create an entity for a given function
 105 createEntity ::
 106   (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- | The function
 107   -> VHDLSession AST.EntityDec -- | The resulting entity
 108
 109 createEntity (fname, expr) = do
 110       -- Strip off lambda's, these will be arguments
 111       let (args, letexpr) = CoreSyn.collectBinders expr
 112       args' <- Monad.mapM mkMap args
 113       -- There must be a let at top level
 114       let (CoreSyn.Let binds (CoreSyn.Var res)) = letexpr
 115       res' <- mkMap res
 116       let vhdl_id = mkVHDLBasicId $ varToString fname ++ "_" ++ varToStringUniq fname
 117       let ent_decl' = createEntityAST vhdl_id args' res'
 118       let AST.EntityDec entity_id _ = ent_decl'
 119       let signature = Entity entity_id args' res'
 120       modA vsSignatures (Map.insert fname signature)
 121       return ent_decl'
 122   where
 123     mkMap ::
 124       --[(SignalId, SignalInfo)]
 125       CoreSyn.CoreBndr
 126       -> VHDLSession Port
 127     -- We only need the vsTypes element from the state
 128     mkMap = (\bndr ->
 129       let
 130         --info = Maybe.fromMaybe
 131         --  (error $ "Signal not found in the name map? This should not happen!")
 132         --  (lookup id sigmap)
 133         --  Assume the bndr has a valid VHDL id already
 134         id = varToVHDLId bndr
 135         ty = Var.varType bndr
 136         error_msg = "\nVHDL.createEntity.mkMap: Can not create entity: " ++ pprString fname ++ "\nbecause no type can be created for port: " ++ pprString bndr
 137       in do
 138         type_mark <- MonadState.lift vsType $ vhdl_ty error_msg ty
 139         return (id, type_mark)
 140      )
 141
 142   -- | Create the VHDL AST for an entity
 143 createEntityAST ::
 144   AST.VHDLId                   -- | The name of the function
 145   -> [Port]                    -- | The entity's arguments
 146   -> Port                      -- | The entity's result
 147   -> AST.EntityDec             -- | The entity with the ent_decl filled in as well
 148
 149 createEntityAST vhdl_id args res =
 150   AST.EntityDec vhdl_id ports
 151   where
 152     -- Create a basic Id, since VHDL doesn't grok filenames with extended Ids.
 153     ports = map (mkIfaceSigDec AST.In) args
 154               ++ [mkIfaceSigDec AST.Out res]
 155               ++ [clk_port]
 156     -- Add a clk port if we have state
 157     clk_port = AST.IfaceSigDec clockId AST.In std_logicTM
 158
 159 -- | Create a port declaration
 160 mkIfaceSigDec ::
 161   AST.Mode                         -- | The mode for the port (In / Out)
 162   -> (AST.VHDLId, AST.TypeMark)    -- | The id and type for the port
 163   -> AST.IfaceSigDec               -- | The resulting port declaration
 164
 165 mkIfaceSigDec mode (id, ty) = AST.IfaceSigDec id mode ty
 166
 167 {-
 168 -- | Generate a VHDL entity name for the given hsfunc
 169 mkEntityId hsfunc =
 170   -- TODO: This doesn't work for functions with multiple signatures!
 171   -- Use a Basic Id, since using extended id's for entities throws off
 172   -- precision and causes problems when generating filenames.
 173   mkVHDLBasicId $ hsFuncName hsfunc
 174 -}
 175
 176 -- | Create an architecture for a given function
 177 createArchitecture ::
 178   (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The function
 179   -> VHDLSession AST.ArchBody -- ^ The architecture for this function
 180
 181 createArchitecture (fname, expr) = do
 182   signaturemap <- getA vsSignatures
 183   let signature = Maybe.fromMaybe
 184         (error $ "\nVHDL.createArchitecture: Generating architecture for function \n" ++ (pprString fname) ++ "\nwithout signature? This should not happen!")
 185         (Map.lookup fname signaturemap)
 186   let entity_id = ent_id signature
 187   -- Strip off lambda's, these will be arguments
 188   let (args, letexpr) = CoreSyn.collectBinders expr
 189   -- There must be a let at top level
 190   let (CoreSyn.Let (CoreSyn.Rec binds) (Var res)) = letexpr
 191
 192   -- Create signal declarations for all binders in the let expression, except
 193   -- for the output port (that will already have an output port declared in
 194   -- the entity).
 195   sig_dec_maybes <- mapM (mkSigDec' . fst) (filter ((/=res).fst) binds)
 196   let sig_decs = Maybe.catMaybes $ sig_dec_maybes
 197
 198   statementss <- Monad.mapM mkConcSm binds
 199   let statements = concat statementss
 200   return $ AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
 201   where
 202     procs = [] --map mkStateProcSm [] -- (makeStatePairs flatfunc)
 203     procs' = map AST.CSPSm procs
 204     -- mkSigDec only uses vsTypes from the state
 205     mkSigDec' = mkSigDec
 206
 207 {-
 208 -- | Looks up all pairs of old state, new state signals, together with
 209 --   the state id they represent.
 210 makeStatePairs :: FlatFunction -> [(StateId, SignalInfo, SignalInfo)]
 211 makeStatePairs flatfunc =
 212   [(Maybe.fromJust $ oldStateId $ sigUse old_info, old_info, new_info)
 213     | old_info <- map snd (flat_sigs flatfunc)
 214     , new_info <- map snd (flat_sigs flatfunc)
 215         -- old_info must be an old state (and, because of the next equality,
 216         -- new_info must be a new state).
 217         , Maybe.isJust $ oldStateId $ sigUse old_info
 218         -- And the state numbers must match
 219     , (oldStateId $ sigUse old_info) == (newStateId $ sigUse new_info)]
 220
 221     -- Replace the second tuple element with the corresponding SignalInfo
 222     --args_states = map (Arrow.second $ signalInfo sigs) args
 223 mkStateProcSm :: (StateId, SignalInfo, SignalInfo) -> AST.ProcSm
 224 mkStateProcSm (num, old, new) =
 225   AST.ProcSm label [clk] [statement]
 226   where
 227     label       = mkVHDLExtId $ "state_" ++ (show num)
 228     clk         = mkVHDLExtId "clk"
 229     rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
 230     wform       = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple $ getSignalId new) Nothing]
 231     assign      = AST.SigAssign (AST.NSimple $ getSignalId old) wform
 232     rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
 233     statement   = AST.IfSm rising_edge_clk [assign] [] Nothing
 234
 235 -- | Creates a VHDL Id from a named SignalInfo. Errors out if the SignalInfo
 236 --   is not named.
 237 getSignalId :: SignalInfo -> AST.VHDLId
 238 getSignalId info =
 239   mkVHDLExtId $ Maybe.fromMaybe
 240     (error $ "Unnamed signal? This should not happen!")
 241     (sigName info)
 242 -}
 243
 244 -- | Transforms a core binding into a VHDL concurrent statement
 245 mkConcSm ::
 246   (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The binding to process
 247   -> VHDLSession [AST.ConcSm] -- ^ The corresponding VHDL component instantiations.
 248
 249
 250 -- Ignore Cast expressions, they should not longer have any meaning as long as
 251 -- the type works out.
 252 mkConcSm (bndr, Cast expr ty) = mkConcSm (bndr, expr)
 253
 254 -- Simple a = b assignments are just like applications, but without arguments.
 255 -- We can't just generate an unconditional assignment here, since b might be a
 256 -- top level binding (e.g., a function with no arguments).
 257 mkConcSm (bndr, Var v) = do
 258   genApplication (Left bndr) v []
 259
 260 mkConcSm (bndr, app@(CoreSyn.App _ _))= do
 261   let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
 262   let valargs = get_val_args (Var.varType f) args
 263   genApplication (Left bndr) f (map Left valargs)
 264
 265 -- A single alt case must be a selector. This means thee scrutinee is a simple
 266 -- variable, the alternative is a dataalt with a single non-wild binder that
 267 -- is also returned.
 268 mkConcSm (bndr, expr@(Case (Var scrut) b ty [alt])) =
 269   case alt of
 270     (DataAlt dc, bndrs, (Var sel_bndr)) -> do
 271       case List.elemIndex sel_bndr bndrs of
 272         Just i -> do
 273           labels <- MonadState.lift vsType $ getFieldLabels (Id.idType scrut)
 274           let label = labels!!i
 275           let sel_name = mkSelectedName (varToVHDLName scrut) label
 276           let sel_expr = AST.PrimName sel_name
 277           return [mkUncondAssign (Left bndr) sel_expr]
 278         Nothing -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
 279
 280     _ -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
 281
 282 -- Multiple case alt are be conditional assignments and have only wild
 283 -- binders in the alts and only variables in the case values and a variable
 284 -- for a scrutinee. We check the constructor of the second alt, since the
 285 -- first is the default case, if there is any.
 286 mkConcSm (bndr, (Case (Var scrut) b ty [(_, _, Var false), (con, _, Var true)])) = do
 287   scrut' <- MonadState.lift vsType $ varToVHDLExpr scrut
 288   let cond_expr = scrut' AST.:=: (altconToVHDLExpr con)
 289   true_expr <- MonadState.lift vsType $ varToVHDLExpr true
 290   false_expr <- MonadState.lift vsType $ varToVHDLExpr false
 291   return [mkCondAssign (Left bndr) cond_expr true_expr false_expr]
 292
 293 mkConcSm (_, (Case (Var _) _ _ alts)) = error "\nVHDL.mkConcSm: Not in normal form: Case statement with more than two alternatives"
 294 mkConcSm (_, Case _ _ _ _) = error "\nVHDL.mkConcSm: Not in normal form: Case statement has does not have a simple variable as scrutinee"
 295 mkConcSm (bndr, expr) = error $ "\nVHDL.mkConcSM: Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr
 296
 297
 298 createTestBench ::
 299   Maybe Int -- ^ Number of cycles to simulate
 300   -> [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] -- ^ Input stimuli
 301   -> CoreSyn.CoreBndr -- ^ Top Entity
 302   -> VHDLSession (AST.VHDLId, [AST.LibraryUnit]) -- ^ Testbench
 303 createTestBench mCycles stimuli topEntity = do
 304   ent@(AST.EntityDec id _) <- createTestBenchEntity topEntity
 305   arch <- createTestBenchArch mCycles stimuli topEntity
 306   return (id, [AST.LUEntity ent, AST.LUArch arch])
 307
 308
 309 createTestBenchEntity ::
 310   CoreSyn.CoreBndr -- ^ Top Entity
 311   -> VHDLSession AST.EntityDec -- ^ TB Entity
 312 createTestBenchEntity topEntity = do
 313   signaturemap <- getA vsSignatures
 314   let signature = Maybe.fromMaybe
 315         (error $ "\nTestbench.createTestBenchEntity: Generating testbench for function \n" ++ (pprString topEntity) ++ "\nwithout signature? This should not happen!")
 316         (Map.lookup topEntity signaturemap)
 317   let signaturename = ent_id signature
 318   return $ AST.EntityDec (AST.unsafeIdAppend signaturename "_tb") []
 319
 320 createTestBenchArch ::
 321   Maybe Int -- ^ Number of cycles to simulate
 322   -> [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] -- ^ Imput stimulie
 323   -> CoreSyn.CoreBndr -- ^ Top Entity
 324   -> VHDLSession AST.ArchBody
 325 createTestBenchArch mCycles stimuli topEntity = do
 326   signaturemap <- getA vsSignatures
 327   let signature = Maybe.fromMaybe
 328         (error $ "\nTestbench.createTestBenchArch: Generating testbench for function \n" ++ (pprString topEntity) ++ "\nwithout signature? This should not happen!")
 329         (Map.lookup topEntity signaturemap)
 330   let entId   = ent_id signature
 331       iIface  = ent_args signature
 332       oIface  = ent_res signature
 333       iIds    = map fst iIface
 334       oIds    = fst oIface
 335   let iDecs   = map (\(vId, tm) -> AST.SigDec vId tm Nothing) iIface
 336   let finalIDecs = iDecs ++
 337                     [AST.SigDec clockId std_logicTM (Just $ AST.PrimLit "'0'"),
 338                      AST.SigDec resetId std_logicTM (Just $ AST.PrimLit "'0'")]
 339   let oDecs   = AST.SigDec (fst oIface) (snd oIface) Nothing
 340   let portmaps = mkAssocElems (map idToVHDLExpr iIds) (AST.NSimple oIds) signature
 341   let mIns    = mkComponentInst "totest" entId portmaps
 342   (stimuliAssigns, stimuliDecs, cycles) <- createStimuliAssigns mCycles stimuli (head iIds)
 343   let finalAssigns = (AST.CSSASm (AST.NSimple resetId AST.:<==:
 344                       AST.ConWforms []
 345                                     (AST.Wform [AST.WformElem (AST.PrimLit "'1'") (Just $ AST.PrimLit "3 ns")])
 346                                     Nothing)) : stimuliAssigns
 347   let clkProc     = createClkProc
 348   let outputProc  = createOutputProc [oIds]
 349   return $ (AST.ArchBody
 350               (AST.unsafeVHDLBasicId "test")
 351               (AST.NSimple $ AST.unsafeIdAppend entId "_tb")
 352               (map AST.BDISD (finalIDecs ++ stimuliDecs ++ [oDecs]))
 353               (mIns :
 354                 ( (AST.CSPSm clkProc) : (AST.CSPSm outputProc) : finalAssigns ) ) )
 355
 356 createStimuliAssigns ::
 357   Maybe Int -- ^ Number of cycles to simulate
 358   -> [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] -- ^ Input stimuli
 359   -> AST.VHDLId -- ^ Input signal
 360   -> VHDLSession ([AST.ConcSm], [AST.SigDec], Int)
 361 createStimuliAssigns mCycles [] _ = return ([], [], Maybe.maybe 0 id mCycles)
 362
 363 createStimuliAssigns mCycles stimuli signal = do
 364   let genWformElem time stim = (AST.WformElem stim (Just $ AST.PrimLit (show time ++ " ns")))
 365   let inputlen = length stimuli
 366   assigns <- Monad.zipWithM createStimulans stimuli [0..inputlen]
 367   let resvars = (map snd assigns)
 368   sig_dec_maybes <- mapM mkSigDec resvars
 369   let sig_decs = Maybe.catMaybes sig_dec_maybes
 370   outps <- mapM (\x -> MonadState.lift vsType (varToVHDLExpr x)) resvars
 371   let wformelems = zipWith genWformElem [0,10..] outps
 372   let inassign = AST.CSSASm $ AST.NSimple signal AST.:<==: AST.ConWforms [] (AST.Wform wformelems) Nothing
 373   return ((map fst assigns) ++ [inassign], sig_decs, inputlen)
 374
 375 createStimulans :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> Int -> VHDLSession (AST.ConcSm, Var.Var)
 376 createStimulans (bndr, expr) cycl = do
 377   -- There must be a let at top level
 378   let (CoreSyn.Let (CoreSyn.Rec binds) (Var res)) = expr
 379   stimulansbinds <- Monad.mapM mkConcSm binds
 380   sig_dec_maybes <- mapM (mkSigDec . fst) (filter ((/=res).fst) binds)
 381   let sig_decs = map (AST.BDISD) (Maybe.catMaybes $ sig_dec_maybes)
 382   let block_label = mkVHDLExtId ("testcycle_" ++ (show cycl))
 383   let block = AST.BlockSm block_label [] (AST.PMapAspect []) sig_decs (concat stimulansbinds)
 384   return (AST.CSBSm block, res)
 385
 386 -- | generates a clock process with a period of 10ns
 387 createClkProc :: AST.ProcSm
 388 createClkProc = AST.ProcSm (AST.unsafeVHDLBasicId "clkproc") [] sms
 389  where sms = -- wait for 5 ns -- (half a cycle)
 390              [AST.WaitFor $ AST.PrimLit "5 ns",
 391               -- clk <= not clk;
 392               AST.NSimple clockId `AST.SigAssign`
 393                  AST.Wform [AST.WformElem (AST.Not (AST.PrimName $ AST.NSimple clockId)) Nothing]]
 394
 395 -- | generate the output process
 396 createOutputProc :: [AST.VHDLId] -- ^ output signal
 397               -> AST.ProcSm
 398 createOutputProc outs =
 399   AST.ProcSm (AST.unsafeVHDLBasicId "writeoutput")
 400          [clockId]
 401          [AST.IfSm clkPred (writeOuts outs) [] Nothing]
 402  where clkPred = AST.PrimName (AST.NAttribute $ AST.AttribName (AST.NSimple clockId)
 403                                                    (AST.NSimple $ eventId)
 404                                                    Nothing          ) `AST.And`
 405                  (AST.PrimName (AST.NSimple clockId) AST.:=: AST.PrimLit "'1'")
 406        writeOuts :: [AST.VHDLId] -> [AST.SeqSm]
 407        writeOuts []  = []
 408        writeOuts [i] = [writeOut i (AST.PrimLit "LF")]
 409        writeOuts (i:is) = writeOut i (AST.PrimLit "HT") : writeOuts is
 410        writeOut outSig suffix =
 411          genExprPCall2 writeId
 412                         (AST.PrimName $ AST.NSimple outputId)
 413                         ((genExprFCall showId (AST.PrimName $ AST.NSimple outSig)) AST.:&: suffix)