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 = 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] ++ 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         error_msg = "\nVHDL.createEntity.mkMap: Can not create entity: " ++ pprString fname ++ "\nbecause no type can be created for port: " ++ pprString bndr
 133       in do
 134         type_mark <- vhdl_ty error_msg ty
 135         return (id, type_mark)
 136      )
 137
 138   -- | Create the VHDL AST for an entity
 139 createEntityAST ::
 140   AST.VHDLId                   -- | The name of the function
 141   -> [Port]                    -- | The entity's arguments
 142   -> Port                      -- | The entity's result
 143   -> AST.EntityDec             -- | The entity with the ent_decl filled in as well
 144
 145 createEntityAST vhdl_id args res =
 146   AST.EntityDec vhdl_id ports
 147   where
 148     -- Create a basic Id, since VHDL doesn't grok filenames with extended Ids.
 149     ports = map (mkIfaceSigDec AST.In) args
 150               ++ [mkIfaceSigDec AST.Out res]
 151               ++ [clk_port]
 152     -- Add a clk port if we have state
 153     clk_port = AST.IfaceSigDec (mkVHDLExtId "clk") AST.In std_logicTM
 154
 155 -- | Create a port declaration
 156 mkIfaceSigDec ::
 157   AST.Mode                         -- | The mode for the port (In / Out)
 158   -> (AST.VHDLId, AST.TypeMark)    -- | The id and type for the port
 159   -> AST.IfaceSigDec               -- | The resulting port declaration
 160
 161 mkIfaceSigDec mode (id, ty) = AST.IfaceSigDec id mode ty
 162
 163 {-
 164 -- | Generate a VHDL entity name for the given hsfunc
 165 mkEntityId hsfunc =
 166   -- TODO: This doesn't work for functions with multiple signatures!
 167   -- Use a Basic Id, since using extended id's for entities throws off
 168   -- precision and causes problems when generating filenames.
 169   mkVHDLBasicId $ hsFuncName hsfunc
 170 -}
 171
 172 -- | Create an architecture for a given function
 173 createArchitecture ::
 174   (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The function
 175   -> VHDLSession AST.ArchBody -- ^ The architecture for this function
 176
 177 createArchitecture (fname, expr) = do
 178   signaturemap <- getA vsSignatures
 179   let signature = Maybe.fromMaybe
 180         (error $ "\nVHDL.createArchitecture: Generating architecture for function \n" ++ (pprString fname) ++ "\nwithout signature? This should not happen!")
 181         (Map.lookup fname signaturemap)
 182   let entity_id = ent_id signature
 183   -- Strip off lambda's, these will be arguments
 184   let (args, letexpr) = CoreSyn.collectBinders expr
 185   -- There must be a let at top level
 186   let (CoreSyn.Let (CoreSyn.Rec binds) (Var res)) = letexpr
 187
 188   -- Create signal declarations for all binders in the let expression, except
 189   -- for the output port (that will already have an output port declared in
 190   -- the entity).
 191   sig_dec_maybes <- mapM (mkSigDec' . fst) (filter ((/=res).fst) binds)
 192   let sig_decs = Maybe.catMaybes $ sig_dec_maybes
 193
 194   statementss <- Monad.mapM mkConcSm binds
 195   let statements = concat statementss
 196   return $ AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
 197   where
 198     procs = [] --map mkStateProcSm [] -- (makeStatePairs flatfunc)
 199     procs' = map AST.CSPSm procs
 200     -- mkSigDec only uses vsTypes from the state
 201     mkSigDec' = mkSigDec
 202
 203 {-
 204 -- | Looks up all pairs of old state, new state signals, together with
 205 --   the state id they represent.
 206 makeStatePairs :: FlatFunction -> [(StateId, SignalInfo, SignalInfo)]
 207 makeStatePairs flatfunc =
 208   [(Maybe.fromJust $ oldStateId $ sigUse old_info, old_info, new_info)
 209     | old_info <- map snd (flat_sigs flatfunc)
 210     , new_info <- map snd (flat_sigs flatfunc)
 211         -- old_info must be an old state (and, because of the next equality,
 212         -- new_info must be a new state).
 213         , Maybe.isJust $ oldStateId $ sigUse old_info
 214         -- And the state numbers must match
 215     , (oldStateId $ sigUse old_info) == (newStateId $ sigUse new_info)]
 216
 217     -- Replace the second tuple element with the corresponding SignalInfo
 218     --args_states = map (Arrow.second $ signalInfo sigs) args
 219 mkStateProcSm :: (StateId, SignalInfo, SignalInfo) -> AST.ProcSm
 220 mkStateProcSm (num, old, new) =
 221   AST.ProcSm label [clk] [statement]
 222   where
 223     label       = mkVHDLExtId $ "state_" ++ (show num)
 224     clk         = mkVHDLExtId "clk"
 225     rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
 226     wform       = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple $ getSignalId new) Nothing]
 227     assign      = AST.SigAssign (AST.NSimple $ getSignalId old) wform
 228     rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
 229     statement   = AST.IfSm rising_edge_clk [assign] [] Nothing
 230
 231 -- | Creates a VHDL Id from a named SignalInfo. Errors out if the SignalInfo
 232 --   is not named.
 233 getSignalId :: SignalInfo -> AST.VHDLId
 234 getSignalId info =
 235   mkVHDLExtId $ Maybe.fromMaybe
 236     (error $ "Unnamed signal? This should not happen!")
 237     (sigName info)
 238 -}
 239
 240 mkSigDec :: CoreSyn.CoreBndr -> VHDLSession (Maybe AST.SigDec)
 241 mkSigDec bndr =
 242   if True then do --isInternalSigUse use || isStateSigUse use then do
 243     let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString bndr
 244     type_mark <- (vhdl_ty error_msg) $ Var.varType bndr
 245     return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing)
 246   else
 247     return Nothing
 248
 249 -- | Transforms a core binding into a VHDL concurrent statement
 250 mkConcSm ::
 251   (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The binding to process
 252   -> VHDLSession [AST.ConcSm] -- ^ The corresponding VHDL component instantiations.
 253
 254
 255 -- Ignore Cast expressions, they should not longer have any meaning as long as
 256 -- the type works out.
 257 mkConcSm (bndr, Cast expr ty) = mkConcSm (bndr, expr)
 258
 259 -- For simple a = b assignments, just generate an unconditional signal
 260 -- assignment. This should only happen for dataconstructors without arguments.
 261 -- TODO: Integrate this with the below code for application (essentially this
 262 -- is an application without arguments)
 263 mkConcSm (bndr, Var v) = return $ [mkUncondAssign (Left bndr) (varToVHDLExpr v)]
 264
 265 mkConcSm (bndr, app@(CoreSyn.App _ _))= do
 266   let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
 267   let valargs = get_val_args (Var.varType f) args
 268   genApplication (Left bndr) f (map Left valargs)
 269
 270 -- A single alt case must be a selector. This means thee scrutinee is a simple
 271 -- variable, the alternative is a dataalt with a single non-wild binder that
 272 -- is also returned.
 273 mkConcSm (bndr, expr@(Case (Var scrut) b ty [alt])) =
 274   case alt of
 275     (DataAlt dc, bndrs, (Var sel_bndr)) -> do
 276       case List.elemIndex sel_bndr bndrs of
 277         Just i -> do
 278           labels <- getFieldLabels (Id.idType scrut)
 279           let label = labels!!i
 280           let sel_name = mkSelectedName (varToVHDLName scrut) label
 281           let sel_expr = AST.PrimName sel_name
 282           return [mkUncondAssign (Left bndr) sel_expr]
 283         Nothing -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
 284
 285     _ -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
 286
 287 -- Multiple case alt are be conditional assignments and have only wild
 288 -- binders in the alts and only variables in the case values and a variable
 289 -- for a scrutinee. We check the constructor of the second alt, since the
 290 -- first is the default case, if there is any.
 291 mkConcSm (bndr, (Case (Var scrut) b ty [(_, _, Var false), (con, _, Var true)])) =
 292   let
 293     cond_expr = (varToVHDLExpr scrut) AST.:=: (altconToVHDLExpr con)
 294     true_expr  = (varToVHDLExpr true)
 295     false_expr  = (varToVHDLExpr false)
 296   in
 297     return [mkCondAssign (Left bndr) cond_expr true_expr false_expr]
 298 mkConcSm (_, (Case (Var _) _ _ alts)) = error "\nVHDL.mkConcSm: Not in normal form: Case statement with more than two alternatives"
 299 mkConcSm (_, Case _ _ _ _) = error "\nVHDL.mkConcSm: Not in normal form: Case statement has does not have a simple variable as scrutinee"
 300 mkConcSm (bndr, expr) = error $ "\nVHDL.mkConcSM: Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr