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