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