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 import GlobalNameTable
  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 Map.empty Map.empty Map.empty Map.empty
  52     (units, final_session) =
  53       State.runState (createLibraryUnits binds) init_session
  54     tyfun_decls = map snd $ Map.elems (final_session ^.vsTypeFuns)
  55     ty_decls = map mktydecl $ Map.elems (final_session ^. vsTypes)
  56     vec_decls = map (\(v_id, v_def) -> AST.PDITD $ AST.TypeDec v_id v_def) (Map.elems (final_session ^. vsElemTypes))
  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] ++ vec_decls ++ 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     mktydecl :: (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn) -> AST.PackageDecItem
  74     mktydecl (ty_id, Left ty_def) = AST.PDITD $ AST.TypeDec ty_id ty_def
  75     mktydecl (ty_id, Right ty_def) = AST.PDISD $ AST.SubtypeDec ty_id ty_def
  76
  77 -- Create a use foo.bar.all statement. Takes a list of components in the used
  78 -- name. Must contain at least two components
  79 mkUseAll :: [String] -> AST.ContextItem
  80 mkUseAll ss =
  81   AST.Use $ from AST.:.: AST.All
  82   where
  83     base_prefix = (AST.NSimple $ mkVHDLBasicId $ head ss)
  84     from = foldl select base_prefix (tail ss)
  85     select prefix s = AST.NSelected $ prefix AST.:.: (AST.SSimple $ mkVHDLBasicId s)
  86
  87 createLibraryUnits ::
  88   [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
  89   -> VHDLSession [(AST.VHDLId, [AST.LibraryUnit])]
  90
  91 createLibraryUnits binds = do
  92   entities <- Monad.mapM createEntity binds
  93   archs <- Monad.mapM createArchitecture binds
  94   return $ zipWith
  95     (\ent arch ->
  96       let AST.EntityDec id _ = ent in
  97       (id, [AST.LUEntity ent, AST.LUArch arch])
  98     )
  99     entities archs
 100
 101 -- | Create an entity for a given function
 102 createEntity ::
 103   (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- | The function
 104   -> VHDLSession AST.EntityDec -- | The resulting entity
 105
 106 createEntity (fname, expr) = do
 107       -- Strip off lambda's, these will be arguments
 108       let (args, letexpr) = CoreSyn.collectBinders expr
 109       args' <- Monad.mapM mkMap args
 110       -- There must be a let at top level
 111       let (CoreSyn.Let binds (CoreSyn.Var res)) = letexpr
 112       res' <- mkMap res
 113       let vhdl_id = mkVHDLBasicId $ varToString fname ++ "_" ++ varToStringUniq fname
 114       let ent_decl' = createEntityAST vhdl_id args' res'
 115       let AST.EntityDec entity_id _ = ent_decl'
 116       let signature = Entity entity_id args' res'
 117       modA vsSignatures (Map.insert fname signature)
 118       return ent_decl'
 119   where
 120     mkMap ::
 121       --[(SignalId, SignalInfo)]
 122       CoreSyn.CoreBndr
 123       -> VHDLSession VHDLSignalMapElement
 124     -- We only need the vsTypes element from the state
 125     mkMap = (\bndr ->
 126       let
 127         --info = Maybe.fromMaybe
 128         --  (error $ "Signal not found in the name map? This should not happen!")
 129         --  (lookup id sigmap)
 130         --  Assume the bndr has a valid VHDL id already
 131         id = varToVHDLId bndr
 132         ty = Var.varType bndr
 133       in
 134         if True -- isPortSigUse $ sigUse info
 135           then do
 136             type_mark <- vhdl_ty ty
 137             return $ Just (id, type_mark)
 138           else
 139             return $ Nothing
 140        )
 141
 142   -- | Create the VHDL AST for an entity
 143 createEntityAST ::
 144   AST.VHDLId                   -- | The name of the function
 145   -> [VHDLSignalMapElement]    -- | The entity's arguments
 146   -> VHDLSignalMapElement      -- | 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 = Maybe.catMaybes $
 154               map (mkIfaceSigDec AST.In) args
 155               ++ [mkIfaceSigDec AST.Out res]
 156               ++ [clk_port]
 157     -- Add a clk port if we have state
 158     clk_port = if True -- hasState hsfunc
 159       then
 160         Just $ AST.IfaceSigDec (mkVHDLExtId "clk") AST.In std_logicTM
 161       else
 162         Nothing
 163
 164 -- | Create a port declaration
 165 mkIfaceSigDec ::
 166   AST.Mode                         -- | The mode for the port (In / Out)
 167   -> Maybe (AST.VHDLId, AST.TypeMark)    -- | The id and type for the port
 168   -> Maybe AST.IfaceSigDec               -- | The resulting port declaration
 169
 170 mkIfaceSigDec mode (Just (id, ty)) = Just $ AST.IfaceSigDec id mode ty
 171 mkIfaceSigDec _ Nothing = Nothing
 172
 173 {-
 174 -- | Generate a VHDL entity name for the given hsfunc
 175 mkEntityId hsfunc =
 176   -- TODO: This doesn't work for functions with multiple signatures!
 177   -- Use a Basic Id, since using extended id's for entities throws off
 178   -- precision and causes problems when generating filenames.
 179   mkVHDLBasicId $ hsFuncName hsfunc
 180 -}
 181
 182 -- | Create an architecture for a given function
 183 createArchitecture ::
 184   (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The function
 185   -> VHDLSession AST.ArchBody -- ^ The architecture for this function
 186
 187 createArchitecture (fname, expr) = do
 188   signaturemap <- getA vsSignatures
 189   let signature = Maybe.fromMaybe
 190         (error $ "Generating architecture for function " ++ (pprString fname) ++ "without signature? This should not happen!")
 191         (Map.lookup fname signaturemap)
 192   let entity_id = ent_id signature
 193   -- Strip off lambda's, these will be arguments
 194   let (args, letexpr) = CoreSyn.collectBinders expr
 195   -- There must be a let at top level
 196   let (CoreSyn.Let (CoreSyn.Rec binds) (Var res)) = letexpr
 197
 198   -- Create signal declarations for all binders in the let expression, except
 199   -- for the output port (that will already have an output port declared in
 200   -- the entity).
 201   sig_dec_maybes <- mapM (mkSigDec' . fst) (filter ((/=res).fst) binds)
 202   let sig_decs = Maybe.catMaybes $ sig_dec_maybes
 203
 204   statementss <- Monad.mapM mkConcSm binds
 205   let statements = concat statementss
 206   return $ AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
 207   where
 208     procs = [] --map mkStateProcSm [] -- (makeStatePairs flatfunc)
 209     procs' = map AST.CSPSm procs
 210     -- mkSigDec only uses vsTypes from the state
 211     mkSigDec' = mkSigDec
 212
 213 {-
 214 -- | Looks up all pairs of old state, new state signals, together with
 215 --   the state id they represent.
 216 makeStatePairs :: FlatFunction -> [(StateId, SignalInfo, SignalInfo)]
 217 makeStatePairs flatfunc =
 218   [(Maybe.fromJust $ oldStateId $ sigUse old_info, old_info, new_info)
 219     | old_info <- map snd (flat_sigs flatfunc)
 220     , new_info <- map snd (flat_sigs flatfunc)
 221         -- old_info must be an old state (and, because of the next equality,
 222         -- new_info must be a new state).
 223         , Maybe.isJust $ oldStateId $ sigUse old_info
 224         -- And the state numbers must match
 225     , (oldStateId $ sigUse old_info) == (newStateId $ sigUse new_info)]
 226
 227     -- Replace the second tuple element with the corresponding SignalInfo
 228     --args_states = map (Arrow.second $ signalInfo sigs) args
 229 mkStateProcSm :: (StateId, SignalInfo, SignalInfo) -> AST.ProcSm
 230 mkStateProcSm (num, old, new) =
 231   AST.ProcSm label [clk] [statement]
 232   where
 233     label       = mkVHDLExtId $ "state_" ++ (show num)
 234     clk         = mkVHDLExtId "clk"
 235     rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
 236     wform       = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple $ getSignalId new) Nothing]
 237     assign      = AST.SigAssign (AST.NSimple $ getSignalId old) wform
 238     rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
 239     statement   = AST.IfSm rising_edge_clk [assign] [] Nothing
 240
 241 -- | Creates a VHDL Id from a named SignalInfo. Errors out if the SignalInfo
 242 --   is not named.
 243 getSignalId :: SignalInfo -> AST.VHDLId
 244 getSignalId info =
 245   mkVHDLExtId $ Maybe.fromMaybe
 246     (error $ "Unnamed signal? This should not happen!")
 247     (sigName info)
 248 -}
 249
 250 mkSigDec :: CoreSyn.CoreBndr -> VHDLSession (Maybe AST.SigDec)
 251 mkSigDec bndr =
 252   if True then do --isInternalSigUse use || isStateSigUse use then do
 253     type_mark <- vhdl_ty $ Var.varType bndr
 254     return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing)
 255   else
 256     return Nothing
 257
 258 -- | Transforms a core binding into a VHDL concurrent statement
 259 mkConcSm ::
 260   (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The binding to process
 261   -> VHDLSession [AST.ConcSm] -- ^ The corresponding VHDL component instantiations.
 262
 263
 264 -- Ignore Cast expressions, they should not longer have any meaning as long as
 265 -- the type works out.
 266 mkConcSm (bndr, Cast expr ty) = mkConcSm (bndr, expr)
 267
 268 -- For simple a = b assignments, just generate an unconditional signal
 269 -- assignment. This should only happen for dataconstructors without arguments.
 270 -- TODO: Integrate this with the below code for application (essentially this
 271 -- is an application without arguments)
 272 mkConcSm (bndr, Var v) = return $ [mkUncondAssign (Left bndr) (varToVHDLExpr v)]
 273
 274 mkConcSm (bndr, app@(CoreSyn.App _ _))= do
 275   let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
 276   let valargs' = filter isValArg args
 277   let valargs = filter (\(CoreSyn.Var bndr) -> not (Id.isDictId bndr)) valargs'
 278   case Var.globalIdVarDetails f of
 279     IdInfo.DataConWorkId dc ->
 280         -- It's a datacon. Create a record from its arguments.
 281         -- First, filter out type args. TODO: Is this the best way to do this?
 282         -- The types should already have been taken into acocunt when creating
 283         -- the signal, so this should probably work...
 284         --let valargs = filter isValArg args in
 285         if all is_var valargs then do
 286           labels <- getFieldLabels (CoreUtils.exprType app)
 287           return $ zipWith mkassign labels valargs
 288         else
 289           error $ "VHDL.mkConcSm Not in normal form: One ore more complex arguments: " ++ pprString args
 290       where
 291         mkassign :: AST.VHDLId -> CoreExpr -> AST.ConcSm
 292         mkassign label (Var arg) =
 293           let sel_name = mkSelectedName bndr label in
 294           mkUncondAssign (Right sel_name) (varToVHDLExpr arg)
 295     IdInfo.VanillaGlobal -> do
 296       -- It's a global value imported from elsewhere. These can be builtin
 297       -- functions.
 298       signatures <- getA vsSignatures
 299       case (Map.lookup (varToString f) globalNameTable) of
 300         Just (arg_count, builder) ->
 301           if length valargs == arg_count then
 302             builder bndr f valargs
 303           else
 304             error $ "VHDL.mkConcSm Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ pprString valargs
 305         Nothing -> error $ "Using function from another module that is not a known builtin: " ++ pprString f
 306     IdInfo.NotGlobalId -> do
 307       signatures <- getA vsSignatures
 308       -- This is a local id, so it should be a function whose definition we
 309       -- have and which can be turned into a component instantiation.
 310       let
 311         signature = Maybe.fromMaybe
 312           (error $ "Using function '" ++ (varToString f) ++ "' without signature? This should not happen!")
 313           (Map.lookup f signatures)
 314         entity_id = ent_id signature
 315         label = "comp_ins_" ++ varToString bndr
 316         -- Add a clk port if we have state
 317         --clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
 318         --clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
 319         --portmaps = mkAssocElems sigs args res signature ++ (if hasState hsfunc then [clk_port] else [])
 320         portmaps = mkAssocElems args bndr signature
 321         in
 322           return [mkComponentInst label entity_id portmaps]
 323     details -> error $ "Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details
 324
 325 -- A single alt case must be a selector. This means thee scrutinee is a simple
 326 -- variable, the alternative is a dataalt with a single non-wild binder that
 327 -- is also returned.
 328 mkConcSm (bndr, expr@(Case (Var scrut) b ty [alt])) =
 329   case alt of
 330     (DataAlt dc, bndrs, (Var sel_bndr)) -> do
 331       case List.elemIndex sel_bndr bndrs of
 332         Just i -> do
 333           labels <- getFieldLabels (Id.idType scrut)
 334           let label = labels!!i
 335           let sel_name = mkSelectedName scrut label
 336           let sel_expr = AST.PrimName sel_name
 337           return [mkUncondAssign (Left bndr) sel_expr]
 338         Nothing -> error $ "VHDL.mkConcSM Not in normal form: Not a selector case:\n" ++ (pprString expr)
 339
 340     _ -> error $ "VHDL.mkConcSM Not in normal form: Not a selector case:\n" ++ (pprString expr)
 341
 342 -- Multiple case alt are be conditional assignments and have only wild
 343 -- binders in the alts and only variables in the case values and a variable
 344 -- for a scrutinee. We check the constructor of the second alt, since the
 345 -- first is the default case, if there is any.
 346 mkConcSm (bndr, (Case (Var scrut) b ty [(_, _, Var false), (con, _, Var true)])) =
 347   let
 348     cond_expr = (varToVHDLExpr scrut) AST.:=: (altconToVHDLExpr con)
 349     true_expr  = (varToVHDLExpr true)
 350     false_expr  = (varToVHDLExpr false)
 351   in
 352     return [mkCondAssign (Left bndr) cond_expr true_expr false_expr]
 353 mkConcSm (_, (Case (Var _) _ _ alts)) = error "VHDL.mkConcSm Not in normal form: Case statement with more than two alternatives"
 354 mkConcSm (_, Case _ _ _ _) = error "VHDL.mkConcSm Not in normal form: Case statement has does not have a simple variable as scrutinee"
 355 mkConcSm (bndr, expr) = error $ "VHDL.mkConcSM Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr