VHDL.hs

   1 --
   2 -- Functions to generate VHDL from FlatFunctions
   3 --
   4 module VHDL where
   5
   6 -- Standard modules
   7 import qualified Data.Foldable as Foldable
   8 import qualified Data.List as List
   9 import qualified Data.Map as Map
  10 import qualified Maybe
  11 import qualified Control.Monad as Monad
  12 import qualified Control.Arrow as Arrow
  13 import qualified Control.Monad.Trans.State as State
  14 import qualified Data.Traversable as Traversable
  15 import qualified Data.Monoid as Monoid
  16 import Data.Accessor
  17 import qualified Data.Accessor.MonadState as MonadState
  18 import Text.Regex.Posix
  19 import Debug.Trace
  20
  21 -- ForSyDe
  22 import qualified ForSyDe.Backend.VHDL.AST as AST
  23
  24 -- GHC API
  25 import CoreSyn
  26 import qualified Type
  27 import qualified Name
  28 import qualified OccName
  29 import qualified Var
  30 import qualified Id
  31 import qualified TyCon
  32 import qualified DataCon
  33 import qualified CoreSubst
  34 import Outputable ( showSDoc, ppr )
  35
  36 -- Local imports
  37 import VHDLTypes
  38 import Flatten
  39 import FlattenTypes
  40 import TranslatorTypes
  41 import HsValueMap
  42 import Pretty
  43 import CoreTools
  44 import Constants
  45 import Generate
  46 import GlobalNameTable
  47
  48 createDesignFiles ::
  49   [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
  50   -> [(AST.VHDLId, AST.DesignFile)]
  51
  52 createDesignFiles binds =
  53   (mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package]) :
  54   map (Arrow.second $ AST.DesignFile full_context) units
  55
  56   where
  57     init_session = VHDLSession Map.empty Map.empty builtin_funcs globalNameTable
  58     (units, final_session) =
  59       State.runState (createLibraryUnits binds) init_session
  60     ty_decls = map (uncurry AST.TypeDec) $ Map.elems (final_session ^. vsTypes)
  61     ieee_context = [
  62         AST.Library $ mkVHDLBasicId "IEEE",
  63         mkUseAll ["IEEE", "std_logic_1164"],
  64         mkUseAll ["IEEE", "numeric_std"]
  65       ]
  66     full_context =
  67       mkUseAll ["work", "types"]
  68       : ieee_context
  69     type_package = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") (map AST.PDITD ty_decls)
  70
  71 -- Create a use foo.bar.all statement. Takes a list of components in the used
  72 -- name. Must contain at least two components
  73 mkUseAll :: [String] -> AST.ContextItem
  74 mkUseAll ss =
  75   AST.Use $ from AST.:.: AST.All
  76   where
  77     base_prefix = (AST.NSimple $ mkVHDLBasicId $ head ss)
  78     from = foldl select base_prefix (tail ss)
  79     select prefix s = AST.NSelected $ prefix AST.:.: (AST.SSimple $ mkVHDLBasicId s)
  80
  81 createLibraryUnits ::
  82   [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
  83   -> VHDLState [(AST.VHDLId, [AST.LibraryUnit])]
  84
  85 createLibraryUnits binds = do
  86   entities <- Monad.mapM createEntity binds
  87   archs <- Monad.mapM createArchitecture binds
  88   return $ zipWith
  89     (\ent arch ->
  90       let AST.EntityDec id _ = ent in
  91       (id, [AST.LUEntity ent, AST.LUArch arch])
  92     )
  93     entities archs
  94
  95 -- | Create an entity for a given function
  96 createEntity ::
  97   (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- | The function
  98   -> VHDLState AST.EntityDec -- | The resulting entity
  99
 100 createEntity (fname, expr) = do
 101       -- Strip off lambda's, these will be arguments
 102       let (args, letexpr) = CoreSyn.collectBinders expr
 103       args' <- Monad.mapM mkMap args
 104       -- There must be a let at top level
 105       let (CoreSyn.Let binds (CoreSyn.Var res)) = letexpr
 106       res' <- mkMap res
 107       let ent_decl' = createEntityAST fname args' res'
 108       let AST.EntityDec entity_id _ = ent_decl'
 109       let signature = Entity entity_id args' res'
 110       modA vsSignatures (Map.insert (bndrToString fname) signature)
 111       return ent_decl'
 112   where
 113     mkMap ::
 114       --[(SignalId, SignalInfo)]
 115       CoreSyn.CoreBndr
 116       -> VHDLState VHDLSignalMapElement
 117     -- We only need the vsTypes element from the state
 118     mkMap = (\bndr ->
 119       let
 120         --info = Maybe.fromMaybe
 121         --  (error $ "Signal not found in the name map? This should not happen!")
 122         --  (lookup id sigmap)
 123         --  Assume the bndr has a valid VHDL id already
 124         id = bndrToVHDLId bndr
 125         ty = Var.varType bndr
 126       in
 127         if True -- isPortSigUse $ sigUse info
 128           then do
 129             type_mark <- vhdl_ty ty
 130             return $ Just (id, type_mark)
 131           else
 132             return $ Nothing
 133        )
 134
 135   -- | Create the VHDL AST for an entity
 136 createEntityAST ::
 137   CoreSyn.CoreBndr             -- | The name of the function
 138   -> [VHDLSignalMapElement]    -- | The entity's arguments
 139   -> VHDLSignalMapElement      -- | The entity's result
 140   -> AST.EntityDec             -- | The entity with the ent_decl filled in as well
 141
 142 createEntityAST name 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     vhdl_id = mkVHDLBasicId $ bndrToString name
 147     ports = Maybe.catMaybes $
 148               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 = if True -- hasState hsfunc
 153       then
 154         Just $ AST.IfaceSigDec (mkVHDLExtId "clk") AST.In VHDL.std_logic_ty
 155       else
 156         Nothing
 157
 158 -- | Create a port declaration
 159 mkIfaceSigDec ::
 160   AST.Mode                         -- | The mode for the port (In / Out)
 161   -> Maybe (AST.VHDLId, AST.TypeMark)    -- | The id and type for the port
 162   -> Maybe AST.IfaceSigDec               -- | The resulting port declaration
 163
 164 mkIfaceSigDec mode (Just (id, ty)) = Just $ AST.IfaceSigDec id mode ty
 165 mkIfaceSigDec _ Nothing = Nothing
 166
 167 -- | Generate a VHDL entity name for the given hsfunc
 168 mkEntityId hsfunc =
 169   -- TODO: This doesn't work for functions with multiple signatures!
 170   -- Use a Basic Id, since using extended id's for entities throws off
 171   -- precision and causes problems when generating filenames.
 172   mkVHDLBasicId $ hsFuncName hsfunc
 173
 174 -- | Create an architecture for a given function
 175 createArchitecture ::
 176   (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The function
 177   -> VHDLState AST.ArchBody -- ^ The architecture for this function
 178
 179 createArchitecture (fname, expr) = do
 180   --signaturemap <- getA vsSignatures
 181   --let signature = Maybe.fromMaybe
 182   --      (error $ "Generating architecture for function " ++ (prettyShow hsfunc) ++ "without signature? This should not happen!")
 183   --      (Map.lookup hsfunc signaturemap)
 184   let entity_id = mkVHDLBasicId $ bndrToString fname
 185   -- Strip off lambda's, these will be arguments
 186   let (args, letexpr) = CoreSyn.collectBinders expr
 187   -- There must be a let at top level
 188   let (CoreSyn.Let (CoreSyn.Rec binds) res) = letexpr
 189
 190   -- Create signal declarations for all internal and state signals
 191   sig_dec_maybes <- mapM (mkSigDec' . fst) binds
 192   let sig_decs = Maybe.catMaybes $ sig_dec_maybes
 193
 194   statements <- Monad.mapM mkConcSm binds
 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 -- | Looks up all pairs of old state, new state signals, together with
 203 --   the state id they represent.
 204 makeStatePairs :: FlatFunction -> [(StateId, SignalInfo, SignalInfo)]
 205 makeStatePairs flatfunc =
 206   [(Maybe.fromJust $ oldStateId $ sigUse old_info, old_info, new_info)
 207     | old_info <- map snd (flat_sigs flatfunc)
 208     , new_info <- map snd (flat_sigs flatfunc)
 209         -- old_info must be an old state (and, because of the next equality,
 210         -- new_info must be a new state).
 211         , Maybe.isJust $ oldStateId $ sigUse old_info
 212         -- And the state numbers must match
 213     , (oldStateId $ sigUse old_info) == (newStateId $ sigUse new_info)]
 214
 215     -- Replace the second tuple element with the corresponding SignalInfo
 216     --args_states = map (Arrow.second $ signalInfo sigs) args
 217 mkStateProcSm :: (StateId, SignalInfo, SignalInfo) -> AST.ProcSm
 218 mkStateProcSm (num, old, new) =
 219   AST.ProcSm label [clk] [statement]
 220   where
 221     label       = mkVHDLExtId $ "state_" ++ (show num)
 222     clk         = mkVHDLExtId "clk"
 223     rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
 224     wform       = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple $ getSignalId new) Nothing]
 225     assign      = AST.SigAssign (AST.NSimple $ getSignalId old) wform
 226     rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
 227     statement   = AST.IfSm rising_edge_clk [assign] [] Nothing
 228
 229 mkSigDec :: CoreSyn.CoreBndr -> VHDLState (Maybe AST.SigDec)
 230 mkSigDec bndr =
 231   if True then do --isInternalSigUse use || isStateSigUse use then do
 232     type_mark <- vhdl_ty $ Var.varType bndr
 233     return $ Just (AST.SigDec (bndrToVHDLId bndr) type_mark Nothing)
 234   else
 235     return Nothing
 236
 237 -- | Creates a VHDL Id from a named SignalInfo. Errors out if the SignalInfo
 238 --   is not named.
 239 getSignalId :: SignalInfo -> AST.VHDLId
 240 getSignalId info =
 241     mkVHDLExtId $ Maybe.fromMaybe
 242       (error $ "Unnamed signal? This should not happen!")
 243       (sigName info)
 244
 245 -- | Transforms a core binding into a VHDL concurrent statement
 246 mkConcSm ::
 247   (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The binding to process
 248   -> VHDLState AST.ConcSm  -- ^ The corresponding VHDL component instantiation.
 249
 250 mkConcSm (bndr, app@(CoreSyn.App _ _))= do
 251   signatures <- getA vsSignatures
 252   funSignatures <- getA vsNameTable
 253   let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
 254   case (Map.lookup (bndrToString f) funSignatures) of
 255     Just funSignature ->
 256       let
 257         sigs = map (bndrToString.varBndr) args
 258         sigsNames = map (\signal -> (AST.PrimName (AST.NSimple (mkVHDLExtId signal)))) sigs
 259         func = (snd funSignature) sigsNames
 260         src_wform = AST.Wform [AST.WformElem func Nothing]
 261         dst_name = AST.NSimple (mkVHDLExtId (bndrToString bndr))
 262         assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
 263       in
 264         return $ AST.CSSASm assign
 265     Nothing ->
 266       let
 267         signature = Maybe.fromMaybe
 268           (error $ "Using function '" ++ (bndrToString f) ++ "' without signature? This should not happen!")
 269           (Map.lookup (bndrToString f) signatures)
 270         entity_id = ent_id signature
 271         label = bndrToString bndr
 272       -- Add a clk port if we have state
 273       --clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
 274       --portmaps = mkAssocElems sigs args res signature ++ (if hasState hsfunc then [clk_port] else [])
 275         portmaps = mkAssocElems args bndr signature
 276       in
 277         return $ AST.CSISm $ AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)
 278
 279 -- GHC generates some funny "r = r" bindings in let statements before
 280 -- simplification. This outputs some dummy ConcSM for these, so things will at
 281 -- least compile for now.
 282 mkConcSm (bndr, CoreSyn.Var _) = return $ AST.CSPSm $ AST.ProcSm (mkVHDLBasicId "unused") [] []
 283
 284 -- A single alt case must be a selector. This means thee scrutinee is a simple
 285 -- variable, the alternative is a dataalt with a single non-wild binder that
 286 -- is also returned.
 287 mkConcSm (bndr, expr@(Case (Var scrut) b ty [alt])) =
 288   case alt of
 289     (DataAlt dc, bndrs, (Var sel_bndr)) -> do
 290       case List.elemIndex sel_bndr bndrs of
 291         Just i -> do
 292           labels <- getFieldLabels (Id.idType scrut)
 293           let label = labels!!i
 294           let scrut_name = AST.NSimple $ bndrToVHDLId scrut
 295           let sel_suffix = AST.SSimple $ label
 296           let sel_name = AST.NSelected $ scrut_name AST.:.: sel_suffix
 297           let sel_expr = AST.PrimName sel_name
 298           let sel_wform = AST.Wform [AST.WformElem sel_expr Nothing]
 299           let dst_name  = AST.NSimple (bndrToVHDLId bndr)
 300           -- TODO: Reduce code duplication with the next mkConcSm clause
 301           let assign = dst_name AST.:<==: (AST.ConWforms [] sel_wform Nothing)
 302           return $ AST.CSSASm assign
 303         Nothing -> error $ "VHDL.mkConcSM Not in normal form: Not a selector case:\n" ++ (pprString expr)
 304
 305     _ -> error $ "VHDL.mkConcSM Not in normal form: Not a selector case:\n" ++ (pprString expr)
 306
 307
 308 -- Multiple case alt are be conditional assignments and have only wild
 309 -- binders in the alts and only variables in the case values and a variable
 310 -- for a scrutinee. We check the constructor of the second alt, since the
 311 -- first is the default case, if there is any.
 312 mkConcSm (bndr, (Case (Var scrut) b ty [(_, _, Var false), (con, _, Var true)])) =
 313   let
 314     cond_expr = (varToVHDLExpr scrut) AST.:=: (conToVHDLExpr con)
 315     true_expr  = (varToVHDLExpr true)
 316     false_expr  = (varToVHDLExpr false)
 317     false_wform = AST.Wform [AST.WformElem false_expr Nothing]
 318     true_wform = AST.Wform [AST.WformElem true_expr Nothing]
 319     whenelse = AST.WhenElse true_wform cond_expr
 320     dst_name  = AST.NSimple (bndrToVHDLId bndr)
 321     assign    = dst_name AST.:<==: (AST.ConWforms [whenelse] false_wform Nothing)
 322   in
 323     return $ AST.CSSASm assign
 324 mkConcSm (_, (Case (Var _) _ _ alts)) = error "VHDL.mkConcSm Not in normal form: Case statement with more than two alternatives"
 325 mkConcSm (_, Case _ _ _ _) = error "VHDL.mkConcSm Not in normal form: Case statement has does not have a simple variable as scrutinee"
 326
 327 -- Finds the field labels for VHDL type generated for the given Core type,
 328 -- which must result in a record type.
 329 getFieldLabels :: Type.Type -> VHDLState [AST.VHDLId]
 330 getFieldLabels ty = do
 331   -- Ensure that the type is generated (but throw away it's VHDLId)
 332   vhdl_ty ty
 333   -- Get the types map, lookup and unpack the VHDL TypeDef
 334   types <- getA vsTypes
 335   case Map.lookup (OrdType ty) types of
 336     Just (_, AST.TDR (AST.RecordTypeDef elems)) -> return $ map (\(AST.ElementDec id _) -> id) elems
 337     _ -> error $ "VHDL.getFieldLabels Type not found or not a record type? This should not happen! Type: " ++ (show ty)
 338
 339 -- Turn a variable reference into a AST expression
 340 varToVHDLExpr :: Var.Var -> AST.Expr
 341 varToVHDLExpr var = AST.PrimName $ AST.NSimple $ bndrToVHDLId var
 342
 343 -- Turn a constructor into an AST expression. For dataconstructors, this is
 344 -- only the constructor itself, not any arguments it has. Should not be called
 345 -- with a DEFAULT constructor.
 346 conToVHDLExpr :: CoreSyn.AltCon -> AST.Expr
 347 conToVHDLExpr (DataAlt dc) = AST.PrimLit lit
 348   where
 349     tycon = DataCon.dataConTyCon dc
 350     tyname = TyCon.tyConName tycon
 351     dcname = DataCon.dataConName dc
 352     lit = case Name.getOccString tyname of
 353       -- TODO: Do something more robust than string matching
 354       "Bit"      -> case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
 355       "Bool" -> case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
 356 conToVHDLExpr (LitAlt _) = error "VHDL.conToVHDLExpr Literals not support in case alternatives yet"
 357 conToVHDLExpr DEFAULT = error "VHDL.conToVHDLExpr DEFAULT alternative should not occur here!"
 358
 359
 360
 361 {-
 362 mkConcSm sigs (UncondDef src dst) _ = do
 363   src_expr <- vhdl_expr src
 364   let src_wform = AST.Wform [AST.WformElem src_expr Nothing]
 365   let dst_name  = AST.NSimple (getSignalId $ signalInfo sigs dst)
 366   let assign    = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
 367   return $ AST.CSSASm assign
 368   where
 369     vhdl_expr (Left id) = return $ mkIdExpr sigs id
 370     vhdl_expr (Right expr) =
 371       case expr of
 372         (EqLit id lit) ->
 373           return $ (mkIdExpr sigs id) AST.:=: (AST.PrimLit lit)
 374         (Literal lit Nothing) ->
 375           return $ AST.PrimLit lit
 376         (Literal lit (Just ty)) -> do
 377           -- Create a cast expression, which is just a function call using the
 378           -- type name as the function name.
 379           let litexpr = AST.PrimLit lit
 380           ty_id <- vhdl_ty ty
 381           let ty_name = AST.NSimple ty_id
 382           let args = [Nothing AST.:=>: (AST.ADExpr litexpr)]
 383           return $ AST.PrimFCall $ AST.FCall ty_name args
 384         (Eq a b) ->
 385          return $  (mkIdExpr sigs a) AST.:=: (mkIdExpr sigs b)
 386
 387 mkConcSm sigs (CondDef cond true false dst) _ =
 388   let
 389     cond_expr  = mkIdExpr sigs cond
 390     true_expr  = mkIdExpr sigs true
 391     false_expr  = mkIdExpr sigs false
 392     false_wform = AST.Wform [AST.WformElem false_expr Nothing]
 393     true_wform = AST.Wform [AST.WformElem true_expr Nothing]
 394     whenelse = AST.WhenElse true_wform cond_expr
 395     dst_name  = AST.NSimple (getSignalId $ signalInfo sigs dst)
 396     assign    = dst_name AST.:<==: (AST.ConWforms [whenelse] false_wform Nothing)
 397   in
 398     return $ AST.CSSASm assign
 399 -}
 400 -- | Turn a SignalId into a VHDL Expr
 401 mkIdExpr :: [(SignalId, SignalInfo)] -> SignalId -> AST.Expr
 402 mkIdExpr sigs id =
 403   let src_name  = AST.NSimple (getSignalId $ signalInfo sigs id) in
 404   AST.PrimName src_name
 405
 406 mkAssocElems ::
 407   [CoreSyn.CoreExpr]            -- | The argument that are applied to function
 408   -> CoreSyn.CoreBndr           -- | The binder in which to store the result
 409   -> Entity                     -- | The entity to map against.
 410   -> [AST.AssocElem]            -- | The resulting port maps
 411
 412 mkAssocElems args res entity =
 413     -- Create the actual AssocElems
 414     Maybe.catMaybes $ zipWith mkAssocElem ports sigs
 415   where
 416     -- Turn the ports and signals from a map into a flat list. This works,
 417     -- since the maps must have an identical form by definition. TODO: Check
 418     -- the similar form?
 419     arg_ports = ent_args entity
 420     res_port  = ent_res entity
 421     -- Extract the id part from the (id, type) tuple
 422     ports     = map (Monad.liftM fst) (res_port : arg_ports)
 423     -- Translate signal numbers into names
 424     sigs      = (bndrToString res : map (bndrToString.varBndr) args)
 425
 426 -- Turns a Var CoreExpr into the Id inside it. Will of course only work for
 427 -- simple Var CoreExprs, not complexer ones.
 428 varBndr :: CoreSyn.CoreExpr -> Var.Id
 429 varBndr (CoreSyn.Var id) = id
 430
 431 -- | Look up a signal in the signal name map
 432 lookupSigName :: [(SignalId, SignalInfo)] -> SignalId -> String
 433 lookupSigName sigs sig = name
 434   where
 435     info = Maybe.fromMaybe
 436       (error $ "Unknown signal " ++ (show sig) ++ " used? This should not happen!")
 437       (lookup sig sigs)
 438     name = Maybe.fromMaybe
 439       (error $ "Unnamed signal " ++ (show sig) ++ " used? This should not happen!")
 440       (sigName info)
 441
 442 -- | Create an VHDL port -> signal association
 443 mkAssocElem :: Maybe AST.VHDLId -> String -> Maybe AST.AssocElem
 444 mkAssocElem (Just port) signal = Just $ Just port AST.:=>: (AST.ADName (AST.NSimple (mkVHDLExtId signal)))
 445 mkAssocElem Nothing _ = Nothing
 446
 447 -- | The VHDL Bit type
 448 bit_ty :: AST.TypeMark
 449 bit_ty = AST.unsafeVHDLBasicId "Bit"
 450
 451 -- | The VHDL Boolean type
 452 bool_ty :: AST.TypeMark
 453 bool_ty = AST.unsafeVHDLBasicId "Boolean"
 454
 455 -- | The VHDL std_logic
 456 std_logic_ty :: AST.TypeMark
 457 std_logic_ty = AST.unsafeVHDLBasicId "std_logic"
 458
 459 -- Translate a Haskell type to a VHDL type
 460 vhdl_ty :: Type.Type -> VHDLState AST.TypeMark
 461 vhdl_ty ty = do
 462   typemap <- getA vsTypes
 463   let builtin_ty = do -- See if this is a tycon and lookup its name
 464         (tycon, args) <- Type.splitTyConApp_maybe ty
 465         let name = Name.getOccString (TyCon.tyConName tycon)
 466         Map.lookup name builtin_types
 467   -- If not a builtin type, try the custom types
 468   let existing_ty = (fmap fst) $ Map.lookup (OrdType ty) typemap
 469   case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of
 470     -- Found a type, return it
 471     Just t -> return t
 472     -- No type yet, try to construct it
 473     Nothing -> do
 474       newty_maybe <- (construct_vhdl_ty ty)
 475       case newty_maybe of
 476         Just (ty_id, ty_def) -> do
 477           -- TODO: Check name uniqueness
 478           modA vsTypes (Map.insert (OrdType ty) (ty_id, ty_def))
 479           return ty_id
 480         Nothing -> error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty)
 481
 482 -- Construct a new VHDL type for the given Haskell type.
 483 construct_vhdl_ty :: Type.Type -> VHDLState (Maybe (AST.TypeMark, AST.TypeDef))
 484 construct_vhdl_ty ty = do
 485   case Type.splitTyConApp_maybe ty of
 486     Just (tycon, args) -> do
 487       let name = Name.getOccString (TyCon.tyConName tycon)
 488       case name of
 489         "TFVec" -> do
 490           res <- mk_vector_ty (tfvec_len ty) ty
 491           return $ Just res
 492         "SizedWord" -> do
 493           res <- mk_vector_ty (sized_word_len ty) ty
 494           return $ Just res
 495         -- Create a custom type from this tycon
 496         otherwise -> mk_tycon_ty tycon args
 497     Nothing -> return $ Nothing
 498
 499 -- | Create VHDL type for a custom tycon
 500 mk_tycon_ty :: TyCon.TyCon -> [Type.Type] -> VHDLState (Maybe (AST.TypeMark, AST.TypeDef))
 501 mk_tycon_ty tycon args =
 502   case TyCon.tyConDataCons tycon of
 503     -- Not an algebraic type
 504     [] -> error $ "Only custom algebraic types are supported: " ++  (showSDoc $ ppr tycon)
 505     [dc] -> do
 506       let arg_tys = DataCon.dataConRepArgTys dc
 507       -- TODO: CoreSubst docs say each Subs can be applied only once. Is this a
 508       -- violation? Or does it only mean not to apply it again to the same
 509       -- subject?
 510       let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
 511       elem_tys <- mapM vhdl_ty real_arg_tys
 512       let elems = zipWith AST.ElementDec recordlabels elem_tys
 513       -- For a single construct datatype, build a record with one field for
 514       -- each argument.
 515       -- TODO: Add argument type ids to this, to ensure uniqueness
 516       -- TODO: Special handling for tuples?
 517       let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon)
 518       let ty_def = AST.TDR $ AST.RecordTypeDef elems
 519       return $ Just (ty_id, ty_def)
 520     dcs -> error $ "Only single constructor datatypes supported: " ++  (showSDoc $ ppr tycon)
 521   where
 522     -- Create a subst that instantiates all types passed to the tycon
 523     -- TODO: I'm not 100% sure that this is the right way to do this. It seems
 524     -- to work so far, though..
 525     tyvars = TyCon.tyConTyVars tycon
 526     subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
 527
 528 -- | Create a VHDL vector type
 529 mk_vector_ty ::
 530   Int -- ^ The length of the vector
 531   -> Type.Type -- ^ The Haskell type to create a VHDL type for
 532   -> VHDLState (AST.TypeMark, AST.TypeDef) -- The typemark created.
 533
 534 mk_vector_ty len ty = do
 535   -- Assume there is a single type argument
 536   let ty_id = mkVHDLExtId $ "vector_" ++ (show len)
 537   -- TODO: Use el_ty
 538   let range = AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
 539   let ty_def = AST.TDA $ AST.ConsArrayDef range std_logic_ty
 540   modA vsTypeFuns (Map.insert (OrdType ty) (genUnconsVectorFuns std_logic_ty ty_id))
 541   return (ty_id, ty_def)
 542
 543
 544 builtin_types =
 545   Map.fromList [
 546     ("Bit", std_logic_ty),
 547     ("Bool", bool_ty) -- TysWiredIn.boolTy
 548   ]
 549
 550 -- Shortcut for
 551 -- Can only contain alphanumerics and underscores. The supplied string must be
 552 -- a valid basic id, otherwise an error value is returned. This function is
 553 -- not meant to be passed identifiers from a source file, use mkVHDLExtId for
 554 -- that.
 555 mkVHDLBasicId :: String -> AST.VHDLId
 556 mkVHDLBasicId s =
 557   AST.unsafeVHDLBasicId $ (strip_multiscore . strip_leading . strip_invalid) s
 558   where
 559     -- Strip invalid characters.
 560     strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
 561     -- Strip leading numbers and underscores
 562     strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
 563     -- Strip multiple adjacent underscores
 564     strip_multiscore = concat . map (\cs ->
 565         case cs of
 566           ('_':_) -> "_"
 567           _ -> cs
 568       ) . List.group
 569
 570 -- Shortcut for Extended VHDL Id's. These Id's can contain a lot more
 571 -- different characters than basic ids, but can never be used to refer to
 572 -- basic ids.
 573 -- Use extended Ids for any values that are taken from the source file.
 574 mkVHDLExtId :: String -> AST.VHDLId
 575 mkVHDLExtId s =
 576   AST.unsafeVHDLExtId $ strip_invalid s
 577   where
 578     -- Allowed characters, taken from ForSyde's mkVHDLExtId
 579     allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&\\'()*+,./:;<=>_|!$%@?[]^`{}~-"
 580     strip_invalid = filter (`elem` allowed)
 581
 582 -- Creates a VHDL Id from a binder
 583 bndrToVHDLId ::
 584   CoreSyn.CoreBndr
 585   -> AST.VHDLId
 586
 587 bndrToVHDLId = mkVHDLExtId . OccName.occNameString . Name.nameOccName . Var.varName
 588
 589 -- Extracts the binder name as a String
 590 bndrToString ::
 591   CoreSyn.CoreBndr
 592   -> String
 593
 594 bndrToString = OccName.occNameString . Name.nameOccName . Var.varName
 595
 596 -- Extracts the string version of the name
 597 nameToString :: Name.Name -> String
 598 nameToString = OccName.occNameString . Name.nameOccName
 599
 600 -- | A consise representation of a (set of) ports on a builtin function
 601 --type PortMap = HsValueMap (String, AST.TypeMark)
 602 -- | A consise representation of a builtin function
 603 data BuiltIn = BuiltIn String [(String, AST.TypeMark)] (String, AST.TypeMark)
 604
 605 -- | Translate a list of concise representation of builtin functions to a
 606 --   SignatureMap
 607 mkBuiltins :: [BuiltIn] -> SignatureMap
 608 mkBuiltins = Map.fromList . map (\(BuiltIn name args res) ->
 609     (name,
 610      Entity (VHDL.mkVHDLBasicId name) (map toVHDLSignalMapElement args) (toVHDLSignalMapElement res))
 611   )
 612
 613 builtin_hsfuncs = Map.keys builtin_funcs
 614 builtin_funcs = mkBuiltins
 615   [
 616     BuiltIn "hwxor" [("a", VHDL.bit_ty), ("b", VHDL.bit_ty)] ("o", VHDL.bit_ty),
 617     BuiltIn "hwand" [("a", VHDL.bit_ty), ("b", VHDL.bit_ty)] ("o", VHDL.bit_ty),
 618     BuiltIn "hwor" [("a", VHDL.bit_ty), ("b", VHDL.bit_ty)] ("o", VHDL.bit_ty),
 619     BuiltIn "hwnot" [("a", VHDL.bit_ty)] ("o", VHDL.bit_ty)
 620   ]
 621
 622 recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
 623
 624 -- | Map a port specification of a builtin function to a VHDL Signal to put in
 625 --   a VHDLSignalMap
 626 toVHDLSignalMapElement :: (String, AST.TypeMark) -> VHDLSignalMapElement
 627 toVHDLSignalMapElement (name, ty) = Just (mkVHDLBasicId name, ty)