Cabalized clash

[matthijs/master-project/cλash.git] / Translator.hs

diff --git a/Translator.hs b/Translator.hs
index fa5802823939d34ee77ac9cfc05c7ac3723a7177..550b4f0800475b348d4a6146aa317527d74af79d 100644 (file)
--- a/Translator.hs
+++ b/Translator.hs
@@ -1,359 +1,355 @@
-module Main(main) where
-import GHC
+module Translator where
+import qualified Directory
+import qualified List
+import GHC hiding (loadModule, sigName)

 import CoreSyn
 import qualified CoreUtils
 import qualified Var
 import qualified Type
 import qualified TyCon
 import qualified DataCon
 import CoreSyn
 import qualified CoreUtils
 import qualified Var
 import qualified Type
 import qualified TyCon
 import qualified DataCon

+import qualified HscMain
+import qualified SrcLoc
+import qualified FastString

 import qualified Maybe
 import qualified Module
 import qualified Maybe
 import qualified Module

-import qualified Control.Monad.State as State
+import qualified Data.Foldable as Foldable
+import qualified Control.Monad.Trans.State as State

 import Name
 import Name

+import qualified Data.Map as Map
+import Data.Accessor

 import Data.Generics
 import NameEnv ( lookupNameEnv )
 import Data.Generics
 import NameEnv ( lookupNameEnv )

+import qualified HscTypes

 import HscTypes ( cm_binds, cm_types )
 import MonadUtils ( liftIO )
 import Outputable ( showSDoc, ppr )
 import GHC.Paths ( libdir )
 import DynFlags ( defaultDynFlags )
 import List ( find )
 import HscTypes ( cm_binds, cm_types )
 import MonadUtils ( liftIO )
 import Outputable ( showSDoc, ppr )
 import GHC.Paths ( libdir )
 import DynFlags ( defaultDynFlags )
 import List ( find )

+import qualified List
+import qualified Monad
+

 -- The following modules come from the ForSyDe project. They are really
 -- internal modules, so ForSyDe.cabal has to be modified prior to installing
 -- ForSyDe to get access to these modules.
 import qualified ForSyDe.Backend.VHDL.AST as AST
 import qualified ForSyDe.Backend.VHDL.Ppr
 -- The following modules come from the ForSyDe project. They are really
 -- internal modules, so ForSyDe.cabal has to be modified prior to installing
 -- ForSyDe to get access to these modules.
 import qualified ForSyDe.Backend.VHDL.AST as AST
 import qualified ForSyDe.Backend.VHDL.Ppr

+import qualified ForSyDe.Backend.VHDL.FileIO

 import qualified ForSyDe.Backend.Ppr
 -- This is needed for rendering the pretty printed VHDL
 import Text.PrettyPrint.HughesPJ (render)
 
 import qualified ForSyDe.Backend.Ppr
 -- This is needed for rendering the pretty printed VHDL
 import Text.PrettyPrint.HughesPJ (render)
 

-main = 
-    do
-      defaultErrorHandler defaultDynFlags $ do
-        runGhc (Just libdir) $ do
-          dflags <- getSessionDynFlags
-          setSessionDynFlags dflags
-          --target <- guessTarget "adder.hs" Nothing
-          --liftIO (print (showSDoc (ppr (target))))
-          --liftIO $ printTarget target
-          --setTargets [target]
-          --load LoadAllTargets
-          --core <- GHC.compileToCoreSimplified "Adders.hs"
-          core <- GHC.compileToCoreSimplified "Adders.hs"
-          liftIO $ printBinds (cm_binds core)
-          let bind = findBind "half_adder" (cm_binds core)
-          let NonRec var expr = bind
-          -- Turn bind into VHDL
-          let vhdl = State.evalState (mkVHDL bind) (VHDLSession 0 builtin_funcs)
-          liftIO $ putStr $ showSDoc $ ppr expr
-          liftIO $ putStr "\n\n"
-          liftIO $ putStr $ render $ ForSyDe.Backend.Ppr.ppr $ vhdl
-          return expr
+import TranslatorTypes
+import HsValueMap
+import Pretty
+import Flatten
+import FlattenTypes
+import VHDLTypes
+import qualified VHDL
+
+-- main = do
+--   makeVHDL "Alu.hs" "exec" True
+
+makeVHDL :: String -> String -> Bool -> IO ()
+makeVHDL filename name stateful = do
+  -- Load the module
+  core <- loadModule filename
+  -- Translate to VHDL
+  vhdl <- moduleToVHDL core [(name, stateful)]
+  -- Write VHDL to file
+  let dir = "../vhdl/vhdl/" ++ name ++ "/"
+  mapM (writeVHDL dir) vhdl
+  return ()
+
+-- | Show the core structure of the given binds in the given file.
+listBind :: String -> String -> IO ()
+listBind filename name = do
+  core <- loadModule filename
+  let [(b, expr)] = findBinds core [name]
+  putStr "\n"
+  putStr $ prettyShow expr
+  putStr "\n\n"
+  putStr $ showSDoc $ ppr expr
+  putStr "\n\n"
+  putStr $ showSDoc $ ppr $ CoreUtils.exprType expr
+  putStr "\n\n"
+
+-- | Translate the binds with the given names from the given core module to
+--   VHDL. The Bool in the tuple makes the function stateful (True) or
+--   stateless (False).
+moduleToVHDL :: HscTypes.CoreModule -> [(String, Bool)] -> IO [(AST.VHDLId, AST.DesignFile)]
+moduleToVHDL core list = do
+  let (names, statefuls) = unzip list
+  --liftIO $ putStr $ prettyShow (cm_binds core)
+  let binds = findBinds core names
+  --putStr $ prettyShow binds
+  -- Turn bind into VHDL
+  let (vhdl, sess) = State.runState (mkVHDL binds statefuls) (TranslatorSession core 0 Map.empty)
+  mapM (putStr . render . ForSyDe.Backend.Ppr.ppr . snd) vhdl
+  putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n"
+  return vhdl

   where
     -- Turns the given bind into VHDL
   where
     -- Turns the given bind into VHDL

-    mkVHDL bind = do
-      -- Get the function signature
-      (name, f) <- mkHWFunction bind
-      -- Add it to the session
-      addFunc name f
-      arch <- getArchitecture bind
-      return arch
-
-printTarget (Target (TargetFile file (Just x)) obj Nothing) =
-  print $ show file
-
-printBinds [] = putStr "done\n\n"
-printBinds (b:bs) = do
-  printBind b
-  putStr "\n"
-  printBinds bs
-
-printBind (NonRec b expr) = do
-  putStr "NonRec: "
-  printBind' (b, expr)
-
-printBind (Rec binds) = do
-  putStr "Rec: \n"  
-  foldl1 (>>) (map printBind' binds)
-
-printBind' (b, expr) = do
-  putStr $ getOccString b
-  --putStr $ showSDoc $ ppr expr
-  putStr "\n"
-
-findBind :: String -> [CoreBind] -> CoreBind
-findBind lookfor =
+    mkVHDL :: [(CoreBndr, CoreExpr)] -> [Bool] -> TranslatorState [(AST.VHDLId, AST.DesignFile)]
+    mkVHDL binds statefuls = do
+      -- Add the builtin functions
+      --mapM addBuiltIn builtin_funcs
+      -- Create entities and architectures for them
+      Monad.zipWithM processBind statefuls binds
+      modA tsFlatFuncs (Map.map nameFlatFunction)
+      flatfuncs <- getA tsFlatFuncs
+      return $ VHDL.createDesignFiles flatfuncs
+
+-- | Write the given design file to a file with the given name inside the
+--   given dir
+writeVHDL :: String -> (AST.VHDLId, AST.DesignFile) -> IO ()
+writeVHDL dir (name, vhdl) = do
+  -- Create the dir if needed
+  exists <- Directory.doesDirectoryExist dir
+  Monad.unless exists $ Directory.createDirectory dir
+  -- Find the filename
+  let fname = dir ++ (AST.fromVHDLId name) ++ ".vhdl"
+  -- Write the file
+  ForSyDe.Backend.VHDL.FileIO.writeDesignFile vhdl fname
+
+-- | Loads the given file and turns it into a core module.
+loadModule :: String -> IO HscTypes.CoreModule
+loadModule filename =
+  defaultErrorHandler defaultDynFlags $ do
+    runGhc (Just libdir) $ do
+      dflags <- getSessionDynFlags
+      setSessionDynFlags dflags
+      --target <- guessTarget "adder.hs" Nothing
+      --liftIO (print (showSDoc (ppr (target))))
+      --liftIO $ printTarget target
+      --setTargets [target]
+      --load LoadAllTargets
+      --core <- GHC.compileToCoreSimplified "Adders.hs"
+      core <- GHC.compileToCoreSimplified filename
+      return core
+
+-- | Extracts the named binds from the given module.
+findBinds :: HscTypes.CoreModule -> [String] -> [(CoreBndr, CoreExpr)]
+findBinds core names = Maybe.mapMaybe (findBind (CoreSyn.flattenBinds $ cm_binds core)) names
+
+-- | Extract a named bind from the given list of binds
+findBind :: [(CoreBndr, CoreExpr)] -> String -> Maybe (CoreBndr, CoreExpr)
+findBind binds lookfor =

   -- This ignores Recs and compares the name of the bind with lookfor,
   -- disregarding any namespaces in OccName and extra attributes in Name and
   -- Var.
   -- This ignores Recs and compares the name of the bind with lookfor,
   -- disregarding any namespaces in OccName and extra attributes in Name and
   -- Var.

-  Maybe.fromJust . find (\b -> case b of 
-    Rec l -> False
-    NonRec var _ -> lookfor == (occNameString $ nameOccName $ getName var)
-  )
-
-getPortMapEntry ::
-  SignalNameMap String      -- The port name to bind to
-  -> AST.VHDLName           -- The signal or port to bind to it
-  -> AST.AssocElem          -- The resulting port map entry
-  
--- Accepts a port name and an argument to map to it.
--- Returns the appropriate line for in the port map
-getPortMapEntry (Signal portname) signame = 
-  (Just (AST.unsafeVHDLBasicId portname)) AST.:=>: (AST.ADName signame)
-
-getInstantiations ::
-  [SignalNameMap String]       -- The arguments that need to be applied to the
-                               -- expression.
-  -> SignalNameMap String      -- The output ports that the expression should generate.
-  -> [(CoreBndr, SignalNameMap String)] 
-                               -- A list of bindings in effect
-  -> CoreSyn.CoreExpr          -- The expression to generate an architecture for
-  -> VHDLState ([AST.SigDec], [AST.ConcSm])    
-                               -- The resulting VHDL code
-
--- A lambda expression binds the first argument (a) to the binder b.
-getInstantiations (a:as) outs binds (Lam b expr) =
-  getInstantiations as outs ((b, a):binds) expr
-
--- A case expression that checks a single variable and has a single
--- alternative, can be used to take tuples apart
-getInstantiations args outs binds (Case (Var v) b _ [res]) =
-  -- Split out the type of alternative constructor, the variables it binds
-  -- and the expression to evaluate with the variables bound.
-  let (altcon, bind_vars, expr) = res in
-  case altcon of
-    DataAlt datacon ->
-      if (DataCon.isTupleCon datacon) then
-        let 
-          -- Lookup the scrutinee (which must be a variable bound to a tuple) in
-          -- the existing bindings list and get the portname map for each of
-          -- it's elements.
-          Tuple tuple_ports = Maybe.fromMaybe 
-            (error $ "Case expression uses unknown scrutinee " ++ getOccString v)
-            (lookup v binds)
-          -- Merge our existing binds with the new binds.
-          binds' = (zip bind_vars tuple_ports) ++ binds 
-        in
-          -- Evaluate the expression with the new binds list
-          getInstantiations args outs binds' expr
-      else
-        error "Data constructors other than tuples not supported"
-    otherwise ->
-      error "Case binders other than tuples not supported"
-
--- An application is an instantiation of a component
-getInstantiations args outs binds app@(App expr arg) = do
-  let ((Var f), fargs) = collectArgs app
-      name = getOccString f
-  if isTupleConstructor f 
-    then do
-      -- Get the signals we should bind our results to
-      let Tuple outports = outs
-      -- Split the tuple constructor arguments into types and actual values.
-      let (_, vals) = splitTupleConstructorArgs fargs
-      -- Bind each argument to each output signal
-      res <- sequence $ zipWith 
-        (\outs' expr' -> getInstantiations args outs' binds expr')
-        outports vals
-      -- res is a list of pairs of lists, so split out the signals and
-      -- components into separate lists of lists
-      let (sigs, comps) = unzip res
-      -- And join all the signals and component instantiations together
-      return $ (concat sigs, concat comps)
-    else do
-      -- This is an normal function application, which maps to a component
-      -- instantiation.
-      -- Lookup the hwfunction to instantiate
-      HWFunction inports outport <- getHWFunc name
-      -- Generate a unique name for the application
-      appname <- uniqueName "app"
-      -- Expand each argument to a signal or port name, possibly generating
-      -- new signals and component instantiations
-      (sigs, comps, args) <- expandArgs binds fargs
-      -- Bind each of the input ports to the expanded signal or port
-      let inmaps = zipWith getPortMapEntry inports args
-      -- Bind each of the output ports to our output signals
-      let outmaps = mapOutputPorts outport outs
-      -- Build and return a component instantiation
-      let comp = AST.CompInsSm
-            (AST.unsafeVHDLBasicId appname)
-            (AST.IUEntity (AST.NSimple (AST.unsafeVHDLBasicId name)))
-            (AST.PMapAspect (inmaps ++ outmaps))
-      return (sigs, (AST.CSISm comp) : comps)
-
-getInstantiations args outs binds expr = 
-  error $ "Unsupported expression" ++ (showSDoc $ ppr $ expr)
-  
-expandArgs :: 
-  [(CoreBndr, SignalNameMap String)]     -- A list of bindings in effect
-  -> [CoreExpr]                          -- The arguments to expand
-  -> VHDLState ([AST.SigDec], [AST.ConcSm], [AST.VHDLName])  
-                                         -- The resulting signal declarations,
-                                         -- component instantiations and a
-                                         -- VHDLName for each of the
-                                         -- expressions passed in.
-expandArgs binds (e:exprs) = do
-  -- Expand the first expression
-  arg <- case e of
-    -- A simple variable reference should be in our binds map
-    Var id -> return $ let
-        -- Lookup the id in our binds map
-        Signal signalname = Maybe.fromMaybe
-          (error $ "Argument " ++ getOccString id ++ "is unknown")
-          (lookup id binds)
-      in
-        -- Create a VHDL name from the signal name
-        AST.NSimple (AST.unsafeVHDLBasicId signalname)
-    -- Other expressions are unsupported
-    otherwise -> error ("Unsupported expression used as argument: " ++ (showSDoc $ ppr e))
-  -- Expand the rest
-  (sigs, comps, args) <- expandArgs binds exprs
-  -- Return all results
-  return (sigs, comps, arg:args)
-
-expandArgs _ [] = return ([], [], [])
-
--- Is the given name a (binary) tuple constructor
-isTupleConstructor :: Var.Var -> Bool
-isTupleConstructor var =
-  Name.isWiredInName name
-  && Name.nameModule name == tuple_mod
-  && (Name.occNameString $ Name.nameOccName name) == "(,)"
+  find (\(var, _) -> lookfor == (occNameString $ nameOccName $ getName var)) binds
+
+-- | Processes the given bind as a top level bind.
+processBind ::
+  Bool                       -- ^ Should this be stateful function?
+  -> (CoreBndr, CoreExpr)    -- ^ The bind to process
+  -> TranslatorState ()
+
+processBind stateful bind@(var, expr) = do
+  -- Create the function signature
+  let ty = CoreUtils.exprType expr
+  let hsfunc = mkHsFunction var ty stateful
+  flattenBind hsfunc bind
+
+-- | Flattens the given bind into the given signature and adds it to the
+--   session. Then (recursively) finds any functions it uses and does the same
+--   with them.
+flattenBind ::
+  HsFunction                         -- The signature to flatten into
+  -> (CoreBndr, CoreExpr)            -- The bind to flatten
+  -> TranslatorState ()
+
+flattenBind hsfunc bind@(var, expr) = do
+  -- Flatten the function
+  let flatfunc = flattenFunction hsfunc bind
+  -- Propagate state variables
+  let flatfunc' = propagateState hsfunc flatfunc
+  -- Store the flat function in the session
+  modA tsFlatFuncs (Map.insert hsfunc flatfunc')
+  -- Flatten any functions used
+  let used_hsfuncs = Maybe.mapMaybe usedHsFunc (flat_defs flatfunc')
+  mapM_ resolvFunc used_hsfuncs
+
+-- | Decide which incoming state variables will become state in the
+--   given function, and which will be propagate to other applied
+--   functions.
+propagateState ::
+  HsFunction
+  -> FlatFunction
+  -> FlatFunction
+
+propagateState hsfunc flatfunc =
+    flatfunc {flat_defs = apps', flat_sigs = sigs'} 

   where
   where

-    name = Var.varName var
-    mod = nameModule name
-    tuple_mod = Module.mkModule (Module.stringToPackageId "ghc-prim") (Module.mkModuleName "GHC.Tuple")
-
--- Split arguments into type arguments and value arguments This is probably
--- not really sufficient (not sure if Types can actually occur as value
--- arguments...)
-splitTupleConstructorArgs :: [CoreExpr] -> ([CoreExpr], [CoreExpr])
-splitTupleConstructorArgs (e:es) =
-  case e of
-    Type t     -> (e:tys, vals)
-    otherwise  -> (tys, e:vals)
+    (olds, news) = unzip $ getStateSignals hsfunc flatfunc
+    states' = zip olds news
+    -- Find all signals used by all sigdefs
+    uses = concatMap sigDefUses (flat_defs flatfunc)
+    -- Find all signals that are used more than once (is there a
+    -- prettier way to do this?)
+    multiple_uses = uses List.\\ (List.nub uses)
+    -- Find the states whose "old state" signal is used only once
+    single_use_states = filter ((`notElem` multiple_uses) . fst) states'
+    -- See if these single use states can be propagated
+    (substate_sigss, apps') = unzip $ map (propagateState' single_use_states) (flat_defs flatfunc)
+    substate_sigs = concat substate_sigss
+    -- Mark any propagated state signals as SigSubState
+    sigs' = map 
+      (\(id, info) -> (id, if id `elem` substate_sigs then info {sigUse = SigSubState} else info))
+      (flat_sigs flatfunc)
+
+-- | Propagate the state into a single function application.
+propagateState' ::
+  [(SignalId, SignalId)]
+                      -- ^ TODO
+  -> SigDef           -- ^ The SigDef to process.
+  -> ([SignalId], SigDef) 
+                      -- ^ Any signal ids that should become substates,
+                      --   and the resulting application.
+
+propagateState' states def =
+    if (is_FApp def) then
+      (our_old ++ our_new, def {appFunc = hsfunc'})
+    else
+      ([], def)

   where
   where

-    (tys, vals) = splitTupleConstructorArgs es
-
-mapOutputPorts ::
-  SignalNameMap String          -- The output portnames of the component
-  -> SignalNameMap String       -- The output portnames and/or signals to map these to
-  -> [AST.AssocElem]            -- The resulting output ports
-
--- Map the output port of a component to the output port of the containing
--- entity.
-mapOutputPorts (Signal portname) (Signal signalname) =
-  [(Just (AST.unsafeVHDLBasicId portname)) AST.:=>: (AST.ADName (AST.NSimple (AST.unsafeVHDLBasicId signalname)))]
-
--- Map matching output ports in the tuple
-mapOutputPorts (Tuple ports) (Tuple signals) =
-  concat (zipWith mapOutputPorts ports signals)
-
-getArchitecture ::
-  CoreBind                  -- The binder to expand into an architecture
-  -> VHDLState AST.ArchBody -- The resulting architecture
-   
-getArchitecture (Rec _) = error "Recursive binders not supported"
-
-getArchitecture (NonRec var expr) = do
-  let name = (getOccString var)
-  HWFunction inports outport <- getHWFunc name
-  sess <- State.get
-  (sigs, comps) <- getInstantiations inports outport [] expr
-  return $ AST.ArchBody
-    (AST.unsafeVHDLBasicId "structural")
-    -- Use unsafe for now, to prevent pulling in ForSyDe error handling
-    (AST.NSimple (AST.unsafeVHDLBasicId name))
-    (map AST.BDISD sigs)
-    comps
-
-data SignalNameMap t =
-  Tuple [SignalNameMap t]
-  | Signal  t
-  deriving (Show)
-
--- Generate a port name map (or multiple for tuple types) in the given direction for
--- each type given.
-getPortNameMapForTys :: String -> Int -> [Type] -> [SignalNameMap String]
-getPortNameMapForTys prefix num [] = [] 
-getPortNameMapForTys prefix num (t:ts) =
-  (getPortNameMapForTy (prefix ++ show num) t) : getPortNameMapForTys prefix (num + 1) ts
-
-getPortNameMapForTy :: String -> Type -> SignalNameMap String
-getPortNameMapForTy name ty =
-  if (TyCon.isTupleTyCon tycon) then
-    -- Expand tuples we find
-    Tuple (getPortNameMapForTys name 0 args)
-  else -- Assume it's a type constructor application, ie simple data type
-    -- TODO: Add type?
-    Signal name
+    hsfunc = appFunc def
+    args = appArgs def
+    res = appRes def
+    our_states = filter our_state states
+    -- A state signal belongs in this function if the old state is
+    -- passed in, and the new state returned
+    our_state (old, new) =
+      any (old `Foldable.elem`) args
+      && new `Foldable.elem` res
+    (our_old, our_new) = unzip our_states
+    -- Mark the result
+    zipped_res = zipValueMaps res (hsFuncRes hsfunc)
+    res' = fmap (mark_state (zip our_new [0..])) zipped_res
+    -- Mark the args
+    zipped_args = zipWith zipValueMaps args (hsFuncArgs hsfunc)
+    args' = map (fmap (mark_state (zip our_old [0..]))) zipped_args
+    hsfunc' = hsfunc {hsFuncArgs = args', hsFuncRes = res'}
+
+    mark_state :: [(SignalId, StateId)] -> (SignalId, HsValueUse) -> HsValueUse
+    mark_state states (id, use) =
+      case lookup id states of
+        Nothing -> use
+        Just state_id -> State state_id
+
+-- | Returns pairs of signals that should be mapped to state in this function.
+getStateSignals ::
+  HsFunction                      -- | The function to look at
+  -> FlatFunction                 -- | The function to look at
+  -> [(SignalId, SignalId)]   
+        -- | TODO The state signals. The first is the state number, the second the
+        --   signal to assign the current state to, the last is the signal
+        --   that holds the new state.
+
+getStateSignals hsfunc flatfunc =
+  [(old_id, new_id) 
+    | (old_num, old_id) <- args
+    , (new_num, new_id) <- res
+    , old_num == new_num]

   where
   where

-    (tycon, args) = Type.splitTyConApp ty 
-
-data HWFunction = HWFunction { -- A function that is available in hardware
-  inPorts   :: [SignalNameMap String],
-  outPort   :: SignalNameMap String
-  --entity    :: AST.EntityDec
-} deriving (Show)
-
--- Turns a CoreExpr describing a function into a description of its input and
--- output ports.
-mkHWFunction ::
-  CoreBind                                   -- The core binder to generate the interface for
-  -> VHDLState (String, HWFunction)          -- The name of the function and its interface
-
-mkHWFunction (NonRec var expr) =
-    return (name, HWFunction inports outport)
+    sigs = flat_sigs flatfunc
+    -- Translate args and res to lists of (statenum, sigid)
+    args = concat $ zipWith stateList (hsFuncArgs hsfunc) (flat_args flatfunc)
+    res = stateList (hsFuncRes hsfunc) (flat_res flatfunc)
+    
+-- | Find the given function, flatten it and add it to the session. Then
+--   (recursively) do the same for any functions used.
+resolvFunc ::
+  HsFunction        -- | The function to look for
+  -> TranslatorState ()
+
+resolvFunc hsfunc = do
+  flatfuncmap <- getA tsFlatFuncs
+  -- Don't do anything if there is already a flat function for this hsfunc or
+  -- when it is a builtin function.
+  Monad.unless (Map.member hsfunc flatfuncmap) $ do
+  Monad.unless (elem hsfunc VHDL.builtin_hsfuncs) $ do
+  -- New function, resolve it
+  core <- getA tsCoreModule
+  -- Find the named function
+  let name = (hsFuncName hsfunc)
+  let bind = findBind (CoreSyn.flattenBinds $ cm_binds core) name 
+  case bind of
+    Nothing -> error $ "Couldn't find function " ++ name ++ " in current module."
+    Just b  -> flattenBind hsfunc b
+
+-- | Translate a top level function declaration to a HsFunction. i.e., which
+--   interface will be provided by this function. This function essentially
+--   defines the "calling convention" for hardware models.
+mkHsFunction ::
+  Var.Var         -- ^ The function defined
+  -> Type         -- ^ The function type (including arguments!)
+  -> Bool         -- ^ Is this a stateful function?
+  -> HsFunction   -- ^ The resulting HsFunction
+
+mkHsFunction f ty stateful=
+  HsFunction hsname hsargs hsres

   where
   where

-    name = (getOccString var)
-    ty = CoreUtils.exprType expr
-    (fargs, res) = Type.splitFunTys ty
-    args = if length fargs == 1 then fargs else (init fargs)
-    --state = if length fargs == 1 then () else (last fargs)
-    inports = case args of
-      -- Handle a single port specially, to prevent an extra 0 in the name
-      [port] -> [getPortNameMapForTy "portin" port]
-      ps     -> getPortNameMapForTys "portin" 0 ps
-    outport = getPortNameMapForTy "portout" res
-
-mkHWFunction (Rec _) =
-  error "Recursive binders not supported"
-
-data VHDLSession = VHDLSession {
-  nameCount :: Int,                      -- A counter that can be used to generate unique names
-  funcs     :: [(String, HWFunction)]    -- All functions available, indexed by name
-} deriving (Show)
-
-type VHDLState = State.State VHDLSession
-
--- Add the function to the session
-addFunc :: String -> HWFunction -> VHDLState ()
-addFunc name f = do
-  fs <- State.gets funcs -- Get the funcs element from the session
-  State.modify (\x -> x {funcs = (name, f) : fs }) -- Prepend name and f
-
--- Lookup the function with the given name in the current session. Errors if
--- it was not found.
-getHWFunc :: String -> VHDLState HWFunction
-getHWFunc name = do
-  fs <- State.gets funcs -- Get the funcs element from the session
-  return $ Maybe.fromMaybe
-    (error $ "Function " ++ name ++ "is unknown? This should not happen!")
-    (lookup name fs)
-
--- Makes the given name unique by appending a unique number.
--- This does not do any checking against existing names, so it only guarantees
--- uniqueness with other names generated by uniqueName.
-uniqueName :: String -> VHDLState String
-uniqueName name = do
-  count <- State.gets nameCount -- Get the funcs element from the session
-  State.modify (\s -> s {nameCount = count + 1})
-  return $ name ++ "-" ++ (show count)
-  
-builtin_funcs = 
-  [ 
-    ("hwxor", HWFunction [Signal "a", Signal "b"] (Signal "o")),
-    ("hwand", HWFunction [Signal "a", Signal "b"] (Signal "o"))
-  ]
+    hsname  = getOccString f
+    (arg_tys, res_ty) = Type.splitFunTys ty
+    (hsargs, hsres) = 
+      if stateful 
+      then
+        let
+          -- The last argument must be state
+          state_ty = last arg_tys
+          state    = useAsState (mkHsValueMap state_ty)
+          -- All but the last argument are inports
+          inports = map (useAsPort . mkHsValueMap)(init arg_tys)
+          hsargs   = inports ++ [state]
+          hsres    = case splitTupleType res_ty of
+            -- Result type must be a two tuple (state, ports)
+            Just [outstate_ty, outport_ty] -> if Type.coreEqType state_ty outstate_ty
+              then
+                Tuple [state, useAsPort (mkHsValueMap outport_ty)]
+              else
+                error $ "Input state type of function " ++ hsname ++ ": " ++ (showSDoc $ ppr state_ty) ++ " does not match output state type: " ++ (showSDoc $ ppr outstate_ty)
+            otherwise                -> error $ "Return type of top-level function " ++ hsname ++ " must be a two-tuple containing a state and output ports."
+        in
+          (hsargs, hsres)
+      else
+        -- Just use everything as a port
+        (map (useAsPort . mkHsValueMap) arg_tys, useAsPort $ mkHsValueMap res_ty)
+
+-- | Adds signal names to the given FlatFunction
+nameFlatFunction ::
+  FlatFunction
+  -> FlatFunction
+
+nameFlatFunction flatfunc =
+  -- Name the signals
+  let 
+    s = flat_sigs flatfunc
+    s' = map nameSignal s in
+  flatfunc { flat_sigs = s' }
+  where
+    nameSignal :: (SignalId, SignalInfo) -> (SignalId, SignalInfo)
+    nameSignal (id, info) =
+      let hints = nameHints info in
+      let parts = ("sig" : hints) ++ [show id] in
+      let name = concat $ List.intersperse "_" parts in
+      (id, info {sigName = Just name})
+
+-- | Splits a tuple type into a list of element types, or Nothing if the type
+--   is not a tuple type.
+splitTupleType ::
+  Type              -- ^ The type to split
+  -> Maybe [Type]   -- ^ The tuples element types
+
+splitTupleType ty =
+  case Type.splitTyConApp_maybe ty of
+    Just (tycon, args) -> if TyCon.isTupleTyCon tycon 
+      then
+        Just args
+      else
+        Nothing
+    Nothing -> Nothing

 
 -- vim: set ts=8 sw=2 sts=2 expandtab:
 
 -- vim: set ts=8 sw=2 sts=2 expandtab: