VHDL.hs

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