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           return $ mkUncondAssign bndr sel_expr
 299         Nothing -> error $ "VHDL.mkConcSM Not in normal form: Not a selector case:\n" ++ (pprString expr)
 300
 301     _ -> error $ "VHDL.mkConcSM Not in normal form: Not a selector case:\n" ++ (pprString expr)
 302
 303
 304 -- Multiple case alt are be conditional assignments and have only wild
 305 -- binders in the alts and only variables in the case values and a variable
 306 -- for a scrutinee. We check the constructor of the second alt, since the
 307 -- first is the default case, if there is any.
 308 mkConcSm (bndr, (Case (Var scrut) b ty [(_, _, Var false), (con, _, Var true)])) =
 309   let
 310     cond_expr = (varToVHDLExpr scrut) AST.:=: (conToVHDLExpr con)
 311     true_expr  = (varToVHDLExpr true)
 312     false_expr  = (varToVHDLExpr false)
 313   in
 314     return $ mkCondAssign bndr cond_expr true_expr false_expr
 315 mkConcSm (_, (Case (Var _) _ _ alts)) = error "VHDL.mkConcSm Not in normal form: Case statement with more than two alternatives"
 316 mkConcSm (_, Case _ _ _ _) = error "VHDL.mkConcSm Not in normal form: Case statement has does not have a simple variable as scrutinee"
 317
 318 -- Create an unconditional assignment statement
 319 mkUncondAssign ::
 320   CoreBndr -- ^ The signal to assign to
 321   -> AST.Expr -- ^ The expression to assign
 322   -> AST.ConcSm -- ^ The resulting concurrent statement
 323 mkUncondAssign bndr expr = mkAssign bndr Nothing expr
 324
 325 -- Create a conditional assignment statement
 326 mkCondAssign ::
 327   CoreBndr -- ^ The signal to assign to
 328   -> AST.Expr -- ^ The condition
 329   -> AST.Expr -- ^ The value when true
 330   -> AST.Expr -- ^ The value when false
 331   -> AST.ConcSm -- ^ The resulting concurrent statement
 332 mkCondAssign bndr cond true false = mkAssign bndr (Just (cond, true)) false
 333
 334 -- Create a conditional or unconditional assignment statement
 335 mkAssign ::
 336   CoreBndr -> -- ^ The signal to assign to
 337   Maybe (AST.Expr , AST.Expr) -> -- ^ Optionally, the condition to test for
 338                                  -- and the value to assign when true.
 339   AST.Expr -> -- ^ The value to assign when false or no condition
 340   AST.ConcSm -- ^ The resulting concurrent statement
 341
 342 mkAssign bndr cond false_expr =
 343   let
 344     -- I'm not 100% how this assignment AST works, but this gets us what we
 345     -- want...
 346     whenelse = case cond of
 347       Just (cond_expr, true_expr) ->
 348         let
 349           true_wform = AST.Wform [AST.WformElem true_expr Nothing]
 350         in
 351           [AST.WhenElse true_wform cond_expr]
 352       Nothing -> []
 353     false_wform = AST.Wform [AST.WformElem false_expr Nothing]
 354     dst_name  = AST.NSimple (bndrToVHDLId bndr)
 355     assign    = dst_name AST.:<==: (AST.ConWforms whenelse false_wform Nothing)
 356   in
 357     AST.CSSASm assign
 358
 359 -- Finds the field labels for VHDL type generated for the given Core type,
 360 -- which must result in a record type.
 361 getFieldLabels :: Type.Type -> VHDLState [AST.VHDLId]
 362 getFieldLabels ty = do
 363   -- Ensure that the type is generated (but throw away it's VHDLId)
 364   vhdl_ty ty
 365   -- Get the types map, lookup and unpack the VHDL TypeDef
 366   types <- getA vsTypes
 367   case Map.lookup (OrdType ty) types of
 368     Just (_, AST.TDR (AST.RecordTypeDef elems)) -> return $ map (\(AST.ElementDec id _) -> id) elems
 369     _ -> error $ "VHDL.getFieldLabels Type not found or not a record type? This should not happen! Type: " ++ (show ty)
 370
 371 -- Turn a variable reference into a AST expression
 372 varToVHDLExpr :: Var.Var -> AST.Expr
 373 varToVHDLExpr var = AST.PrimName $ AST.NSimple $ bndrToVHDLId var
 374
 375 -- Turn a constructor into an AST expression. For dataconstructors, this is
 376 -- only the constructor itself, not any arguments it has. Should not be called
 377 -- with a DEFAULT constructor.
 378 conToVHDLExpr :: CoreSyn.AltCon -> AST.Expr
 379 conToVHDLExpr (DataAlt dc) = AST.PrimLit lit
 380   where
 381     tycon = DataCon.dataConTyCon dc
 382     tyname = TyCon.tyConName tycon
 383     dcname = DataCon.dataConName dc
 384     lit = case Name.getOccString tyname of
 385       -- TODO: Do something more robust than string matching
 386       "Bit"      -> case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
 387       "Bool" -> case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
 388 conToVHDLExpr (LitAlt _) = error "VHDL.conToVHDLExpr Literals not support in case alternatives yet"
 389 conToVHDLExpr DEFAULT = error "VHDL.conToVHDLExpr DEFAULT alternative should not occur here!"
 390
 391
 392
 393 {-
 394 mkConcSm sigs (UncondDef src dst) _ = do
 395   src_expr <- vhdl_expr src
 396   let src_wform = AST.Wform [AST.WformElem src_expr Nothing]
 397   let dst_name  = AST.NSimple (getSignalId $ signalInfo sigs dst)
 398   let assign    = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
 399   return $ AST.CSSASm assign
 400   where
 401     vhdl_expr (Left id) = return $ mkIdExpr sigs id
 402     vhdl_expr (Right expr) =
 403       case expr of
 404         (EqLit id lit) ->
 405           return $ (mkIdExpr sigs id) AST.:=: (AST.PrimLit lit)
 406         (Literal lit Nothing) ->
 407           return $ AST.PrimLit lit
 408         (Literal lit (Just ty)) -> do
 409           -- Create a cast expression, which is just a function call using the
 410           -- type name as the function name.
 411           let litexpr = AST.PrimLit lit
 412           ty_id <- vhdl_ty ty
 413           let ty_name = AST.NSimple ty_id
 414           let args = [Nothing AST.:=>: (AST.ADExpr litexpr)]
 415           return $ AST.PrimFCall $ AST.FCall ty_name args
 416         (Eq a b) ->
 417          return $  (mkIdExpr sigs a) AST.:=: (mkIdExpr sigs b)
 418
 419 mkConcSm sigs (CondDef cond true false dst) _ =
 420   let
 421     cond_expr  = mkIdExpr sigs cond
 422     true_expr  = mkIdExpr sigs true
 423     false_expr  = mkIdExpr sigs false
 424     false_wform = AST.Wform [AST.WformElem false_expr Nothing]
 425     true_wform = AST.Wform [AST.WformElem true_expr Nothing]
 426     whenelse = AST.WhenElse true_wform cond_expr
 427     dst_name  = AST.NSimple (getSignalId $ signalInfo sigs dst)
 428     assign    = dst_name AST.:<==: (AST.ConWforms [whenelse] false_wform Nothing)
 429   in
 430     return $ AST.CSSASm assign
 431 -}
 432 -- | Turn a SignalId into a VHDL Expr
 433 mkIdExpr :: [(SignalId, SignalInfo)] -> SignalId -> AST.Expr
 434 mkIdExpr sigs id =
 435   let src_name  = AST.NSimple (getSignalId $ signalInfo sigs id) in
 436   AST.PrimName src_name
 437
 438 mkAssocElems ::
 439   [CoreSyn.CoreExpr]            -- | The argument that are applied to function
 440   -> CoreSyn.CoreBndr           -- | The binder in which to store the result
 441   -> Entity                     -- | The entity to map against.
 442   -> [AST.AssocElem]            -- | The resulting port maps
 443
 444 mkAssocElems args res entity =
 445     -- Create the actual AssocElems
 446     Maybe.catMaybes $ zipWith mkAssocElem ports sigs
 447   where
 448     -- Turn the ports and signals from a map into a flat list. This works,
 449     -- since the maps must have an identical form by definition. TODO: Check
 450     -- the similar form?
 451     arg_ports = ent_args entity
 452     res_port  = ent_res entity
 453     -- Extract the id part from the (id, type) tuple
 454     ports     = map (Monad.liftM fst) (res_port : arg_ports)
 455     -- Translate signal numbers into names
 456     sigs      = (bndrToString res : map (bndrToString.varBndr) args)
 457
 458 -- Turns a Var CoreExpr into the Id inside it. Will of course only work for
 459 -- simple Var CoreExprs, not complexer ones.
 460 varBndr :: CoreSyn.CoreExpr -> Var.Id
 461 varBndr (CoreSyn.Var id) = id
 462
 463 -- | Look up a signal in the signal name map
 464 lookupSigName :: [(SignalId, SignalInfo)] -> SignalId -> String
 465 lookupSigName sigs sig = name
 466   where
 467     info = Maybe.fromMaybe
 468       (error $ "Unknown signal " ++ (show sig) ++ " used? This should not happen!")
 469       (lookup sig sigs)
 470     name = Maybe.fromMaybe
 471       (error $ "Unnamed signal " ++ (show sig) ++ " used? This should not happen!")
 472       (sigName info)
 473
 474 -- | Create an VHDL port -> signal association
 475 mkAssocElem :: Maybe AST.VHDLId -> String -> Maybe AST.AssocElem
 476 mkAssocElem (Just port) signal = Just $ Just port AST.:=>: (AST.ADName (AST.NSimple (mkVHDLExtId signal)))
 477 mkAssocElem Nothing _ = Nothing
 478
 479 -- | The VHDL Bit type
 480 bit_ty :: AST.TypeMark
 481 bit_ty = AST.unsafeVHDLBasicId "Bit"
 482
 483 -- | The VHDL Boolean type
 484 bool_ty :: AST.TypeMark
 485 bool_ty = AST.unsafeVHDLBasicId "Boolean"
 486
 487 -- | The VHDL std_logic
 488 std_logic_ty :: AST.TypeMark
 489 std_logic_ty = AST.unsafeVHDLBasicId "std_logic"
 490
 491 -- Translate a Haskell type to a VHDL type
 492 vhdl_ty :: Type.Type -> VHDLState AST.TypeMark
 493 vhdl_ty ty = do
 494   typemap <- getA vsTypes
 495   let builtin_ty = do -- See if this is a tycon and lookup its name
 496         (tycon, args) <- Type.splitTyConApp_maybe ty
 497         let name = Name.getOccString (TyCon.tyConName tycon)
 498         Map.lookup name builtin_types
 499   -- If not a builtin type, try the custom types
 500   let existing_ty = (fmap fst) $ Map.lookup (OrdType ty) typemap
 501   case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of
 502     -- Found a type, return it
 503     Just t -> return t
 504     -- No type yet, try to construct it
 505     Nothing -> do
 506       newty_maybe <- (construct_vhdl_ty ty)
 507       case newty_maybe of
 508         Just (ty_id, ty_def) -> do
 509           -- TODO: Check name uniqueness
 510           modA vsTypes (Map.insert (OrdType ty) (ty_id, ty_def))
 511           return ty_id
 512         Nothing -> error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty)
 513
 514 -- Construct a new VHDL type for the given Haskell type.
 515 construct_vhdl_ty :: Type.Type -> VHDLState (Maybe (AST.TypeMark, AST.TypeDef))
 516 construct_vhdl_ty ty = do
 517   case Type.splitTyConApp_maybe ty of
 518     Just (tycon, args) -> do
 519       let name = Name.getOccString (TyCon.tyConName tycon)
 520       case name of
 521         "TFVec" -> do
 522           res <- mk_vector_ty (tfvec_len ty) ty
 523           return $ Just res
 524         "SizedWord" -> do
 525           res <- mk_vector_ty (sized_word_len ty) ty
 526           return $ Just res
 527         -- Create a custom type from this tycon
 528         otherwise -> mk_tycon_ty tycon args
 529     Nothing -> return $ Nothing
 530
 531 -- | Create VHDL type for a custom tycon
 532 mk_tycon_ty :: TyCon.TyCon -> [Type.Type] -> VHDLState (Maybe (AST.TypeMark, AST.TypeDef))
 533 mk_tycon_ty tycon args =
 534   case TyCon.tyConDataCons tycon of
 535     -- Not an algebraic type
 536     [] -> error $ "Only custom algebraic types are supported: " ++  (showSDoc $ ppr tycon)
 537     [dc] -> do
 538       let arg_tys = DataCon.dataConRepArgTys dc
 539       -- TODO: CoreSubst docs say each Subs can be applied only once. Is this a
 540       -- violation? Or does it only mean not to apply it again to the same
 541       -- subject?
 542       let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
 543       elem_tys <- mapM vhdl_ty real_arg_tys
 544       let elems = zipWith AST.ElementDec recordlabels elem_tys
 545       -- For a single construct datatype, build a record with one field for
 546       -- each argument.
 547       -- TODO: Add argument type ids to this, to ensure uniqueness
 548       -- TODO: Special handling for tuples?
 549       let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon)
 550       let ty_def = AST.TDR $ AST.RecordTypeDef elems
 551       return $ Just (ty_id, ty_def)
 552     dcs -> error $ "Only single constructor datatypes supported: " ++  (showSDoc $ ppr tycon)
 553   where
 554     -- Create a subst that instantiates all types passed to the tycon
 555     -- TODO: I'm not 100% sure that this is the right way to do this. It seems
 556     -- to work so far, though..
 557     tyvars = TyCon.tyConTyVars tycon
 558     subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
 559
 560 -- | Create a VHDL vector type
 561 mk_vector_ty ::
 562   Int -- ^ The length of the vector
 563   -> Type.Type -- ^ The Haskell type to create a VHDL type for
 564   -> VHDLState (AST.TypeMark, AST.TypeDef) -- The typemark created.
 565
 566 mk_vector_ty len ty = do
 567   -- Assume there is a single type argument
 568   let ty_id = mkVHDLExtId $ "vector_" ++ (show len)
 569   -- TODO: Use el_ty
 570   let range = AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
 571   let ty_def = AST.TDA $ AST.ConsArrayDef range std_logic_ty
 572   modA vsTypeFuns (Map.insert (OrdType ty) (genUnconsVectorFuns std_logic_ty ty_id))
 573   return (ty_id, ty_def)
 574
 575
 576 builtin_types =
 577   Map.fromList [
 578     ("Bit", std_logic_ty),
 579     ("Bool", bool_ty) -- TysWiredIn.boolTy
 580   ]
 581
 582 -- Shortcut for
 583 -- Can only contain alphanumerics and underscores. The supplied string must be
 584 -- a valid basic id, otherwise an error value is returned. This function is
 585 -- not meant to be passed identifiers from a source file, use mkVHDLExtId for
 586 -- that.
 587 mkVHDLBasicId :: String -> AST.VHDLId
 588 mkVHDLBasicId s =
 589   AST.unsafeVHDLBasicId $ (strip_multiscore . strip_leading . strip_invalid) s
 590   where
 591     -- Strip invalid characters.
 592     strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
 593     -- Strip leading numbers and underscores
 594     strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
 595     -- Strip multiple adjacent underscores
 596     strip_multiscore = concat . map (\cs ->
 597         case cs of
 598           ('_':_) -> "_"
 599           _ -> cs
 600       ) . List.group
 601
 602 -- Shortcut for Extended VHDL Id's. These Id's can contain a lot more
 603 -- different characters than basic ids, but can never be used to refer to
 604 -- basic ids.
 605 -- Use extended Ids for any values that are taken from the source file.
 606 mkVHDLExtId :: String -> AST.VHDLId
 607 mkVHDLExtId s =
 608   AST.unsafeVHDLExtId $ strip_invalid s
 609   where
 610     -- Allowed characters, taken from ForSyde's mkVHDLExtId
 611     allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&\\'()*+,./:;<=>_|!$%@?[]^`{}~-"
 612     strip_invalid = filter (`elem` allowed)
 613
 614 -- Creates a VHDL Id from a binder
 615 bndrToVHDLId ::
 616   CoreSyn.CoreBndr
 617   -> AST.VHDLId
 618
 619 bndrToVHDLId = mkVHDLExtId . OccName.occNameString . Name.nameOccName . Var.varName
 620
 621 -- Extracts the binder name as a String
 622 bndrToString ::
 623   CoreSyn.CoreBndr
 624   -> String
 625
 626 bndrToString = OccName.occNameString . Name.nameOccName . Var.varName
 627
 628 -- Extracts the string version of the name
 629 nameToString :: Name.Name -> String
 630 nameToString = OccName.occNameString . Name.nameOccName
 631
 632 -- | A consise representation of a (set of) ports on a builtin function
 633 --type PortMap = HsValueMap (String, AST.TypeMark)
 634 -- | A consise representation of a builtin function
 635 data BuiltIn = BuiltIn String [(String, AST.TypeMark)] (String, AST.TypeMark)
 636
 637 -- | Translate a list of concise representation of builtin functions to a
 638 --   SignatureMap
 639 mkBuiltins :: [BuiltIn] -> SignatureMap
 640 mkBuiltins = Map.fromList . map (\(BuiltIn name args res) ->
 641     (name,
 642      Entity (VHDL.mkVHDLBasicId name) (map toVHDLSignalMapElement args) (toVHDLSignalMapElement res))
 643   )
 644
 645 builtin_hsfuncs = Map.keys builtin_funcs
 646 builtin_funcs = mkBuiltins
 647   [
 648     BuiltIn "hwxor" [("a", VHDL.bit_ty), ("b", VHDL.bit_ty)] ("o", VHDL.bit_ty),
 649     BuiltIn "hwand" [("a", VHDL.bit_ty), ("b", VHDL.bit_ty)] ("o", VHDL.bit_ty),
 650     BuiltIn "hwor" [("a", VHDL.bit_ty), ("b", VHDL.bit_ty)] ("o", VHDL.bit_ty),
 651     BuiltIn "hwnot" [("a", VHDL.bit_ty)] ("o", VHDL.bit_ty)
 652   ]
 653
 654 recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
 655
 656 -- | Map a port specification of a builtin function to a VHDL Signal to put in
 657 --   a VHDLSignalMap
 658 toVHDLSignalMapElement :: (String, AST.TypeMark) -> VHDLSignalMapElement
 659 toVHDLSignalMapElement (name, ty) = Just (mkVHDLBasicId name, ty)