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