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