Translator.hs

   1 module Main(main) where
   2 import GHC
   3 import CoreSyn
   4 import qualified CoreUtils
   5 import qualified Var
   6 import qualified Type
   7 import qualified TyCon
   8 import qualified DataCon
   9 import qualified Maybe
  10 import qualified Module
  11 import qualified Control.Monad.State as State
  12 import Name
  13 import Data.Generics
  14 import NameEnv ( lookupNameEnv )
  15 import HscTypes ( cm_binds, cm_types )
  16 import MonadUtils ( liftIO )
  17 import Outputable ( showSDoc, ppr )
  18 import GHC.Paths ( libdir )
  19 import DynFlags ( defaultDynFlags )
  20 import List ( find )
  21 import qualified List
  22 import qualified Monad
  23
  24 -- The following modules come from the ForSyDe project. They are really
  25 -- internal modules, so ForSyDe.cabal has to be modified prior to installing
  26 -- ForSyDe to get access to these modules.
  27 import qualified ForSyDe.Backend.VHDL.AST as AST
  28 import qualified ForSyDe.Backend.VHDL.Ppr
  29 import qualified ForSyDe.Backend.Ppr
  30 -- This is needed for rendering the pretty printed VHDL
  31 import Text.PrettyPrint.HughesPJ (render)
  32
  33 main =
  34     do
  35       defaultErrorHandler defaultDynFlags $ do
  36         runGhc (Just libdir) $ do
  37           dflags <- getSessionDynFlags
  38           setSessionDynFlags dflags
  39           --target <- guessTarget "adder.hs" Nothing
  40           --liftIO (print (showSDoc (ppr (target))))
  41           --liftIO $ printTarget target
  42           --setTargets [target]
  43           --load LoadAllTargets
  44           --core <- GHC.compileToCoreSimplified "Adders.hs"
  45           core <- GHC.compileToCoreSimplified "Adders.hs"
  46           liftIO $ printBinds (cm_binds core)
  47           let bind = findBind "full_adder" (cm_binds core)
  48           let NonRec var expr = bind
  49           -- Turn bind into VHDL
  50           let vhdl = State.evalState (mkVHDL bind) (VHDLSession 0 builtin_funcs)
  51           liftIO $ putStr $ showSDoc $ ppr expr
  52           liftIO $ putStr "\n\n"
  53           liftIO $ putStr $ render $ ForSyDe.Backend.Ppr.ppr $ vhdl
  54           return expr
  55   where
  56     -- Turns the given bind into VHDL
  57     mkVHDL bind = do
  58       -- Get the function signature
  59       (name, f) <- mkHWFunction bind
  60       -- Add it to the session
  61       addFunc name f
  62       arch <- getArchitecture bind
  63       return arch
  64
  65 printTarget (Target (TargetFile file (Just x)) obj Nothing) =
  66   print $ show file
  67
  68 printBinds [] = putStr "done\n\n"
  69 printBinds (b:bs) = do
  70   printBind b
  71   putStr "\n"
  72   printBinds bs
  73
  74 printBind (NonRec b expr) = do
  75   putStr "NonRec: "
  76   printBind' (b, expr)
  77
  78 printBind (Rec binds) = do
  79   putStr "Rec: \n"
  80   foldl1 (>>) (map printBind' binds)
  81
  82 printBind' (b, expr) = do
  83   putStr $ getOccString b
  84   --putStr $ showSDoc $ ppr expr
  85   putStr "\n"
  86
  87 findBind :: String -> [CoreBind] -> CoreBind
  88 findBind lookfor =
  89   -- This ignores Recs and compares the name of the bind with lookfor,
  90   -- disregarding any namespaces in OccName and extra attributes in Name and
  91   -- Var.
  92   Maybe.fromJust . find (\b -> case b of
  93     Rec l -> False
  94     NonRec var _ -> lookfor == (occNameString $ nameOccName $ getName var)
  95   )
  96
  97 getPortMapEntry ::
  98   SignalNameMap AST.VHDLId  -- The port name to bind to
  99   -> SignalNameMap AST.VHDLId
 100                             -- The signal or port to bind to it
 101   -> AST.AssocElem          -- The resulting port map entry
 102
 103 -- Accepts a port name and an argument to map to it.
 104 -- Returns the appropriate line for in the port map
 105 getPortMapEntry (Signal portname) (Signal signame) =
 106   (Just portname) AST.:=>: (AST.ADName (AST.NSimple signame))
 107
 108 getInstantiations ::
 109   [SignalNameMap AST.VHDLId]   -- The arguments that need to be applied to the
 110                                -- expression.
 111   -> SignalNameMap AST.VHDLId  -- The output ports that the expression should generate.
 112   -> [(CoreBndr, SignalNameMap AST.VHDLId)]
 113                                -- A list of bindings in effect
 114   -> CoreSyn.CoreExpr          -- The expression to generate an architecture for
 115   -> VHDLState ([AST.SigDec], [AST.ConcSm])
 116                                -- The resulting VHDL code
 117
 118 -- A lambda expression binds the first argument (a) to the binder b.
 119 getInstantiations (a:as) outs binds (Lam b expr) =
 120   getInstantiations as outs ((b, a):binds) expr
 121
 122 -- A case expression that checks a single variable and has a single
 123 -- alternative, can be used to take tuples apart
 124 getInstantiations args outs binds (Case (Var v) b _ [res]) =
 125   -- Split out the type of alternative constructor, the variables it binds
 126   -- and the expression to evaluate with the variables bound.
 127   let (altcon, bind_vars, expr) = res in
 128   case altcon of
 129     DataAlt datacon ->
 130       if (DataCon.isTupleCon datacon) then
 131         let
 132           -- Lookup the scrutinee (which must be a variable bound to a tuple) in
 133           -- the existing bindings list and get the portname map for each of
 134           -- it's elements.
 135           Tuple tuple_ports = Maybe.fromMaybe
 136             (error $ "Case expression uses unknown scrutinee " ++ getOccString v)
 137             (lookup v binds)
 138           -- Merge our existing binds with the new binds.
 139           binds' = (zip bind_vars tuple_ports) ++ binds
 140         in
 141           -- Evaluate the expression with the new binds list
 142           getInstantiations args outs binds' expr
 143       else
 144         error "Data constructors other than tuples not supported"
 145     otherwise ->
 146       error "Case binders other than tuples not supported"
 147
 148 -- An application is an instantiation of a component
 149 getInstantiations args outs binds app@(App expr arg) = do
 150   let ((Var f), fargs) = collectArgs app
 151       name = getOccString f
 152   if isTupleConstructor f
 153     then do
 154       -- Get the signals we should bind our results to
 155       let Tuple outports = outs
 156       -- Split the tuple constructor arguments into types and actual values.
 157       let (_, vals) = splitTupleConstructorArgs fargs
 158       -- Bind each argument to each output signal
 159       res <- sequence $ zipWith
 160         (\outs' expr' -> getInstantiations args outs' binds expr')
 161         outports vals
 162       -- res is a list of pairs of lists, so split out the signals and
 163       -- components into separate lists of lists
 164       let (sigs, comps) = unzip res
 165       -- And join all the signals and component instantiations together
 166       return $ (concat sigs, concat comps)
 167     else do
 168       -- This is an normal function application, which maps to a component
 169       -- instantiation.
 170       -- Lookup the hwfunction to instantiate
 171       HWFunction inports outport <- getHWFunc name
 172       -- Generate a unique name for the application
 173       appname <- uniqueName "app"
 174       -- Expand each argument to a signal or port name, possibly generating
 175       -- new signals and component instantiations
 176       (sigs, comps, args) <- expandArgs binds fargs
 177       -- Bind each of the input ports to the expanded signal or port
 178       let inmaps = zipWith getPortMapEntry inports args
 179       -- Bind each of the output ports to our output signals
 180       let outmaps = mapOutputPorts outport outs
 181       -- Build and return a component instantiation
 182       let comp = AST.CompInsSm
 183             (AST.unsafeVHDLBasicId appname)
 184             (AST.IUEntity (AST.NSimple (AST.unsafeVHDLBasicId name)))
 185             (AST.PMapAspect (inmaps ++ outmaps))
 186       return (sigs, (AST.CSISm comp) : comps)
 187
 188 getInstantiations args outs binds expr =
 189   error $ "Unsupported expression" ++ (showSDoc $ ppr $ expr)
 190
 191 expandExpr ::
 192   [(CoreBndr, SignalNameMap AST.VHDLId)]
 193                                          -- A list of bindings in effect
 194   -> CoreExpr                            -- The expression to expand
 195   -> VHDLState (
 196        [AST.SigDec],                     -- Needed signal declarations
 197        [AST.ConcSm],                     -- Needed component instantations and
 198                                          -- signal assignments.
 199        [SignalNameMap AST.VHDLId],       -- The signal names corresponding to
 200                                          -- the expression's arguments
 201        SignalNameMap AST.VHDLId)         -- The signal names corresponding to
 202                                          -- the expression's result.
 203 expandExpr binds lam@(Lam b expr) = do
 204   -- Generate a new signal to which we will expect this argument to be bound.
 205   signal_name <- uniqueName ("arg-" ++ getOccString b)
 206   -- Find the type of the binder
 207   let (arg_ty, _) = Type.splitFunTy (CoreUtils.exprType lam)
 208   -- Create signal names for the binder
 209   let arg_signal = getPortNameMapForTy ("xxx") arg_ty
 210   -- Create the corresponding signal declarations
 211   let signal_decls = mkSignalsFromMap arg_signal
 212   -- Add the binder to the list of binds
 213   let binds' = (b, arg_signal) : binds
 214   -- Expand the rest of the expression
 215   (signal_decls', statements', arg_signals', res_signal') <- expandExpr binds' expr
 216   -- Properly merge the results
 217   return (signal_decls ++ signal_decls',
 218           statements',
 219           arg_signal : arg_signals',
 220           res_signal')
 221
 222 expandExpr binds (Var id) =
 223   return ([], [], [], Signal signal_id)
 224   where
 225     -- Lookup the id in our binds map
 226     Signal signal_id = Maybe.fromMaybe
 227       (error $ "Argument " ++ getOccString id ++ "is unknown")
 228       (lookup id binds)
 229
 230 expandExpr binds app@(App _ _) = do
 231   let ((Var f), args) = collectArgs app
 232   if isTupleConstructor f
 233     then
 234       expandBuildTupleExpr binds args
 235     else
 236       expandApplicationExpr binds (CoreUtils.exprType app) f args
 237
 238 expandExpr binds expr@(Case (Var v) b _ alts) =
 239   case alts of
 240     [alt] -> expandSingleAltCaseExpr binds v b alt
 241     otherwise -> error $ "Multiple alternative case expression not supported: " ++ (showSDoc $ ppr expr)
 242
 243 expandExpr binds expr@(Case _ b _ _) =
 244   error $ "Case expression with non-variable scrutinee not supported: " ++ (showSDoc $ ppr expr)
 245
 246 expandExpr binds expr =
 247   error $ "Unsupported expression: " ++ (showSDoc $ ppr $ expr)
 248
 249 -- Expands the construction of a tuple into VHDL
 250 expandBuildTupleExpr ::
 251   [(CoreBndr, SignalNameMap AST.VHDLId)]
 252                                          -- A list of bindings in effect
 253   -> [CoreExpr]                          -- A list of expressions to put in the tuple
 254   -> VHDLState ( [AST.SigDec], [AST.ConcSm], [SignalNameMap AST.VHDLId], SignalNameMap AST.VHDLId)
 255                                          -- See expandExpr
 256 expandBuildTupleExpr binds args = do
 257   -- Split the tuple constructor arguments into types and actual values.
 258   let (_, vals) = splitTupleConstructorArgs args
 259   -- Expand each of the values in the tuple
 260   (signals_declss, statementss, arg_signalss, res_signals) <-
 261     (Monad.liftM List.unzip4) $ mapM (expandExpr binds) vals
 262   if any (not . null) arg_signalss
 263     then error "Putting high order functions in tuples not supported"
 264     else
 265       return (
 266         concat signals_declss,
 267         concat statementss,
 268         [],
 269         Tuple res_signals)
 270
 271 -- Expands the most simple case expression that scrutinizes a plain variable
 272 -- and has a single alternative. This simple form currently allows only for
 273 -- unpacking tuple variables.
 274 expandSingleAltCaseExpr ::
 275   [(CoreBndr, SignalNameMap AST.VHDLId)]
 276                             -- A list of bindings in effect
 277   -> Var.Var                -- The scrutinee
 278   -> CoreBndr               -- The binder to bind the scrutinee to
 279   -> CoreAlt                -- The single alternative
 280   -> VHDLState ( [AST.SigDec], [AST.ConcSm], [SignalNameMap AST.VHDLId], SignalNameMap AST.VHDLId)
 281                                          -- See expandExpr
 282
 283 expandSingleAltCaseExpr binds v b alt@(DataAlt datacon, bind_vars, expr) =
 284   if not (DataCon.isTupleCon datacon)
 285     then
 286       error $ "Dataconstructors other than tuple constructors not supported in case pattern of alternative: " ++ (showSDoc $ ppr alt)
 287     else
 288       let
 289         -- Lookup the scrutinee (which must be a variable bound to a tuple) in
 290         -- the existing bindings list and get the portname map for each of
 291         -- it's elements.
 292         Tuple tuple_ports = Maybe.fromMaybe
 293           (error $ "Case expression uses unknown scrutinee " ++ getOccString v)
 294           (lookup v binds)
 295         -- TODO include b in the binds list
 296         -- Merge our existing binds with the new binds.
 297         binds' = (zip bind_vars tuple_ports) ++ binds
 298       in
 299         -- Expand the expression with the new binds list
 300         expandExpr binds' expr
 301
 302 expandSingleAltCaseExpr _ _ _ alt =
 303   error $ "Case patterns other than data constructors not supported in case alternative: " ++ (showSDoc $ ppr alt)
 304
 305
 306 -- Expands the application of argument to a function into VHDL
 307 expandApplicationExpr ::
 308   [(CoreBndr, SignalNameMap AST.VHDLId)]
 309                                          -- A list of bindings in effect
 310   -> Type                                -- The result type of the function call
 311   -> Var.Var                             -- The function to call
 312   -> [CoreExpr]                          -- A list of argumetns to apply to the function
 313   -> VHDLState ( [AST.SigDec], [AST.ConcSm], [SignalNameMap AST.VHDLId], SignalNameMap AST.VHDLId)
 314                                          -- See expandExpr
 315 expandApplicationExpr binds ty f args = do
 316   let name = getOccString f
 317   -- Generate a unique name for the application
 318   appname <- uniqueName ("app-" ++ name)
 319   -- Lookup the hwfunction to instantiate
 320   HWFunction inports outport <- getHWFunc name
 321   -- Expand each of the args, so each of them is reduced to output signals
 322   (arg_signal_decls, arg_statements, arg_res_signals) <- expandArgs binds args
 323   -- Bind each of the input ports to the expanded arguments
 324   let inmaps = concat $ zipWith createAssocElems inports arg_res_signals
 325   -- Create signal names for our result
 326   let res_signal = getPortNameMapForTy (appname ++ "-out") ty
 327   -- Create the corresponding signal declarations
 328   let signal_decls = mkSignalsFromMap res_signal
 329   -- Bind each of the output ports to our output signals
 330   let outmaps = mapOutputPorts outport res_signal
 331   -- Instantiate the component
 332   let component = AST.CSISm $ AST.CompInsSm
 333         (AST.unsafeVHDLBasicId appname)
 334         (AST.IUEntity (AST.NSimple (AST.unsafeVHDLBasicId name)))
 335         (AST.PMapAspect (inmaps ++ outmaps))
 336   -- Merge the generated declarations
 337   return (
 338     signal_decls ++ arg_signal_decls,
 339     component : arg_statements,
 340     [], -- We don't take any extra arguments; we don't support higher order functions yet
 341     res_signal)
 342
 343 -- Creates a list of AssocElems (port map lines) that maps the given signals
 344 -- to the given ports.
 345 createAssocElems ::
 346   SignalNameMap AST.VHDLId      -- The port names to bind to
 347   -> SignalNameMap AST.VHDLId   -- The signals to bind to it
 348   -> [AST.AssocElem]            -- The resulting port map lines
 349
 350 createAssocElems (Signal port_id) (Signal signal_id) =
 351   [(Just port_id) AST.:=>: (AST.ADName (AST.NSimple signal_id))]
 352
 353 createAssocElems (Tuple ports) (Tuple signals) =
 354   concat $ zipWith createAssocElems ports signals
 355
 356 -- Generate a signal declaration for a signal with the given name and the
 357 -- given type and no value. Also returns the id of the signal.
 358 mkSignal :: String -> AST.TypeMark -> (AST.VHDLId, AST.SigDec)
 359 mkSignal name ty =
 360   (id, mkSignalFromId id ty)
 361   where
 362     id = AST.unsafeVHDLBasicId name
 363
 364 mkSignalFromId :: AST.VHDLId -> AST.TypeMark -> AST.SigDec
 365 mkSignalFromId id ty =
 366   AST.SigDec id ty Nothing
 367
 368 -- Generates signal declarations for all the signals in the given map
 369 mkSignalsFromMap ::
 370   SignalNameMap AST.VHDLId
 371   -> [AST.SigDec]
 372
 373 mkSignalsFromMap (Signal id) =
 374   -- TODO: This uses the bit type hardcoded
 375   [mkSignalFromId id vhdl_bit_ty]
 376
 377 mkSignalsFromMap (Tuple signals) =
 378   concat $ map mkSignalsFromMap signals
 379
 380 expandArgs ::
 381   [(CoreBndr, SignalNameMap AST.VHDLId)] -- A list of bindings in effect
 382   -> [CoreExpr]                          -- The arguments to expand
 383   -> VHDLState ([AST.SigDec], [AST.ConcSm], [SignalNameMap AST.VHDLId])
 384                                          -- The resulting signal declarations,
 385                                          -- component instantiations and a
 386                                          -- VHDLName for each of the
 387                                          -- expressions passed in.
 388 expandArgs binds (e:exprs) = do
 389   -- Expand the first expression
 390   (signal_decls, statements, arg_signals, res_signal) <- expandExpr binds e
 391   if not (null arg_signals)
 392     then error $ "Passing functions as arguments not supported: " ++ (showSDoc $ ppr e)
 393     else do
 394       (signal_decls', statements', res_signals') <- expandArgs binds exprs
 395       return (
 396         signal_decls ++ signal_decls',
 397         statements ++ statements',
 398         res_signal : res_signals')
 399
 400 expandArgs _ [] = return ([], [], [])
 401
 402 -- Is the given name a (binary) tuple constructor
 403 isTupleConstructor :: Var.Var -> Bool
 404 isTupleConstructor var =
 405   Name.isWiredInName name
 406   && Name.nameModule name == tuple_mod
 407   && (Name.occNameString $ Name.nameOccName name) == "(,)"
 408   where
 409     name = Var.varName var
 410     mod = nameModule name
 411     tuple_mod = Module.mkModule (Module.stringToPackageId "ghc-prim") (Module.mkModuleName "GHC.Tuple")
 412
 413 -- Split arguments into type arguments and value arguments This is probably
 414 -- not really sufficient (not sure if Types can actually occur as value
 415 -- arguments...)
 416 splitTupleConstructorArgs :: [CoreExpr] -> ([CoreExpr], [CoreExpr])
 417 splitTupleConstructorArgs (e:es) =
 418   case e of
 419     Type t     -> (e:tys, vals)
 420     otherwise  -> (tys, e:vals)
 421   where
 422     (tys, vals) = splitTupleConstructorArgs es
 423
 424 splitTupleConstructorArgs [] = ([], [])
 425
 426 mapOutputPorts ::
 427   SignalNameMap AST.VHDLId      -- The output portnames of the component
 428   -> SignalNameMap AST.VHDLId   -- The output portnames and/or signals to map these to
 429   -> [AST.AssocElem]            -- The resulting output ports
 430
 431 -- Map the output port of a component to the output port of the containing
 432 -- entity.
 433 mapOutputPorts (Signal portname) (Signal signalname) =
 434   [(Just portname) AST.:=>: (AST.ADName (AST.NSimple signalname))]
 435
 436 -- Map matching output ports in the tuple
 437 mapOutputPorts (Tuple ports) (Tuple signals) =
 438   concat (zipWith mapOutputPorts ports signals)
 439
 440 getArchitecture ::
 441   CoreBind                  -- The binder to expand into an architecture
 442   -> VHDLState AST.ArchBody -- The resulting architecture
 443
 444 getArchitecture (Rec _) = error "Recursive binders not supported"
 445
 446 getArchitecture (NonRec var expr) = do
 447   let name = (getOccString var)
 448   HWFunction inports outport <- getHWFunc name
 449   sess <- State.get
 450   (signal_decls, statements, arg_signals, res_signal) <- expandExpr [] expr
 451   let inport_assigns = concat $ zipWith createSignalAssignments arg_signals inports
 452   let outport_assigns = createSignalAssignments outport res_signal
 453   return $ AST.ArchBody
 454     (AST.unsafeVHDLBasicId "structural")
 455     -- Use unsafe for now, to prevent pulling in ForSyDe error handling
 456     (AST.NSimple (AST.unsafeVHDLBasicId name))
 457     (map AST.BDISD signal_decls)
 458     (inport_assigns ++ outport_assigns ++ statements)
 459
 460 -- Create concurrent assignments of one map of signals to another. The maps
 461 -- should have a similar form.
 462 createSignalAssignments ::
 463   SignalNameMap AST.VHDLId         -- The signals to assign to
 464   -> SignalNameMap AST.VHDLId      -- The signals to assign
 465   -> [AST.ConcSm]                  -- The resulting assignments
 466
 467 -- A simple assignment of one signal to another (greatly complicated because
 468 -- signal assignments can be conditional with multiple conditions in VHDL).
 469 createSignalAssignments (Signal dst) (Signal src) =
 470     [AST.CSSASm assign]
 471   where
 472     src_name  = AST.NSimple src
 473     src_expr  = AST.PrimName src_name
 474     src_wform = AST.Wform [AST.WformElem src_expr Nothing]
 475     dst_name  = (AST.NSimple dst)
 476     assign    = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
 477
 478 createSignalAssignments (Tuple dsts) (Tuple srcs) =
 479   concat $ zipWith createSignalAssignments dsts srcs
 480
 481 createSignalAssignments dst src =
 482   error $ "Non matching source and destination: " ++ show dst ++ "\nand\n" ++  show src
 483
 484 data SignalNameMap t =
 485   Tuple [SignalNameMap t]
 486   | Signal  t
 487   deriving (Show)
 488
 489 -- Generate a port name map (or multiple for tuple types) in the given direction for
 490 -- each type given.
 491 getPortNameMapForTys :: String -> Int -> [Type] -> [SignalNameMap AST.VHDLId]
 492 getPortNameMapForTys prefix num [] = []
 493 getPortNameMapForTys prefix num (t:ts) =
 494   (getPortNameMapForTy (prefix ++ show num) t) : getPortNameMapForTys prefix (num + 1) ts
 495
 496 getPortNameMapForTy :: String -> Type -> SignalNameMap AST.VHDLId
 497 getPortNameMapForTy name ty =
 498   if (TyCon.isTupleTyCon tycon) then
 499     -- Expand tuples we find
 500     Tuple (getPortNameMapForTys name 0 args)
 501   else -- Assume it's a type constructor application, ie simple data type
 502     -- TODO: Add type?
 503     Signal (AST.unsafeVHDLBasicId name)
 504   where
 505     (tycon, args) = Type.splitTyConApp ty
 506
 507 data HWFunction = HWFunction { -- A function that is available in hardware
 508   inPorts   :: [SignalNameMap AST.VHDLId],
 509   outPort   :: SignalNameMap AST.VHDLId
 510   --entity    :: AST.EntityDec
 511 } deriving (Show)
 512
 513 -- Turns a CoreExpr describing a function into a description of its input and
 514 -- output ports.
 515 mkHWFunction ::
 516   CoreBind                                   -- The core binder to generate the interface for
 517   -> VHDLState (String, HWFunction)          -- The name of the function and its interface
 518
 519 mkHWFunction (NonRec var expr) =
 520     return (name, HWFunction inports outport)
 521   where
 522     name = (getOccString var)
 523     ty = CoreUtils.exprType expr
 524     (fargs, res) = Type.splitFunTys ty
 525     args = if length fargs == 1 then fargs else (init fargs)
 526     --state = if length fargs == 1 then () else (last fargs)
 527     inports = case args of
 528       -- Handle a single port specially, to prevent an extra 0 in the name
 529       [port] -> [getPortNameMapForTy "portin" port]
 530       ps     -> getPortNameMapForTys "portin" 0 ps
 531     outport = getPortNameMapForTy "portout" res
 532
 533 mkHWFunction (Rec _) =
 534   error "Recursive binders not supported"
 535
 536 data VHDLSession = VHDLSession {
 537   nameCount :: Int,                      -- A counter that can be used to generate unique names
 538   funcs     :: [(String, HWFunction)]    -- All functions available, indexed by name
 539 } deriving (Show)
 540
 541 type VHDLState = State.State VHDLSession
 542
 543 -- Add the function to the session
 544 addFunc :: String -> HWFunction -> VHDLState ()
 545 addFunc name f = do
 546   fs <- State.gets funcs -- Get the funcs element from the session
 547   State.modify (\x -> x {funcs = (name, f) : fs }) -- Prepend name and f
 548
 549 -- Lookup the function with the given name in the current session. Errors if
 550 -- it was not found.
 551 getHWFunc :: String -> VHDLState HWFunction
 552 getHWFunc name = do
 553   fs <- State.gets funcs -- Get the funcs element from the session
 554   return $ Maybe.fromMaybe
 555     (error $ "Function " ++ name ++ "is unknown? This should not happen!")
 556     (lookup name fs)
 557
 558 -- Makes the given name unique by appending a unique number.
 559 -- This does not do any checking against existing names, so it only guarantees
 560 -- uniqueness with other names generated by uniqueName.
 561 uniqueName :: String -> VHDLState String
 562 uniqueName name = do
 563   count <- State.gets nameCount -- Get the funcs element from the session
 564   State.modify (\s -> s {nameCount = count + 1})
 565   return $ name ++ "-" ++ (show count)
 566
 567 -- Shortcut
 568 mkVHDLId :: String -> AST.VHDLId
 569 mkVHDLId = AST.unsafeVHDLBasicId
 570
 571 builtin_funcs =
 572   [
 573     ("hwxor", HWFunction [Signal $ mkVHDLId "a", Signal $ mkVHDLId "b"] (Signal $ mkVHDLId "o")),
 574     ("hwand", HWFunction [Signal $ mkVHDLId "a", Signal $ mkVHDLId "b"] (Signal $ mkVHDLId "o")),
 575     ("hwor", HWFunction [Signal $ mkVHDLId "a", Signal $ mkVHDLId "b"] (Signal $ mkVHDLId "o")),
 576     ("hwnot", HWFunction [Signal $ mkVHDLId "i"] (Signal $ mkVHDLId "o"))
 577   ]
 578
 579 vhdl_bit_ty :: AST.TypeMark
 580 vhdl_bit_ty = AST.unsafeVHDLBasicId "Bit"
 581
 582 -- vim: set ts=8 sw=2 sts=2 expandtab: