VHDL.hs

   1 --
   2 -- Functions to generate VHDL from FlatFunctions
   3 --
   4 module VHDL where
   5
   6 import qualified Data.Foldable as Foldable
   7 import qualified Maybe
   8
   9 import qualified Type
  10 import qualified Name
  11 import qualified TyCon
  12 import Outputable ( showSDoc, ppr )
  13
  14 import qualified ForSyDe.Backend.VHDL.AST as AST
  15
  16 import VHDLTypes
  17 import FlattenTypes
  18 import TranslatorTypes
  19
  20 -- | Create an entity for a given function
  21 createEntity ::
  22   HsFunction        -- | The function signature
  23   -> FuncData       -- | The function data collected so far
  24   -> VHDLState ()
  25
  26 createEntity hsfunc fdata =
  27   let func = flatFunc fdata in
  28   case func of
  29     -- Skip (builtin) functions without a FlatFunction
  30     Nothing -> do return ()
  31     -- Create an entity for all other functions
  32     Just flatfunc ->
  33
  34       let
  35         sigs    = flat_sigs flatfunc
  36         args    = flat_args flatfunc
  37         res     = flat_res  flatfunc
  38         args'   = map (fmap (mkMap sigs)) args
  39         res'    = fmap (mkMap sigs) res
  40         ent_decl' = createEntityAST hsfunc args' res'
  41         entity' = Entity args' res' (Just ent_decl')
  42       in
  43         setEntity hsfunc entity'
  44   where
  45     mkMap :: Eq id => [(id, SignalInfo)] -> id -> (AST.VHDLId, AST.TypeMark)
  46     mkMap sigmap id =
  47       (mkVHDLId nm, vhdl_ty ty)
  48       where
  49         info = Maybe.fromMaybe
  50           (error $ "Signal not found in the name map? This should not happen!")
  51           (lookup id sigmap)
  52         nm = Maybe.fromMaybe
  53           (error $ "Signal not named? This should not happen!")
  54           (sigName info)
  55         ty = sigTy info
  56
  57 -- | Create the VHDL AST for an entity
  58 createEntityAST ::
  59   HsFunction            -- | The signature of the function we're working with
  60   -> [VHDLSignalMap]    -- | The entity's arguments
  61   -> VHDLSignalMap      -- | The entity's result
  62   -> AST.EntityDec      -- | The entity with the ent_decl filled in as well
  63
  64 createEntityAST hsfunc args res =
  65   AST.EntityDec vhdl_id ports
  66   where
  67     vhdl_id = mkEntityId hsfunc
  68     ports = concatMap (mapToPorts AST.In) args
  69             ++ mapToPorts AST.Out res
  70     mapToPorts :: AST.Mode -> VHDLSignalMap -> [AST.IfaceSigDec]
  71     mapToPorts mode m =
  72       map (mkIfaceSigDec mode) (Foldable.toList m)
  73
  74 -- | Create a port declaration
  75 mkIfaceSigDec ::
  76   AST.Mode                         -- | The mode for the port (In / Out)
  77   -> (AST.VHDLId, AST.TypeMark)    -- | The id and type for the port
  78   -> AST.IfaceSigDec               -- | The resulting port declaration
  79
  80 mkIfaceSigDec mode (id, ty) = AST.IfaceSigDec id mode ty
  81
  82 -- | Generate a VHDL entity name for the given hsfunc
  83 mkEntityId hsfunc =
  84   -- TODO: This doesn't work for functions with multiple signatures!
  85   mkVHDLId $ hsFuncName hsfunc
  86
  87 -- | Create an architecture for a given function
  88 createArchitecture ::
  89   HsFunction        -- | The function signature
  90   -> FuncData       -- | The function data collected so far
  91   -> VHDLState ()
  92
  93 createArchitecture hsfunc fdata =
  94   let func = flatFunc fdata in
  95   case func of
  96     -- Skip (builtin) functions without a FlatFunction
  97     Nothing -> do return ()
  98     -- Create an architecture for all other functions
  99     Just flatfunc -> do
 100       let sigs = flat_sigs flatfunc
 101       let args = flat_args flatfunc
 102       let res  = flat_res  flatfunc
 103       let apps = flat_apps flatfunc
 104       let entity_id = Maybe.fromMaybe
 105                       (error $ "Building architecture without an entity? This should not happen!")
 106                       (getEntityId fdata)
 107       -- Create signal declarations for all signals that are not in args and
 108       -- res
 109       let sig_decs = [mkSigDec info | (id, info) <- sigs, (all (id `Foldable.notElem`) (res:args)) ]
 110       -- Create component instantiations for all function applications
 111       insts <- mapM mkCompInsSm apps
 112       let insts' = map AST.CSISm insts
 113       let arch = AST.ArchBody (mkVHDLId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) insts'
 114       setArchitecture hsfunc arch
 115
 116 mkSigDec :: SignalInfo -> AST.SigDec
 117 mkSigDec info =
 118     AST.SigDec (mkVHDLId name) (vhdl_ty ty) Nothing
 119   where
 120     name = Maybe.fromMaybe
 121       (error $ "Unnamed signal? This should not happen!")
 122       (sigName info)
 123     ty = sigTy info
 124
 125 -- | Transforms a flat function application to a VHDL component instantiation.
 126 mkCompInsSm ::
 127   FApp UnnamedSignal            -- | The application to look at.
 128   -> VHDLState AST.CompInsSm    -- | The corresponding VHDL component instantiation.
 129
 130 mkCompInsSm app = do
 131   return $ AST.CompInsSm label (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)
 132   where
 133     entity_id = mkVHDLId "foo"
 134     label     = mkVHDLId "app"
 135     portmaps  = []
 136
 137 -- | Extracts the generated entity id from the given funcdata
 138 getEntityId :: FuncData -> Maybe AST.VHDLId
 139 getEntityId fdata =
 140   case funcEntity fdata of
 141     Nothing -> Nothing
 142     Just e  -> case ent_decl e of
 143       Nothing -> Nothing
 144       Just (AST.EntityDec id _) -> Just id
 145
 146 getLibraryUnits ::
 147   (HsFunction, FuncData)      -- | A function from the session
 148   -> [AST.LibraryUnit]        -- | The library units it generates
 149
 150 getLibraryUnits (hsfunc, fdata) =
 151   case funcEntity fdata of
 152     Nothing -> []
 153     Just ent -> case ent_decl ent of
 154       Nothing -> []
 155       Just decl -> [AST.LUEntity decl]
 156   ++
 157   case funcArch fdata of
 158     Nothing -> []
 159     Just arch -> [AST.LUArch arch]
 160
 161 -- | The VHDL Bit type
 162 bit_ty :: AST.TypeMark
 163 bit_ty = AST.unsafeVHDLBasicId "Bit"
 164
 165 -- Translate a Haskell type to a VHDL type
 166 vhdl_ty :: Type.Type -> AST.TypeMark
 167 vhdl_ty ty = Maybe.fromMaybe
 168   (error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty))
 169   (vhdl_ty_maybe ty)
 170
 171 -- Translate a Haskell type to a VHDL type
 172 vhdl_ty_maybe :: Type.Type -> Maybe AST.TypeMark
 173 vhdl_ty_maybe ty =
 174   case Type.splitTyConApp_maybe ty of
 175     Just (tycon, args) ->
 176       let name = TyCon.tyConName tycon in
 177         -- TODO: Do something more robust than string matching
 178         case Name.getOccString name of
 179           "Bit"      -> Just bit_ty
 180           otherwise  -> Nothing
 181     otherwise -> Nothing
 182
 183 -- Shortcut
 184 mkVHDLId :: String -> AST.VHDLId
 185 mkVHDLId = AST.unsafeVHDLBasicId