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 = 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) 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 (mkVHDLExtId "clk") 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 mkSigDec :: CoreSyn.CoreBndr -> VHDLSession (Maybe AST.SigDec)
 245 mkSigDec bndr =
 246   if True then do --isInternalSigUse use || isStateSigUse use then do
 247     let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString bndr
 248     type_mark <- MonadState.lift vsType $ vhdl_ty error_msg (Var.varType bndr)
 249     return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing)
 250   else
 251     return Nothing
 252
 253 -- | Transforms a core binding into a VHDL concurrent statement
 254 mkConcSm ::
 255   (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The binding to process
 256   -> VHDLSession [AST.ConcSm] -- ^ The corresponding VHDL component instantiations.
 257
 258
 259 -- Ignore Cast expressions, they should not longer have any meaning as long as
 260 -- the type works out.
 261 mkConcSm (bndr, Cast expr ty) = mkConcSm (bndr, expr)
 262
 263 -- Simple a = b assignments are just like applications, but without arguments.
 264 -- We can't just generate an unconditional assignment here, since b might be a
 265 -- top level binding (e.g., a function with no arguments).
 266 mkConcSm (bndr, Var v) = do
 267   genApplication (Left bndr) v []
 268
 269 mkConcSm (bndr, app@(CoreSyn.App _ _))= do
 270   let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
 271   let valargs = get_val_args (Var.varType f) args
 272   genApplication (Left bndr) f (map Left valargs)
 273
 274 -- A single alt case must be a selector. This means thee scrutinee is a simple
 275 -- variable, the alternative is a dataalt with a single non-wild binder that
 276 -- is also returned.
 277 mkConcSm (bndr, expr@(Case (Var scrut) b ty [alt])) =
 278   case alt of
 279     (DataAlt dc, bndrs, (Var sel_bndr)) -> do
 280       case List.elemIndex sel_bndr bndrs of
 281         Just i -> do
 282           labels <- MonadState.lift vsType $ getFieldLabels (Id.idType scrut)
 283           let label = labels!!i
 284           let sel_name = mkSelectedName (varToVHDLName scrut) label
 285           let sel_expr = AST.PrimName sel_name
 286           return [mkUncondAssign (Left bndr) sel_expr]
 287         Nothing -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
 288
 289     _ -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
 290
 291 -- Multiple case alt are be conditional assignments and have only wild
 292 -- binders in the alts and only variables in the case values and a variable
 293 -- for a scrutinee. We check the constructor of the second alt, since the
 294 -- first is the default case, if there is any.
 295 mkConcSm (bndr, (Case (Var scrut) b ty [(_, _, Var false), (con, _, Var true)])) = do
 296   scrut' <- MonadState.lift vsType $ varToVHDLExpr scrut
 297   let cond_expr = scrut' AST.:=: (altconToVHDLExpr con)
 298   true_expr <- MonadState.lift vsType $ varToVHDLExpr true
 299   false_expr <- MonadState.lift vsType $ varToVHDLExpr false
 300   return [mkCondAssign (Left bndr) cond_expr true_expr false_expr]
 301
 302 mkConcSm (_, (Case (Var _) _ _ alts)) = error "\nVHDL.mkConcSm: Not in normal form: Case statement with more than two alternatives"
 303 mkConcSm (_, Case _ _ _ _) = error "\nVHDL.mkConcSm: Not in normal form: Case statement has does not have a simple variable as scrutinee"
 304 mkConcSm (bndr, expr) = error $ "\nVHDL.mkConcSM: Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr
 305
 306
 307 createTestBench ::
 308   Maybe Int -- ^ Number of cycles to simulate
 309   -> [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] -- ^ Input stimuli
 310   -> CoreSyn.CoreBndr -- ^ Top Entity
 311   -> VHDLSession (AST.VHDLId, [AST.LibraryUnit]) -- ^ Testbench
 312 createTestBench mCycles stimuli topEntity = do
 313   ent@(AST.EntityDec id _) <- createTestBenchEntity topEntity
 314   arch <- createTestBenchArch mCycles stimuli topEntity
 315   return (id, [AST.LUEntity ent, AST.LUArch arch])
 316
 317
 318 createTestBenchEntity ::
 319   CoreSyn.CoreBndr -- ^ Top Entity
 320   -> VHDLSession AST.EntityDec -- ^ TB Entity
 321 createTestBenchEntity topEntity = do
 322   signaturemap <- getA vsSignatures
 323   let signature = Maybe.fromMaybe
 324         (error $ "\nTestbench.createTestBenchEntity: Generating testbench for function \n" ++ (pprString topEntity) ++ "\nwithout signature? This should not happen!")
 325         (Map.lookup topEntity signaturemap)
 326   let signaturename = ent_id signature
 327   return $ AST.EntityDec (AST.unsafeIdAppend signaturename "_tb") []
 328
 329 createTestBenchArch ::
 330   Maybe Int -- ^ Number of cycles to simulate
 331   -> [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] -- ^ Imput stimulie
 332   -> CoreSyn.CoreBndr -- ^ Top Entity
 333   -> VHDLSession AST.ArchBody
 334 createTestBenchArch mCycles stimuli topEntity = do
 335   signaturemap <- getA vsSignatures
 336   let signature = Maybe.fromMaybe
 337         (error $ "\nTestbench.createTestBenchArch: Generating testbench for function \n" ++ (pprString topEntity) ++ "\nwithout signature? This should not happen!")
 338         (Map.lookup topEntity signaturemap)
 339   let entId   = ent_id signature
 340       iIface  = ent_args signature
 341       oIface  = ent_res signature
 342       iIds    = map fst iIface
 343       oIds    = fst oIface
 344   let iDecs   = map (\(vId, tm) -> AST.SigDec vId tm Nothing) iIface
 345   let finalIDecs = iDecs ++
 346                     [AST.SigDec clockId std_logicTM (Just $ AST.PrimLit "'0'"),
 347                      AST.SigDec resetId std_logicTM (Just $ AST.PrimLit "'0'")]
 348   let oDecs   = AST.SigDec (fst oIface) (snd oIface) Nothing
 349   let portmaps = mkAssocElems (map idToVHDLExpr iIds) (AST.NSimple oIds) signature
 350   let mIns    = mkComponentInst "totest" entId portmaps
 351   (stimuliAssigns, stimuliDecs, cycles) <- createStimuliAssigns mCycles stimuli (head iIds)
 352   let finalAssigns = (AST.CSSASm (AST.NSimple resetId AST.:<==:
 353                       AST.ConWforms []
 354                                     (AST.Wform [AST.WformElem (AST.PrimLit "'1'") (Just $ AST.PrimLit "3 ns")])
 355                                     Nothing)) : stimuliAssigns
 356   let clkProc     = createClkProc
 357   let outputProc  = createOutputProc [oIds]
 358   return $ (AST.ArchBody
 359               (AST.unsafeVHDLBasicId "test")
 360               (AST.NSimple $ AST.unsafeIdAppend entId "_tb")
 361               (map AST.BDISD (finalIDecs ++ stimuliDecs ++ [oDecs]))
 362               (mIns :
 363                 ( (AST.CSPSm clkProc) : (AST.CSPSm outputProc) : finalAssigns ) ) )
 364
 365 createStimuliAssigns ::
 366   Maybe Int -- ^ Number of cycles to simulate
 367   -> [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] -- ^ Input stimuli
 368   -> AST.VHDLId -- ^ Input signal
 369   -> VHDLSession ([AST.ConcSm], [AST.SigDec], Int)
 370 createStimuliAssigns mCycles [] _ = return ([], [], Maybe.maybe 0 id mCycles)
 371
 372 createStimuliAssigns mCycles stimuli signal = do
 373   let genWformElem time stim = (AST.WformElem stim (Just $ AST.PrimLit (show time ++ " ns")))
 374   let inputlen = length stimuli
 375   assigns <- Monad.zipWithM createStimulans stimuli [0..inputlen]
 376   let resvars = (map snd assigns)
 377   sig_dec_maybes <- mapM mkSigDec resvars
 378   let sig_decs = Maybe.catMaybes sig_dec_maybes
 379   outps <- mapM (\x -> MonadState.lift vsType (varToVHDLExpr x)) resvars
 380   let wformelems = zipWith genWformElem [0,10..] outps
 381   let inassign = AST.CSSASm $ AST.NSimple signal AST.:<==: AST.ConWforms [] (AST.Wform wformelems) Nothing
 382   return ((map fst assigns) ++ [inassign], sig_decs, inputlen)
 383
 384 createStimulans :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> Int -> VHDLSession (AST.ConcSm, Var.Var)
 385 createStimulans (bndr, expr) cycl = do
 386   -- There must be a let at top level
 387   let (CoreSyn.Let (CoreSyn.Rec binds) (Var res)) = expr
 388   stimulansbinds <- Monad.mapM mkConcSm binds
 389   sig_dec_maybes <- mapM (mkSigDec . fst) (filter ((/=res).fst) binds)
 390   let sig_decs = map (AST.BDISD) (Maybe.catMaybes $ sig_dec_maybes)
 391   let block_label = mkVHDLExtId ("testcycle_" ++ (show cycl))
 392   let block = AST.BlockSm block_label [] (AST.PMapAspect []) sig_decs (concat stimulansbinds)
 393   return (AST.CSBSm block, res)
 394
 395 -- | generates a clock process with a period of 10ns
 396 createClkProc :: AST.ProcSm
 397 createClkProc = AST.ProcSm (AST.unsafeVHDLBasicId "clkproc") [] sms
 398  where sms = -- wait for 5 ns -- (half a cycle)
 399              [AST.WaitFor $ AST.PrimLit "5 ns",
 400               -- clk <= not clk;
 401               AST.NSimple clockId `AST.SigAssign`
 402                  AST.Wform [AST.WformElem (AST.Not (AST.PrimName $ AST.NSimple clockId)) Nothing]]
 403
 404 -- | generate the output process
 405 createOutputProc :: [AST.VHDLId] -- ^ output signal
 406               -> AST.ProcSm
 407 createOutputProc outs =
 408   AST.ProcSm (AST.unsafeVHDLBasicId "writeoutput")
 409          [clockId]
 410          [AST.IfSm clkPred (writeOuts outs) [] Nothing]
 411  where clkPred = AST.PrimName (AST.NAttribute $ AST.AttribName (AST.NSimple clockId)
 412                                                    eventId
 413                                                    Nothing          ) `AST.And`
 414                  (AST.PrimName (AST.NSimple clockId) AST.:=: AST.PrimLit "'1'")
 415        writeOuts :: [AST.VHDLId] -> [AST.SeqSm]
 416        writeOuts []  = []
 417        writeOuts [i] = [writeOut i (AST.PrimLit "LF")]
 418        writeOuts (i:is) = writeOut i (AST.PrimLit "HT") : writeOuts is
 419        writeOut outSig suffix =
 420          genExprFCall2 writeId
 421                         (AST.PrimName $ AST.NSimple outputId)
 422                         (genExprFCall1 showId ((AST.PrimName $ AST.NSimple outSig) AST.:&:  suffix))
 423        genExprFCall2 entid arg1 arg2 =
 424         AST.ProcCall (AST.NSimple entid) $
 425          map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [arg1,arg2]
 426        genExprFCall1 entid arg =
 427         AST.PrimFCall $ AST.FCall (AST.NSimple entid) $
 428          map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [arg]