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 Data.List as List
   8 import qualified Data.Map as Map
   9 import qualified Maybe
  10 import qualified Control.Monad as Monad
  11 import qualified Control.Arrow as Arrow
  12 import qualified Control.Monad.Trans.State as State
  13 import qualified Data.Traversable as Traversable
  14 import qualified Data.Monoid as Monoid
  15 import Data.Accessor
  16
  17 import qualified Type
  18 import qualified TysWiredIn
  19 import qualified Name
  20 import qualified TyCon
  21 import Outputable ( showSDoc, ppr )
  22
  23 import qualified ForSyDe.Backend.VHDL.AST as AST
  24
  25 import VHDLTypes
  26 import Flatten
  27 import FlattenTypes
  28 import TranslatorTypes
  29 import HsValueMap
  30 import Pretty
  31
  32 createDesignFiles ::
  33   FlatFuncMap
  34   -> [(AST.VHDLId, AST.DesignFile)]
  35
  36 createDesignFiles flatfuncmap =
  37   -- TODO: Output types
  38   map (Arrow.second $ AST.DesignFile context) units
  39   where
  40     init_session = VHDLSession Map.empty builtin_funcs
  41     (units, final_session) =
  42       State.runState (createLibraryUnits flatfuncmap) init_session
  43     context = [
  44       AST.Library $ mkVHDLId "IEEE",
  45       AST.Use $ (AST.NSimple $ mkVHDLId "IEEE.std_logic_1164") AST.:.: AST.All]
  46
  47 createLibraryUnits ::
  48   FlatFuncMap
  49   -> VHDLState [(AST.VHDLId, [AST.LibraryUnit])]
  50
  51 createLibraryUnits flatfuncmap = do
  52   let hsfuncs = Map.keys flatfuncmap
  53   let flatfuncs = Map.elems flatfuncmap
  54   entities <- Monad.zipWithM createEntity hsfuncs flatfuncs
  55   archs <- Monad.zipWithM createArchitecture hsfuncs flatfuncs
  56   return $ zipWith
  57     (\ent arch ->
  58       let AST.EntityDec id _ = ent in
  59       (id, [AST.LUEntity ent, AST.LUArch arch])
  60     )
  61     entities archs
  62
  63 -- | Create an entity for a given function
  64 createEntity ::
  65   HsFunction -- | The function signature
  66   -> FlatFunction -- | The FlatFunction
  67   -> VHDLState AST.EntityDec -- | The resulting entity
  68
  69 createEntity hsfunc flatfunc =
  70       let
  71         sigs    = flat_sigs flatfunc
  72         args    = flat_args flatfunc
  73         res     = flat_res  flatfunc
  74         (ty_decls, args') = Traversable.traverse (Traversable.traverse (mkMap sigs)) args
  75         (ty_decls', res') = Traversable.traverse (mkMap sigs) res
  76         -- TODO: Unique ty_decls
  77         ent_decl' = createEntityAST hsfunc args' res'
  78         pkg_id = mkVHDLId $ (AST.fromVHDLId entity_id) ++ "_types"
  79         pkg_decl = if null ty_decls && null ty_decls'
  80           then Nothing
  81           else Just $ AST.PackageDec pkg_id (map AST.PDITD $ ty_decls ++ ty_decls')
  82         -- TODO: Output package
  83         AST.EntityDec entity_id _ = ent_decl'
  84         signature = Entity entity_id args' res'
  85       in do
  86         modA vsSignatures (Map.insert hsfunc signature)
  87         return ent_decl'
  88   where
  89     mkMap ::
  90       [(SignalId, SignalInfo)]
  91       -> SignalId
  92       -> ([AST.TypeDec], Maybe (AST.VHDLId, AST.TypeMark))
  93     mkMap sigmap id =
  94       if isPortSigUse $ sigUse info
  95         then
  96           let (decs, type_mark) = vhdl_ty ty in
  97           (decs, Just (mkVHDLId nm, type_mark))
  98         else
  99           (Monoid.mempty, Nothing)
 100       where
 101         info = Maybe.fromMaybe
 102           (error $ "Signal not found in the name map? This should not happen!")
 103           (lookup id sigmap)
 104         nm = Maybe.fromMaybe
 105           (error $ "Signal not named? This should not happen!")
 106           (sigName info)
 107         ty = sigTy info
 108
 109   -- | Create the VHDL AST for an entity
 110 createEntityAST ::
 111   HsFunction            -- | The signature of the function we're working with
 112   -> [VHDLSignalMap]    -- | The entity's arguments
 113   -> VHDLSignalMap      -- | The entity's result
 114   -> AST.EntityDec      -- | The entity with the ent_decl filled in as well
 115
 116 createEntityAST hsfunc args res =
 117   AST.EntityDec vhdl_id ports
 118   where
 119     vhdl_id = mkEntityId hsfunc
 120     ports = concatMap (mapToPorts AST.In) args
 121             ++ mapToPorts AST.Out res
 122             ++ clk_port
 123     mapToPorts :: AST.Mode -> VHDLSignalMap -> [AST.IfaceSigDec]
 124     mapToPorts mode m =
 125       Maybe.catMaybes $ map (mkIfaceSigDec mode) (Foldable.toList m)
 126     -- Add a clk port if we have state
 127     clk_port = if hasState hsfunc
 128       then
 129         [AST.IfaceSigDec (mkVHDLId "clk") AST.In VHDL.std_logic_ty]
 130       else
 131         []
 132
 133 -- | Create a port declaration
 134 mkIfaceSigDec ::
 135   AST.Mode                         -- | The mode for the port (In / Out)
 136   -> Maybe (AST.VHDLId, AST.TypeMark)    -- | The id and type for the port
 137   -> Maybe AST.IfaceSigDec               -- | The resulting port declaration
 138
 139 mkIfaceSigDec mode (Just (id, ty)) = Just $ AST.IfaceSigDec id mode ty
 140 mkIfaceSigDec _ Nothing = Nothing
 141
 142 -- | Generate a VHDL entity name for the given hsfunc
 143 mkEntityId hsfunc =
 144   -- TODO: This doesn't work for functions with multiple signatures!
 145   mkVHDLId $ hsFuncName hsfunc
 146
 147 -- | Create an architecture for a given function
 148 createArchitecture ::
 149   HsFunction -- ^ The function signature
 150   -> FlatFunction -- ^ The FlatFunction
 151   -> VHDLState AST.ArchBody -- ^ The architecture for this function
 152
 153 createArchitecture hsfunc flatfunc = do
 154   signaturemap <- getA vsSignatures
 155   let signature = Maybe.fromMaybe
 156         (error $ "Generating architecture for function " ++ (prettyShow hsfunc) ++ "without signature? This should not happen!")
 157         (Map.lookup hsfunc signaturemap)
 158   let entity_id = ent_id signature
 159     -- Create concurrent statements for all signal definitions
 160   let statements = zipWith (mkConcSm signaturemap sigs) defs [0..]
 161   return $ AST.ArchBody (mkVHDLId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
 162   where
 163     sigs = flat_sigs flatfunc
 164     args = flat_args flatfunc
 165     res  = flat_res  flatfunc
 166     defs = flat_defs flatfunc
 167     -- Create signal declarations for all internal and state signals
 168     (ty_decls, sig_decs)  = Arrow.second Maybe.catMaybes $ Traversable.traverse (mkSigDec . snd) sigs
 169     -- TODO: Unique ty_decls
 170     -- TODO: Store ty_decls somewhere
 171     procs = map mkStateProcSm (makeStatePairs flatfunc)
 172     procs' = map AST.CSPSm procs
 173
 174 -- | Looks up all pairs of old state, new state signals, together with
 175 --   the state id they represent.
 176 makeStatePairs :: FlatFunction -> [(StateId, SignalInfo, SignalInfo)]
 177 makeStatePairs flatfunc =
 178   [(Maybe.fromJust $ oldStateId $ sigUse old_info, old_info, new_info)
 179     | old_info <- map snd (flat_sigs flatfunc)
 180     , new_info <- map snd (flat_sigs flatfunc)
 181         -- old_info must be an old state (and, because of the next equality,
 182         -- new_info must be a new state).
 183         , Maybe.isJust $ oldStateId $ sigUse old_info
 184         -- And the state numbers must match
 185     , (oldStateId $ sigUse old_info) == (newStateId $ sigUse new_info)]
 186
 187     -- Replace the second tuple element with the corresponding SignalInfo
 188     --args_states = map (Arrow.second $ signalInfo sigs) args
 189 mkStateProcSm :: (StateId, SignalInfo, SignalInfo) -> AST.ProcSm
 190 mkStateProcSm (num, old, new) =
 191   AST.ProcSm label [clk] [statement]
 192   where
 193     label       = mkVHDLId $ "state_" ++ (show num)
 194     clk         = mkVHDLId "clk"
 195     rising_edge = AST.NSimple $ mkVHDLId "rising_edge"
 196     wform       = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple $ getSignalId new) Nothing]
 197     assign      = AST.SigAssign (AST.NSimple $ getSignalId old) wform
 198     rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
 199     statement   = AST.IfSm rising_edge_clk [assign] [] Nothing
 200
 201 mkSigDec :: SignalInfo -> ([AST.TypeDec], Maybe AST.SigDec)
 202 mkSigDec info =
 203   let use = sigUse info in
 204   if isInternalSigUse use || isStateSigUse use then
 205     let (ty_decls, type_mark) = vhdl_ty ty in
 206     (ty_decls, Just $ AST.SigDec (getSignalId info) type_mark Nothing)
 207   else
 208     ([], Nothing)
 209   where
 210     ty = sigTy info
 211
 212 -- | Creates a VHDL Id from a named SignalInfo. Errors out if the SignalInfo
 213 --   is not named.
 214 getSignalId :: SignalInfo -> AST.VHDLId
 215 getSignalId info =
 216     mkVHDLId $ Maybe.fromMaybe
 217       (error $ "Unnamed signal? This should not happen!")
 218       (sigName info)
 219
 220 -- | Transforms a signal definition into a VHDL concurrent statement
 221 mkConcSm ::
 222   SignatureMap             -- ^ The interfaces of functions in the session
 223   -> [(SignalId, SignalInfo)] -- ^ The signals in the current architecture
 224   -> SigDef                -- ^ The signal definition
 225   -> Int                   -- ^ A number that will be unique for all
 226                            --   concurrent statements in the architecture.
 227   -> AST.ConcSm            -- ^ The corresponding VHDL component instantiation.
 228
 229 mkConcSm signatures sigs (FApp hsfunc args res) num =
 230   let
 231     signature = Maybe.fromMaybe
 232         (error $ "Using function '" ++ (prettyShow hsfunc) ++ "' without signature? This should not happen!")
 233         (Map.lookup hsfunc signatures)
 234     entity_id = ent_id signature
 235     label = (AST.fromVHDLId entity_id) ++ "_" ++ (show num)
 236     -- Add a clk port if we have state
 237     clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLId "clk") "clk"
 238     portmaps = mkAssocElems sigs args res signature ++ (if hasState hsfunc then [clk_port] else [])
 239   in
 240     AST.CSISm $ AST.CompInsSm (mkVHDLId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)
 241
 242 mkConcSm _ sigs (UncondDef src dst) _ =
 243   let
 244     src_expr  = vhdl_expr src
 245     src_wform = AST.Wform [AST.WformElem src_expr Nothing]
 246     dst_name  = AST.NSimple (getSignalId $ signalInfo sigs dst)
 247     assign    = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
 248   in
 249     AST.CSSASm assign
 250   where
 251     vhdl_expr (Left id) = mkIdExpr sigs id
 252     vhdl_expr (Right expr) =
 253       case expr of
 254         (EqLit id lit) ->
 255           (mkIdExpr sigs id) AST.:=: (AST.PrimLit lit)
 256         (Literal lit) ->
 257           AST.PrimLit lit
 258         (Eq a b) ->
 259           (mkIdExpr sigs a) AST.:=: (mkIdExpr sigs b)
 260
 261 mkConcSm _ sigs (CondDef cond true false dst) _ =
 262   let
 263     cond_expr  = mkIdExpr sigs cond
 264     true_expr  = mkIdExpr sigs true
 265     false_expr  = mkIdExpr sigs false
 266     false_wform = AST.Wform [AST.WformElem false_expr Nothing]
 267     true_wform = AST.Wform [AST.WformElem true_expr Nothing]
 268     whenelse = AST.WhenElse true_wform cond_expr
 269     dst_name  = AST.NSimple (getSignalId $ signalInfo sigs dst)
 270     assign    = dst_name AST.:<==: (AST.ConWforms [whenelse] false_wform Nothing)
 271   in
 272     AST.CSSASm assign
 273
 274 -- | Turn a SignalId into a VHDL Expr
 275 mkIdExpr :: [(SignalId, SignalInfo)] -> SignalId -> AST.Expr
 276 mkIdExpr sigs id =
 277   let src_name  = AST.NSimple (getSignalId $ signalInfo sigs id) in
 278   AST.PrimName src_name
 279
 280 mkAssocElems ::
 281   [(SignalId, SignalInfo)]      -- | The signals in the current architecture
 282   -> [SignalMap]                -- | The signals that are applied to function
 283   -> SignalMap                  -- | the signals in which to store the function result
 284   -> Entity                     -- | The entity to map against.
 285   -> [AST.AssocElem]            -- | The resulting port maps
 286
 287 mkAssocElems sigmap args res entity =
 288     -- Create the actual AssocElems
 289     Maybe.catMaybes $ zipWith mkAssocElem ports sigs
 290   where
 291     -- Turn the ports and signals from a map into a flat list. This works,
 292     -- since the maps must have an identical form by definition. TODO: Check
 293     -- the similar form?
 294     arg_ports = concat (map Foldable.toList (ent_args entity))
 295     res_ports = Foldable.toList (ent_res entity)
 296     arg_sigs  = (concat (map Foldable.toList args))
 297     res_sigs  = Foldable.toList res
 298     -- Extract the id part from the (id, type) tuple
 299     ports     = (map (fmap fst) (arg_ports ++ res_ports))
 300     -- Translate signal numbers into names
 301     sigs      = (map (lookupSigName sigmap) (arg_sigs ++ res_sigs))
 302
 303 -- | Look up a signal in the signal name map
 304 lookupSigName :: [(SignalId, SignalInfo)] -> SignalId -> String
 305 lookupSigName sigs sig = name
 306   where
 307     info = Maybe.fromMaybe
 308       (error $ "Unknown signal " ++ (show sig) ++ " used? This should not happen!")
 309       (lookup sig sigs)
 310     name = Maybe.fromMaybe
 311       (error $ "Unnamed signal " ++ (show sig) ++ " used? This should not happen!")
 312       (sigName info)
 313
 314 -- | Create an VHDL port -> signal association
 315 mkAssocElem :: Maybe AST.VHDLId -> String -> Maybe AST.AssocElem
 316 mkAssocElem (Just port) signal = Just $ Just port AST.:=>: (AST.ADName (AST.NSimple (mkVHDLId signal)))
 317 mkAssocElem Nothing _ = Nothing
 318
 319 -- | The VHDL Bit type
 320 bit_ty :: AST.TypeMark
 321 bit_ty = AST.unsafeVHDLBasicId "Bit"
 322
 323 -- | The VHDL Boolean type
 324 bool_ty :: AST.TypeMark
 325 bool_ty = AST.unsafeVHDLBasicId "Boolean"
 326
 327 -- | The VHDL std_logic
 328 std_logic_ty :: AST.TypeMark
 329 std_logic_ty = AST.unsafeVHDLBasicId "std_logic"
 330
 331 -- Translate a Haskell type to a VHDL type
 332 vhdl_ty :: Type.Type -> ([AST.TypeDec], AST.TypeMark)
 333 vhdl_ty ty = Maybe.fromMaybe
 334   (error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty))
 335   (vhdl_ty_maybe ty)
 336
 337 -- Translate a Haskell type to a VHDL type, optionally generating a type
 338 -- declaration for the type.
 339 vhdl_ty_maybe :: Type.Type -> Maybe ([AST.TypeDec], AST.TypeMark)
 340 vhdl_ty_maybe ty =
 341   if Type.coreEqType ty TysWiredIn.boolTy
 342     then
 343       Just ([], bool_ty)
 344     else
 345       case Type.splitTyConApp_maybe ty of
 346         Just (tycon, args) ->
 347           let name = TyCon.tyConName tycon in
 348             -- TODO: Do something more robust than string matching
 349             case Name.getOccString name of
 350               "Bit"      -> Just ([], std_logic_ty)
 351               "FSVec"    ->
 352                 let
 353                   [len, el_ty] = args
 354                   -- TODO: Find actual number
 355                   ty_id = mkVHDLId ("vector_" ++ (show len))
 356                   -- TODO: Use el_ty
 357                   range = AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "16")]
 358                   ty_def = AST.TDA $ AST.ConsArrayDef range std_logic_ty
 359                   ty_dec = AST.TypeDec ty_id ty_def
 360                 in
 361                   Just ([ty_dec], ty_id)
 362               otherwise  -> Nothing
 363         otherwise -> Nothing
 364
 365 -- Shortcut
 366 mkVHDLId :: String -> AST.VHDLId
 367 mkVHDLId s =
 368   AST.unsafeVHDLBasicId $ (strip_multiscore . strip_invalid) s
 369   where
 370     -- Strip invalid characters.
 371     strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
 372     -- Strip multiple adjacent underscores
 373     strip_multiscore = concat . map (\cs ->
 374         case cs of
 375           ('_':_) -> "_"
 376           _ -> cs
 377       ) . List.group
 378
 379 -- | A consise representation of a (set of) ports on a builtin function
 380 type PortMap = HsValueMap (String, AST.TypeMark)
 381 -- | A consise representation of a builtin function
 382 data BuiltIn = BuiltIn String [PortMap] PortMap
 383
 384 -- | Translate a list of concise representation of builtin functions to a
 385 --   SignatureMap
 386 mkBuiltins :: [BuiltIn] -> SignatureMap
 387 mkBuiltins = Map.fromList . map (\(BuiltIn name args res) ->
 388     (HsFunction name (map useAsPort args) (useAsPort res),
 389      Entity (VHDL.mkVHDLId name) (map toVHDLSignalMap args) (toVHDLSignalMap res))
 390   )
 391
 392 builtin_hsfuncs = Map.keys builtin_funcs
 393 builtin_funcs = mkBuiltins
 394   [
 395     BuiltIn "hwxor" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)),
 396     BuiltIn "hwand" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)),
 397     BuiltIn "hwor" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)),
 398     BuiltIn "hwnot" [(Single ("a", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty))
 399   ]
 400
 401 -- | Map a port specification of a builtin function to a VHDL Signal to put in
 402 --   a VHDLSignalMap
 403 toVHDLSignalMap :: HsValueMap (String, AST.TypeMark) -> VHDLSignalMap
 404 toVHDLSignalMap = fmap (\(name, ty) -> Just (mkVHDLId name, ty))