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