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