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