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
  42 createDesignFiles ::
  43   TypeState
  44   -> [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
  45   -> [(AST.VHDLId, AST.DesignFile)]
  46
  47 createDesignFiles init_typestate binds =
  48   (mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package_dec, type_package_body]) :
  49   map (Arrow.second $ AST.DesignFile full_context) units
  50
  51   where
  52     init_session = VHDLState init_typestate Map.empty
  53     (units, final_session) =
  54       State.runState (createLibraryUnits binds) init_session
  55     tyfun_decls = map snd $ Map.elems (final_session ^. vsType ^. vsTypeFuns)
  56     ty_decls = final_session ^. vsType ^. vsTypeDecls
  57     tfvec_index_decl = AST.PDISD $ AST.SubtypeDec tfvec_indexTM tfvec_index_def
  58     tfvec_range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit "-1") (AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerTM) highId Nothing)
  59     tfvec_index_def = AST.SubtypeIn integerTM (Just tfvec_range)
  60     ieee_context = [
  61         AST.Library $ mkVHDLBasicId "IEEE",
  62         mkUseAll ["IEEE", "std_logic_1164"],
  63         mkUseAll ["IEEE", "numeric_std"]
  64       ]
  65     full_context =
  66       mkUseAll ["work", "types"]
  67       : (mkUseAll ["work"]
  68       : ieee_context)
  69     type_package_dec = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") ([tfvec_index_decl] ++ ty_decls ++ subProgSpecs)
  70     type_package_body = AST.LUPackageBody $ AST.PackageBody typesId tyfun_decls
  71     subProgSpecs = map subProgSpec tyfun_decls
  72     subProgSpec = \(AST.SubProgBody spec _ _) -> AST.PDISS spec
  73
  74 -- Create a use foo.bar.all statement. Takes a list of components in the used
  75 -- name. Must contain at least two components
  76 mkUseAll :: [String] -> AST.ContextItem
  77 mkUseAll ss =
  78   AST.Use $ from AST.:.: AST.All
  79   where
  80     base_prefix = (AST.NSimple $ mkVHDLBasicId $ head ss)
  81     from = foldl select base_prefix (tail ss)
  82     select prefix s = AST.NSelected $ prefix AST.:.: (AST.SSimple $ mkVHDLBasicId s)
  83
  84 createLibraryUnits ::
  85   [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
  86   -> VHDLSession [(AST.VHDLId, [AST.LibraryUnit])]
  87
  88 createLibraryUnits binds = do
  89   entities <- Monad.mapM createEntity binds
  90   archs <- Monad.mapM createArchitecture binds
  91   return $ zipWith
  92     (\ent arch ->
  93       let AST.EntityDec id _ = ent in
  94       (id, [AST.LUEntity ent, AST.LUArch arch])
  95     )
  96     entities archs
  97
  98 -- | Create an entity for a given function
  99 createEntity ::
 100   (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- | The function
 101   -> VHDLSession AST.EntityDec -- | The resulting entity
 102
 103 createEntity (fname, expr) = do
 104       -- Strip off lambda's, these will be arguments
 105       let (args, letexpr) = CoreSyn.collectBinders expr
 106       args' <- Monad.mapM mkMap args
 107       -- There must be a let at top level
 108       let (CoreSyn.Let binds (CoreSyn.Var res)) = letexpr
 109       res' <- mkMap res
 110       let vhdl_id = mkVHDLBasicId $ varToString fname ++ "_" ++ varToStringUniq fname
 111       let ent_decl' = createEntityAST vhdl_id args' res'
 112       let AST.EntityDec entity_id _ = ent_decl'
 113       let signature = Entity entity_id args' res'
 114       modA vsSignatures (Map.insert fname signature)
 115       return ent_decl'
 116   where
 117     mkMap ::
 118       --[(SignalId, SignalInfo)]
 119       CoreSyn.CoreBndr
 120       -> VHDLSession Port
 121     -- We only need the vsTypes element from the state
 122     mkMap = (\bndr ->
 123       let
 124         --info = Maybe.fromMaybe
 125         --  (error $ "Signal not found in the name map? This should not happen!")
 126         --  (lookup id sigmap)
 127         --  Assume the bndr has a valid VHDL id already
 128         id = varToVHDLId bndr
 129         ty = Var.varType bndr
 130         error_msg = "\nVHDL.createEntity.mkMap: Can not create entity: " ++ pprString fname ++ "\nbecause no type can be created for port: " ++ pprString bndr
 131       in do
 132         type_mark <- MonadState.lift vsType $ vhdl_ty error_msg ty
 133         return (id, type_mark)
 134      )
 135
 136   -- | Create the VHDL AST for an entity
 137 createEntityAST ::
 138   AST.VHDLId                   -- | The name of the function
 139   -> [Port]                    -- | The entity's arguments
 140   -> Port                      -- | The entity's result
 141   -> AST.EntityDec             -- | The entity with the ent_decl filled in as well
 142
 143 createEntityAST vhdl_id args res =
 144   AST.EntityDec vhdl_id ports
 145   where
 146     -- Create a basic Id, since VHDL doesn't grok filenames with extended Ids.
 147     ports = map (mkIfaceSigDec AST.In) args
 148               ++ [mkIfaceSigDec AST.Out res]
 149               ++ [clk_port]
 150     -- Add a clk port if we have state
 151     clk_port = AST.IfaceSigDec (mkVHDLExtId "clk") AST.In std_logicTM
 152
 153 -- | Create a port declaration
 154 mkIfaceSigDec ::
 155   AST.Mode                         -- | The mode for the port (In / Out)
 156   -> (AST.VHDLId, AST.TypeMark)    -- | The id and type for the port
 157   -> AST.IfaceSigDec               -- | The resulting port declaration
 158
 159 mkIfaceSigDec mode (id, ty) = AST.IfaceSigDec id mode ty
 160
 161 {-
 162 -- | Generate a VHDL entity name for the given hsfunc
 163 mkEntityId hsfunc =
 164   -- TODO: This doesn't work for functions with multiple signatures!
 165   -- Use a Basic Id, since using extended id's for entities throws off
 166   -- precision and causes problems when generating filenames.
 167   mkVHDLBasicId $ hsFuncName hsfunc
 168 -}
 169
 170 -- | Create an architecture for a given function
 171 createArchitecture ::
 172   (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The function
 173   -> VHDLSession AST.ArchBody -- ^ The architecture for this function
 174
 175 createArchitecture (fname, expr) = do
 176   signaturemap <- getA vsSignatures
 177   let signature = Maybe.fromMaybe
 178         (error $ "\nVHDL.createArchitecture: Generating architecture for function \n" ++ (pprString fname) ++ "\nwithout signature? This should not happen!")
 179         (Map.lookup fname signaturemap)
 180   let entity_id = ent_id signature
 181   -- Strip off lambda's, these will be arguments
 182   let (args, letexpr) = CoreSyn.collectBinders expr
 183   -- There must be a let at top level
 184   let (CoreSyn.Let (CoreSyn.Rec binds) (Var res)) = letexpr
 185
 186   -- Create signal declarations for all binders in the let expression, except
 187   -- for the output port (that will already have an output port declared in
 188   -- the entity).
 189   sig_dec_maybes <- mapM (mkSigDec' . fst) (filter ((/=res).fst) binds)
 190   let sig_decs = Maybe.catMaybes $ sig_dec_maybes
 191
 192   statementss <- Monad.mapM mkConcSm binds
 193   let statements = concat statementss
 194   return $ AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
 195   where
 196     procs = [] --map mkStateProcSm [] -- (makeStatePairs flatfunc)
 197     procs' = map AST.CSPSm procs
 198     -- mkSigDec only uses vsTypes from the state
 199     mkSigDec' = mkSigDec
 200
 201 {-
 202 -- | Looks up all pairs of old state, new state signals, together with
 203 --   the state id they represent.
 204 makeStatePairs :: FlatFunction -> [(StateId, SignalInfo, SignalInfo)]
 205 makeStatePairs flatfunc =
 206   [(Maybe.fromJust $ oldStateId $ sigUse old_info, old_info, new_info)
 207     | old_info <- map snd (flat_sigs flatfunc)
 208     , new_info <- map snd (flat_sigs flatfunc)
 209         -- old_info must be an old state (and, because of the next equality,
 210         -- new_info must be a new state).
 211         , Maybe.isJust $ oldStateId $ sigUse old_info
 212         -- And the state numbers must match
 213     , (oldStateId $ sigUse old_info) == (newStateId $ sigUse new_info)]
 214
 215     -- Replace the second tuple element with the corresponding SignalInfo
 216     --args_states = map (Arrow.second $ signalInfo sigs) args
 217 mkStateProcSm :: (StateId, SignalInfo, SignalInfo) -> AST.ProcSm
 218 mkStateProcSm (num, old, new) =
 219   AST.ProcSm label [clk] [statement]
 220   where
 221     label       = mkVHDLExtId $ "state_" ++ (show num)
 222     clk         = mkVHDLExtId "clk"
 223     rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
 224     wform       = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple $ getSignalId new) Nothing]
 225     assign      = AST.SigAssign (AST.NSimple $ getSignalId old) wform
 226     rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
 227     statement   = AST.IfSm rising_edge_clk [assign] [] Nothing
 228
 229 -- | Creates a VHDL Id from a named SignalInfo. Errors out if the SignalInfo
 230 --   is not named.
 231 getSignalId :: SignalInfo -> AST.VHDLId
 232 getSignalId info =
 233   mkVHDLExtId $ Maybe.fromMaybe
 234     (error $ "Unnamed signal? This should not happen!")
 235     (sigName info)
 236 -}
 237
 238 mkSigDec :: CoreSyn.CoreBndr -> VHDLSession (Maybe AST.SigDec)
 239 mkSigDec bndr =
 240   if True then do --isInternalSigUse use || isStateSigUse use then do
 241     let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString bndr
 242     type_mark <- MonadState.lift vsType $ vhdl_ty error_msg (Var.varType bndr)
 243     return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing)
 244   else
 245     return Nothing
 246
 247 -- | Transforms a core binding into a VHDL concurrent statement
 248 mkConcSm ::
 249   (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The binding to process
 250   -> VHDLSession [AST.ConcSm] -- ^ The corresponding VHDL component instantiations.
 251
 252
 253 -- Ignore Cast expressions, they should not longer have any meaning as long as
 254 -- the type works out.
 255 mkConcSm (bndr, Cast expr ty) = mkConcSm (bndr, expr)
 256
 257 -- Simple a = b assignments are just like applications, but without arguments.
 258 -- We can't just generate an unconditional assignment here, since b might be a
 259 -- top level binding (e.g., a function with no arguments).
 260 mkConcSm (bndr, Var v) = do
 261   genApplication (Left bndr) v []
 262
 263 mkConcSm (bndr, app@(CoreSyn.App _ _))= do
 264   let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
 265   let valargs = get_val_args (Var.varType f) args
 266   genApplication (Left bndr) f (map Left valargs)
 267
 268 -- A single alt case must be a selector. This means thee scrutinee is a simple
 269 -- variable, the alternative is a dataalt with a single non-wild binder that
 270 -- is also returned.
 271 mkConcSm (bndr, expr@(Case (Var scrut) b ty [alt])) =
 272   case alt of
 273     (DataAlt dc, bndrs, (Var sel_bndr)) -> do
 274       case List.elemIndex sel_bndr bndrs of
 275         Just i -> do
 276           labels <- MonadState.lift vsType $ getFieldLabels (Id.idType scrut)
 277           let label = labels!!i
 278           let sel_name = mkSelectedName (varToVHDLName scrut) label
 279           let sel_expr = AST.PrimName sel_name
 280           return [mkUncondAssign (Left bndr) sel_expr]
 281         Nothing -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
 282
 283     _ -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
 284
 285 -- Multiple case alt are be conditional assignments and have only wild
 286 -- binders in the alts and only variables in the case values and a variable
 287 -- for a scrutinee. We check the constructor of the second alt, since the
 288 -- first is the default case, if there is any.
 289 mkConcSm (bndr, (Case (Var scrut) b ty [(_, _, Var false), (con, _, Var true)])) = do
 290   scrut' <- MonadState.lift vsType $ varToVHDLExpr scrut
 291   let cond_expr = scrut' AST.:=: (altconToVHDLExpr con)
 292   true_expr <- MonadState.lift vsType $ varToVHDLExpr true
 293   false_expr <- MonadState.lift vsType $ varToVHDLExpr false
 294   return [mkCondAssign (Left bndr) cond_expr true_expr false_expr]
 295
 296 mkConcSm (_, (Case (Var _) _ _ alts)) = error "\nVHDL.mkConcSm: Not in normal form: Case statement with more than two alternatives"
 297 mkConcSm (_, Case _ _ _ _) = error "\nVHDL.mkConcSm: Not in normal form: Case statement has does not have a simple variable as scrutinee"
 298 mkConcSm (bndr, expr) = error $ "\nVHDL.mkConcSM: Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr