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