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 = Maybe.fromJust $ findBind (cm_binds core) "full_adder"
  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 :: [CoreBind] -> String -> Maybe CoreBind
  88 findBind binds 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   find (\b -> case b of
  93     Rec l -> False
  94     NonRec var _ -> lookfor == (occNameString $ nameOccName $ getName var)
  95   ) binds
  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 l@(Let (NonRec b bexpr) expr) = do
 231   (signal_decls, statements, arg_signals, res_signals) <- expandExpr binds bexpr
 232   let binds' = (b, res_signals) : binds
 233   (signal_decls', statements', arg_signals', res_signals') <- expandExpr binds' expr
 234   return (
 235     signal_decls ++ signal_decls',
 236     statements ++ statements',
 237     arg_signals',
 238     res_signals')
 239
 240 expandExpr binds app@(App _ _) = do
 241   let ((Var f), args) = collectArgs app
 242   if isTupleConstructor f
 243     then
 244       expandBuildTupleExpr binds args
 245     else
 246       expandApplicationExpr binds (CoreUtils.exprType app) f args
 247
 248 expandExpr binds expr@(Case (Var v) b _ alts) =
 249   case alts of
 250     [alt] -> expandSingleAltCaseExpr binds v b alt
 251     otherwise -> error $ "Multiple alternative case expression not supported: " ++ (showSDoc $ ppr expr)
 252
 253 expandExpr binds expr@(Case _ b _ _) =
 254   error $ "Case expression with non-variable scrutinee not supported: " ++ (showSDoc $ ppr expr)
 255
 256 expandExpr binds expr =
 257   error $ "Unsupported expression: " ++ (showSDoc $ ppr $ expr)
 258
 259 -- Expands the construction of a tuple into VHDL
 260 expandBuildTupleExpr ::
 261   [(CoreBndr, SignalNameMap AST.VHDLId)]
 262                                          -- A list of bindings in effect
 263   -> [CoreExpr]                          -- A list of expressions to put in the tuple
 264   -> VHDLState ( [AST.SigDec], [AST.ConcSm], [SignalNameMap AST.VHDLId], SignalNameMap AST.VHDLId)
 265                                          -- See expandExpr
 266 expandBuildTupleExpr binds args = do
 267   -- Split the tuple constructor arguments into types and actual values.
 268   let (_, vals) = splitTupleConstructorArgs args
 269   -- Expand each of the values in the tuple
 270   (signals_declss, statementss, arg_signalss, res_signals) <-
 271     (Monad.liftM List.unzip4) $ mapM (expandExpr binds) vals
 272   if any (not . null) arg_signalss
 273     then error "Putting high order functions in tuples not supported"
 274     else
 275       return (
 276         concat signals_declss,
 277         concat statementss,
 278         [],
 279         Tuple res_signals)
 280
 281 -- Expands the most simple case expression that scrutinizes a plain variable
 282 -- and has a single alternative. This simple form currently allows only for
 283 -- unpacking tuple variables.
 284 expandSingleAltCaseExpr ::
 285   [(CoreBndr, SignalNameMap AST.VHDLId)]
 286                             -- A list of bindings in effect
 287   -> Var.Var                -- The scrutinee
 288   -> CoreBndr               -- The binder to bind the scrutinee to
 289   -> CoreAlt                -- The single alternative
 290   -> VHDLState ( [AST.SigDec], [AST.ConcSm], [SignalNameMap AST.VHDLId], SignalNameMap AST.VHDLId)
 291                                          -- See expandExpr
 292
 293 expandSingleAltCaseExpr binds v b alt@(DataAlt datacon, bind_vars, expr) =
 294   if not (DataCon.isTupleCon datacon)
 295     then
 296       error $ "Dataconstructors other than tuple constructors not supported in case pattern of alternative: " ++ (showSDoc $ ppr alt)
 297     else
 298       let
 299         -- Lookup the scrutinee (which must be a variable bound to a tuple) in
 300         -- the existing bindings list and get the portname map for each of
 301         -- it's elements.
 302         Tuple tuple_ports = Maybe.fromMaybe
 303           (error $ "Case expression uses unknown scrutinee " ++ getOccString v)
 304           (lookup v binds)
 305         -- TODO include b in the binds list
 306         -- Merge our existing binds with the new binds.
 307         binds' = (zip bind_vars tuple_ports) ++ binds
 308       in
 309         -- Expand the expression with the new binds list
 310         expandExpr binds' expr
 311
 312 expandSingleAltCaseExpr _ _ _ alt =
 313   error $ "Case patterns other than data constructors not supported in case alternative: " ++ (showSDoc $ ppr alt)
 314
 315
 316 -- Expands the application of argument to a function into VHDL
 317 expandApplicationExpr ::
 318   [(CoreBndr, SignalNameMap AST.VHDLId)]
 319                                          -- A list of bindings in effect
 320   -> Type                                -- The result type of the function call
 321   -> Var.Var                             -- The function to call
 322   -> [CoreExpr]                          -- A list of argumetns to apply to the function
 323   -> VHDLState ( [AST.SigDec], [AST.ConcSm], [SignalNameMap AST.VHDLId], SignalNameMap AST.VHDLId)
 324                                          -- See expandExpr
 325 expandApplicationExpr binds ty f args = do
 326   let name = getOccString f
 327   -- Generate a unique name for the application
 328   appname <- uniqueName ("app-" ++ name)
 329   -- Lookup the hwfunction to instantiate
 330   HWFunction inports outport <- getHWFunc name
 331   -- Expand each of the args, so each of them is reduced to output signals
 332   (arg_signal_decls, arg_statements, arg_res_signals) <- expandArgs binds args
 333   -- Bind each of the input ports to the expanded arguments
 334   let inmaps = concat $ zipWith createAssocElems inports arg_res_signals
 335   -- Create signal names for our result
 336   let res_signal = getPortNameMapForTy (appname ++ "-out") ty
 337   -- Create the corresponding signal declarations
 338   let signal_decls = mkSignalsFromMap res_signal
 339   -- Bind each of the output ports to our output signals
 340   let outmaps = mapOutputPorts outport res_signal
 341   -- Instantiate the component
 342   let component = AST.CSISm $ AST.CompInsSm
 343         (AST.unsafeVHDLBasicId appname)
 344         (AST.IUEntity (AST.NSimple (AST.unsafeVHDLBasicId name)))
 345         (AST.PMapAspect (inmaps ++ outmaps))
 346   -- Merge the generated declarations
 347   return (
 348     signal_decls ++ arg_signal_decls,
 349     component : arg_statements,
 350     [], -- We don't take any extra arguments; we don't support higher order functions yet
 351     res_signal)
 352
 353 -- Creates a list of AssocElems (port map lines) that maps the given signals
 354 -- to the given ports.
 355 createAssocElems ::
 356   SignalNameMap AST.VHDLId      -- The port names to bind to
 357   -> SignalNameMap AST.VHDLId   -- The signals to bind to it
 358   -> [AST.AssocElem]            -- The resulting port map lines
 359
 360 createAssocElems (Signal port_id) (Signal signal_id) =
 361   [(Just port_id) AST.:=>: (AST.ADName (AST.NSimple signal_id))]
 362
 363 createAssocElems (Tuple ports) (Tuple signals) =
 364   concat $ zipWith createAssocElems ports signals
 365
 366 -- Generate a signal declaration for a signal with the given name and the
 367 -- given type and no value. Also returns the id of the signal.
 368 mkSignal :: String -> AST.TypeMark -> (AST.VHDLId, AST.SigDec)
 369 mkSignal name ty =
 370   (id, mkSignalFromId id ty)
 371   where
 372     id = AST.unsafeVHDLBasicId name
 373
 374 mkSignalFromId :: AST.VHDLId -> AST.TypeMark -> AST.SigDec
 375 mkSignalFromId id ty =
 376   AST.SigDec id ty Nothing
 377
 378 -- Generates signal declarations for all the signals in the given map
 379 mkSignalsFromMap ::
 380   SignalNameMap AST.VHDLId
 381   -> [AST.SigDec]
 382
 383 mkSignalsFromMap (Signal id) =
 384   -- TODO: This uses the bit type hardcoded
 385   [mkSignalFromId id vhdl_bit_ty]
 386
 387 mkSignalsFromMap (Tuple signals) =
 388   concat $ map mkSignalsFromMap signals
 389
 390 expandArgs ::
 391   [(CoreBndr, SignalNameMap AST.VHDLId)] -- A list of bindings in effect
 392   -> [CoreExpr]                          -- The arguments to expand
 393   -> VHDLState ([AST.SigDec], [AST.ConcSm], [SignalNameMap AST.VHDLId])
 394                                          -- The resulting signal declarations,
 395                                          -- component instantiations and a
 396                                          -- VHDLName for each of the
 397                                          -- expressions passed in.
 398 expandArgs binds (e:exprs) = do
 399   -- Expand the first expression
 400   (signal_decls, statements, arg_signals, res_signal) <- expandExpr binds e
 401   if not (null arg_signals)
 402     then error $ "Passing functions as arguments not supported: " ++ (showSDoc $ ppr e)
 403     else do
 404       (signal_decls', statements', res_signals') <- expandArgs binds exprs
 405       return (
 406         signal_decls ++ signal_decls',
 407         statements ++ statements',
 408         res_signal : res_signals')
 409
 410 expandArgs _ [] = return ([], [], [])
 411
 412 -- Is the given name a (binary) tuple constructor
 413 isTupleConstructor :: Var.Var -> Bool
 414 isTupleConstructor var =
 415   Name.isWiredInName name
 416   && Name.nameModule name == tuple_mod
 417   && (Name.occNameString $ Name.nameOccName name) == "(,)"
 418   where
 419     name = Var.varName var
 420     mod = nameModule name
 421     tuple_mod = Module.mkModule (Module.stringToPackageId "ghc-prim") (Module.mkModuleName "GHC.Tuple")
 422
 423 -- Split arguments into type arguments and value arguments This is probably
 424 -- not really sufficient (not sure if Types can actually occur as value
 425 -- arguments...)
 426 splitTupleConstructorArgs :: [CoreExpr] -> ([CoreExpr], [CoreExpr])
 427 splitTupleConstructorArgs (e:es) =
 428   case e of
 429     Type t     -> (e:tys, vals)
 430     otherwise  -> (tys, e:vals)
 431   where
 432     (tys, vals) = splitTupleConstructorArgs es
 433
 434 splitTupleConstructorArgs [] = ([], [])
 435
 436 mapOutputPorts ::
 437   SignalNameMap AST.VHDLId      -- The output portnames of the component
 438   -> SignalNameMap AST.VHDLId   -- The output portnames and/or signals to map these to
 439   -> [AST.AssocElem]            -- The resulting output ports
 440
 441 -- Map the output port of a component to the output port of the containing
 442 -- entity.
 443 mapOutputPorts (Signal portname) (Signal signalname) =
 444   [(Just portname) AST.:=>: (AST.ADName (AST.NSimple signalname))]
 445
 446 -- Map matching output ports in the tuple
 447 mapOutputPorts (Tuple ports) (Tuple signals) =
 448   concat (zipWith mapOutputPorts ports signals)
 449
 450 getArchitecture ::
 451   CoreBind                  -- The binder to expand into an architecture
 452   -> VHDLState AST.ArchBody -- The resulting architecture
 453
 454 getArchitecture (Rec _) = error "Recursive binders not supported"
 455
 456 getArchitecture (NonRec var expr) = do
 457   let name = (getOccString var)
 458   HWFunction inports outport <- getHWFunc name
 459   sess <- State.get
 460   (signal_decls, statements, arg_signals, res_signal) <- expandExpr [] expr
 461   let inport_assigns = concat $ zipWith createSignalAssignments arg_signals inports
 462   let outport_assigns = createSignalAssignments outport res_signal
 463   return $ AST.ArchBody
 464     (AST.unsafeVHDLBasicId "structural")
 465     -- Use unsafe for now, to prevent pulling in ForSyDe error handling
 466     (AST.NSimple (AST.unsafeVHDLBasicId name))
 467     (map AST.BDISD signal_decls)
 468     (inport_assigns ++ outport_assigns ++ statements)
 469
 470 -- Create concurrent assignments of one map of signals to another. The maps
 471 -- should have a similar form.
 472 createSignalAssignments ::
 473   SignalNameMap AST.VHDLId         -- The signals to assign to
 474   -> SignalNameMap AST.VHDLId      -- The signals to assign
 475   -> [AST.ConcSm]                  -- The resulting assignments
 476
 477 -- A simple assignment of one signal to another (greatly complicated because
 478 -- signal assignments can be conditional with multiple conditions in VHDL).
 479 createSignalAssignments (Signal dst) (Signal src) =
 480     [AST.CSSASm assign]
 481   where
 482     src_name  = AST.NSimple src
 483     src_expr  = AST.PrimName src_name
 484     src_wform = AST.Wform [AST.WformElem src_expr Nothing]
 485     dst_name  = (AST.NSimple dst)
 486     assign    = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
 487
 488 createSignalAssignments (Tuple dsts) (Tuple srcs) =
 489   concat $ zipWith createSignalAssignments dsts srcs
 490
 491 createSignalAssignments dst src =
 492   error $ "Non matching source and destination: " ++ show dst ++ "\nand\n" ++  show src
 493
 494 data SignalNameMap t =
 495   Tuple [SignalNameMap t]
 496   | Signal  t
 497   deriving (Show)
 498
 499 -- Generate a port name map (or multiple for tuple types) in the given direction for
 500 -- each type given.
 501 getPortNameMapForTys :: String -> Int -> [Type] -> [SignalNameMap AST.VHDLId]
 502 getPortNameMapForTys prefix num [] = []
 503 getPortNameMapForTys prefix num (t:ts) =
 504   (getPortNameMapForTy (prefix ++ show num) t) : getPortNameMapForTys prefix (num + 1) ts
 505
 506 getPortNameMapForTy :: String -> Type -> SignalNameMap AST.VHDLId
 507 getPortNameMapForTy name ty =
 508   if (TyCon.isTupleTyCon tycon) then
 509     -- Expand tuples we find
 510     Tuple (getPortNameMapForTys name 0 args)
 511   else -- Assume it's a type constructor application, ie simple data type
 512     -- TODO: Add type?
 513     Signal (AST.unsafeVHDLBasicId name)
 514   where
 515     (tycon, args) = Type.splitTyConApp ty
 516
 517 data HWFunction = HWFunction { -- A function that is available in hardware
 518   inPorts   :: [SignalNameMap AST.VHDLId],
 519   outPort   :: SignalNameMap AST.VHDLId
 520   --entity    :: AST.EntityDec
 521 } deriving (Show)
 522
 523 -- Turns a CoreExpr describing a function into a description of its input and
 524 -- output ports.
 525 mkHWFunction ::
 526   CoreBind                                   -- The core binder to generate the interface for
 527   -> VHDLState (String, HWFunction)          -- The name of the function and its interface
 528
 529 mkHWFunction (NonRec var expr) =
 530     return (name, HWFunction inports outport)
 531   where
 532     name = (getOccString var)
 533     ty = CoreUtils.exprType expr
 534     (fargs, res) = Type.splitFunTys ty
 535     args = if length fargs == 1 then fargs else (init fargs)
 536     --state = if length fargs == 1 then () else (last fargs)
 537     inports = case args of
 538       -- Handle a single port specially, to prevent an extra 0 in the name
 539       [port] -> [getPortNameMapForTy "portin" port]
 540       ps     -> getPortNameMapForTys "portin" 0 ps
 541     outport = getPortNameMapForTy "portout" res
 542
 543 mkHWFunction (Rec _) =
 544   error "Recursive binders not supported"
 545
 546 data VHDLSession = VHDLSession {
 547   nameCount :: Int,                      -- A counter that can be used to generate unique names
 548   funcs     :: [(String, HWFunction)]    -- All functions available, indexed by name
 549 } deriving (Show)
 550
 551 type VHDLState = State.State VHDLSession
 552
 553 -- Add the function to the session
 554 addFunc :: String -> HWFunction -> VHDLState ()
 555 addFunc name f = do
 556   fs <- State.gets funcs -- Get the funcs element from the session
 557   State.modify (\x -> x {funcs = (name, f) : fs }) -- Prepend name and f
 558
 559 -- Lookup the function with the given name in the current session. Errors if
 560 -- it was not found.
 561 getHWFunc :: String -> VHDLState HWFunction
 562 getHWFunc name = do
 563   fs <- State.gets funcs -- Get the funcs element from the session
 564   return $ Maybe.fromMaybe
 565     (error $ "Function " ++ name ++ "is unknown? This should not happen!")
 566     (lookup name fs)
 567
 568 -- Makes the given name unique by appending a unique number.
 569 -- This does not do any checking against existing names, so it only guarantees
 570 -- uniqueness with other names generated by uniqueName.
 571 uniqueName :: String -> VHDLState String
 572 uniqueName name = do
 573   count <- State.gets nameCount -- Get the funcs element from the session
 574   State.modify (\s -> s {nameCount = count + 1})
 575   return $ name ++ "-" ++ (show count)
 576
 577 -- Shortcut
 578 mkVHDLId :: String -> AST.VHDLId
 579 mkVHDLId = AST.unsafeVHDLBasicId
 580
 581 builtin_funcs =
 582   [
 583     ("hwxor", HWFunction [Signal $ mkVHDLId "a", Signal $ mkVHDLId "b"] (Signal $ mkVHDLId "o")),
 584     ("hwand", HWFunction [Signal $ mkVHDLId "a", Signal $ mkVHDLId "b"] (Signal $ mkVHDLId "o")),
 585     ("hwor", HWFunction [Signal $ mkVHDLId "a", Signal $ mkVHDLId "b"] (Signal $ mkVHDLId "o")),
 586     ("hwnot", HWFunction [Signal $ mkVHDLId "i"] (Signal $ mkVHDLId "o"))
 587   ]
 588
 589 vhdl_bit_ty :: AST.TypeMark
 590 vhdl_bit_ty = AST.unsafeVHDLBasicId "Bit"
 591
 592 -- vim: set ts=8 sw=2 sts=2 expandtab: