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