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 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 = map mktydecl $ Map.elems (final_session ^. vsTypes)
  55     vec_decls = map (\(v_id, v_def) -> AST.PDITD $ AST.TypeDec v_id v_def) (Map.elems (final_session ^. vsElemTypes))
  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] ++ vec_decls ++ 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     mktydecl :: (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn) -> AST.PackageDecItem
  73     mktydecl (ty_id, Left ty_def) = AST.PDITD $ AST.TypeDec ty_id ty_def
  74     mktydecl (ty_id, Right ty_def) = AST.PDISD $ AST.SubtypeDec ty_id ty_def
  75
  76 -- Create a use foo.bar.all statement. Takes a list of components in the used
  77 -- name. Must contain at least two components
  78 mkUseAll :: [String] -> AST.ContextItem
  79 mkUseAll ss =
  80   AST.Use $ from AST.:.: AST.All
  81   where
  82     base_prefix = (AST.NSimple $ mkVHDLBasicId $ head ss)
  83     from = foldl select base_prefix (tail ss)
  84     select prefix s = AST.NSelected $ prefix AST.:.: (AST.SSimple $ mkVHDLBasicId s)
  85
  86 createLibraryUnits ::
  87   [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
  88   -> VHDLSession [(AST.VHDLId, [AST.LibraryUnit])]
  89
  90 createLibraryUnits binds = do
  91   entities <- Monad.mapM createEntity binds
  92   archs <- Monad.mapM createArchitecture binds
  93   return $ zipWith
  94     (\ent arch ->
  95       let AST.EntityDec id _ = ent in
  96       (id, [AST.LUEntity ent, AST.LUArch arch])
  97     )
  98     entities archs
  99
 100 -- | Create an entity for a given function
 101 createEntity ::
 102   (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- | The function
 103   -> VHDLSession AST.EntityDec -- | The resulting entity
 104
 105 createEntity (fname, expr) = do
 106       -- Strip off lambda's, these will be arguments
 107       let (args, letexpr) = CoreSyn.collectBinders expr
 108       args' <- Monad.mapM mkMap args
 109       -- There must be a let at top level
 110       let (CoreSyn.Let binds (CoreSyn.Var res)) = letexpr
 111       res' <- mkMap res
 112       let vhdl_id = mkVHDLBasicId $ varToString fname ++ "_" ++ varToStringUniq fname
 113       let ent_decl' = createEntityAST vhdl_id args' res'
 114       let AST.EntityDec entity_id _ = ent_decl'
 115       let signature = Entity entity_id args' res'
 116       modA vsSignatures (Map.insert fname signature)
 117       return ent_decl'
 118   where
 119     mkMap ::
 120       --[(SignalId, SignalInfo)]
 121       CoreSyn.CoreBndr
 122       -> VHDLSession Port
 123     -- We only need the vsTypes element from the state
 124     mkMap = (\bndr ->
 125       let
 126         --info = Maybe.fromMaybe
 127         --  (error $ "Signal not found in the name map? This should not happen!")
 128         --  (lookup id sigmap)
 129         --  Assume the bndr has a valid VHDL id already
 130         id = varToVHDLId bndr
 131         ty = Var.varType bndr
 132       in do
 133         type_mark <- vhdl_ty ty
 134         return (id, type_mark)
 135      )
 136
 137   -- | Create the VHDL AST for an entity
 138 createEntityAST ::
 139   AST.VHDLId                   -- | The name of the function
 140   -> [Port]                    -- | The entity's arguments
 141   -> Port                      -- | The entity's result
 142   -> AST.EntityDec             -- | The entity with the ent_decl filled in as well
 143
 144 createEntityAST vhdl_id args res =
 145   AST.EntityDec vhdl_id ports
 146   where
 147     -- Create a basic Id, since VHDL doesn't grok filenames with extended Ids.
 148     ports = map (mkIfaceSigDec AST.In) args
 149               ++ [mkIfaceSigDec AST.Out res]
 150               ++ [clk_port]
 151     -- Add a clk port if we have state
 152     clk_port = AST.IfaceSigDec (mkVHDLExtId "clk") AST.In std_logicTM
 153
 154 -- | Create a port declaration
 155 mkIfaceSigDec ::
 156   AST.Mode                         -- | The mode for the port (In / Out)
 157   -> (AST.VHDLId, AST.TypeMark)    -- | The id and type for the port
 158   -> AST.IfaceSigDec               -- | The resulting port declaration
 159
 160 mkIfaceSigDec mode (id, ty) = AST.IfaceSigDec id mode ty
 161
 162 {-
 163 -- | Generate a VHDL entity name for the given hsfunc
 164 mkEntityId hsfunc =
 165   -- TODO: This doesn't work for functions with multiple signatures!
 166   -- Use a Basic Id, since using extended id's for entities throws off
 167   -- precision and causes problems when generating filenames.
 168   mkVHDLBasicId $ hsFuncName hsfunc
 169 -}
 170
 171 -- | Create an architecture for a given function
 172 createArchitecture ::
 173   (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The function
 174   -> VHDLSession AST.ArchBody -- ^ The architecture for this function
 175
 176 createArchitecture (fname, expr) = do
 177   signaturemap <- getA vsSignatures
 178   let signature = Maybe.fromMaybe
 179         (error $ "Generating architecture for function " ++ (pprString fname) ++ "without signature? This should not happen!")
 180         (Map.lookup fname signaturemap)
 181   let entity_id = ent_id signature
 182   -- Strip off lambda's, these will be arguments
 183   let (args, letexpr) = CoreSyn.collectBinders expr
 184   -- There must be a let at top level
 185   let (CoreSyn.Let (CoreSyn.Rec binds) (Var res)) = letexpr
 186
 187   -- Create signal declarations for all binders in the let expression, except
 188   -- for the output port (that will already have an output port declared in
 189   -- the entity).
 190   sig_dec_maybes <- mapM (mkSigDec' . fst) (filter ((/=res).fst) binds)
 191   let sig_decs = Maybe.catMaybes $ sig_dec_maybes
 192
 193   statementss <- Monad.mapM mkConcSm binds
 194   let statements = concat statementss
 195   return $ AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
 196   where
 197     procs = [] --map mkStateProcSm [] -- (makeStatePairs flatfunc)
 198     procs' = map AST.CSPSm procs
 199     -- mkSigDec only uses vsTypes from the state
 200     mkSigDec' = mkSigDec
 201
 202 {-
 203 -- | Looks up all pairs of old state, new state signals, together with
 204 --   the state id they represent.
 205 makeStatePairs :: FlatFunction -> [(StateId, SignalInfo, SignalInfo)]
 206 makeStatePairs flatfunc =
 207   [(Maybe.fromJust $ oldStateId $ sigUse old_info, old_info, new_info)
 208     | old_info <- map snd (flat_sigs flatfunc)
 209     , new_info <- map snd (flat_sigs flatfunc)
 210         -- old_info must be an old state (and, because of the next equality,
 211         -- new_info must be a new state).
 212         , Maybe.isJust $ oldStateId $ sigUse old_info
 213         -- And the state numbers must match
 214     , (oldStateId $ sigUse old_info) == (newStateId $ sigUse new_info)]
 215
 216     -- Replace the second tuple element with the corresponding SignalInfo
 217     --args_states = map (Arrow.second $ signalInfo sigs) args
 218 mkStateProcSm :: (StateId, SignalInfo, SignalInfo) -> AST.ProcSm
 219 mkStateProcSm (num, old, new) =
 220   AST.ProcSm label [clk] [statement]
 221   where
 222     label       = mkVHDLExtId $ "state_" ++ (show num)
 223     clk         = mkVHDLExtId "clk"
 224     rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
 225     wform       = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple $ getSignalId new) Nothing]
 226     assign      = AST.SigAssign (AST.NSimple $ getSignalId old) wform
 227     rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
 228     statement   = AST.IfSm rising_edge_clk [assign] [] Nothing
 229
 230 -- | Creates a VHDL Id from a named SignalInfo. Errors out if the SignalInfo
 231 --   is not named.
 232 getSignalId :: SignalInfo -> AST.VHDLId
 233 getSignalId info =
 234   mkVHDLExtId $ Maybe.fromMaybe
 235     (error $ "Unnamed signal? This should not happen!")
 236     (sigName info)
 237 -}
 238
 239 mkSigDec :: CoreSyn.CoreBndr -> VHDLSession (Maybe AST.SigDec)
 240 mkSigDec bndr =
 241   if True then do --isInternalSigUse use || isStateSigUse use then do
 242     type_mark <- vhdl_ty $ 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 -- For simple a = b assignments, just generate an unconditional signal
 258 -- assignment. This should only happen for dataconstructors without arguments.
 259 -- TODO: Integrate this with the below code for application (essentially this
 260 -- is an application without arguments)
 261 mkConcSm (bndr, Var v) = return $ [mkUncondAssign (Left bndr) (varToVHDLExpr 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 <- 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 $ "VHDL.mkConcSM Not in normal form: Not a selector case:\n" ++ (pprString expr)
 282
 283     _ -> error $ "VHDL.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)])) =
 290   let
 291     cond_expr = (varToVHDLExpr scrut) AST.:=: (altconToVHDLExpr con)
 292     true_expr  = (varToVHDLExpr true)
 293     false_expr  = (varToVHDLExpr false)
 294   in
 295     return [mkCondAssign (Left bndr) cond_expr true_expr false_expr]
 296 mkConcSm (_, (Case (Var _) _ _ alts)) = error "VHDL.mkConcSm Not in normal form: Case statement with more than two alternatives"
 297 mkConcSm (_, Case _ _ _ _) = error "VHDL.mkConcSm Not in normal form: Case statement has does not have a simple variable as scrutinee"
 298 mkConcSm (bndr, expr) = error $ "VHDL.mkConcSM Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr