Started adding builtin functions

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

diff --git a/Translator.hs b/Translator.hs
index 766d08d2e379a42bd9927997e771c1bf3eb26fcc..f377152c775c9deaf7b8efed06453a63403e7a3b 100644 (file)
--- a/Translator.hs
+++ b/Translator.hs
@@ -1,17 +1,26 @@
-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 HscTypes ( cm_binds, cm_types )
 import MonadUtils ( liftIO )
 import Outputable ( showSDoc, ppr )


@@ -26,592 +35,321 @@ import qualified Monad
 -- ForSyDe to get access to these modules.
 import qualified ForSyDe.Backend.VHDL.AST as AST
 import qualified ForSyDe.Backend.VHDL.Ppr
 -- 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 binds = Maybe.mapMaybe (findBind (cm_binds core)) ["full_adder", "half_adder"]
-          liftIO $ printBinds binds
-          -- Turn bind into VHDL
-          let vhdl = State.evalState (mkVHDL binds) (VHDLSession 0 [])
-          liftIO $ putStr $ render $ ForSyDe.Backend.Ppr.ppr vhdl
-          return ()
+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/" ++ 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 binds = do
+    mkVHDL :: [(CoreBndr, CoreExpr)] -> [Bool] -> TranslatorState [(AST.VHDLId, AST.DesignFile)]
+    mkVHDL binds statefuls = do

       -- Add the builtin functions
       -- Add the builtin functions

-      mapM (uncurry addFunc) builtin_funcs
-      -- Get the function signatures
-      funcs <- mapM mkHWFunction binds
-      -- Add them to the session
-      mapM (uncurry addFunc) funcs
-      let entities = map getEntity (snd $ unzip funcs)
-      -- Create architectures for them
-      archs <- mapM getArchitecture binds
-      return $ AST.DesignFile 
-        []
-        ((map AST.LUEntity entities) ++ (map AST.LUArch archs))
-
-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 :: [CoreBind] -> String -> Maybe CoreBind
+      --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.
 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.

-  find (\b -> case b of 
-    Rec l -> False
-    NonRec var _ -> lookfor == (occNameString $ nameOccName $ getName var)
-  ) binds
-
-getPortMapEntry ::
-  SignalNameMap AST.VHDLId  -- The port name to bind to
-  -> SignalNameMap AST.VHDLId 
-                            -- 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) (Signal signame) = 
-  (Just portname) AST.:=>: (AST.ADName (AST.NSimple signame))
-
-getInstantiations ::
-  [SignalNameMap AST.VHDLId]   -- The arguments that need to be applied to the
-                               -- expression.
-  -> SignalNameMap AST.VHDLId  -- The output ports that the expression should generate.
-  -> [(CoreBndr, SignalNameMap AST.VHDLId)] 
-                               -- 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 vhdl_id 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 vhdl_id))
-            (AST.PMapAspect (inmaps ++ outmaps))
-      return (sigs, (AST.CSISm comp) : comps)
-
-getInstantiations args outs binds expr = 
-  error $ "Unsupported expression" ++ (showSDoc $ ppr $ expr)
-
-expandExpr ::
-  [(CoreBndr, SignalNameMap AST.VHDLId)] 
-                                         -- A list of bindings in effect
-  -> CoreExpr                            -- The expression to expand
-  -> VHDLState (
-       [AST.SigDec],                     -- Needed signal declarations
-       [AST.ConcSm],                     -- Needed component instantations and
-                                         -- signal assignments.
-       [SignalNameMap AST.VHDLId],       -- The signal names corresponding to
-                                         -- the expression's arguments
-       SignalNameMap AST.VHDLId)         -- The signal names corresponding to
-                                         -- the expression's result.
-expandExpr binds lam@(Lam b expr) = do
-  -- Generate a new signal to which we will expect this argument to be bound.
-  signal_name <- uniqueName ("arg-" ++ getOccString b)
-  -- Find the type of the binder
-  let (arg_ty, _) = Type.splitFunTy (CoreUtils.exprType lam)
-  -- Create signal names for the binder
-  let arg_signal = getPortNameMapForTy ("xxx") arg_ty
-  -- Create the corresponding signal declarations
-  let signal_decls = mkSignalsFromMap arg_signal
-  -- Add the binder to the list of binds
-  let binds' = (b, arg_signal) : binds
-  -- Expand the rest of the expression
-  (signal_decls', statements', arg_signals', res_signal') <- expandExpr binds' expr
-  -- Properly merge the results
-  return (signal_decls ++ signal_decls',
-          statements',
-          arg_signal : arg_signals',
-          res_signal')
-
-expandExpr binds (Var id) =
-  return ([], [], [], Signal signal_id)
+  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

-    -- Lookup the id in our binds map
-    Signal signal_id = Maybe.fromMaybe
-      (error $ "Argument " ++ getOccString id ++ "is unknown")
-      (lookup id binds)
-
-expandExpr binds l@(Let (NonRec b bexpr) expr) = do
-  (signal_decls, statements, arg_signals, res_signals) <- expandExpr binds bexpr
-  let binds' = (b, res_signals) : binds
-  (signal_decls', statements', arg_signals', res_signals') <- expandExpr binds' expr
-  return (
-    signal_decls ++ signal_decls',
-    statements ++ statements',
-    arg_signals',
-    res_signals')
-
-expandExpr binds app@(App _ _) = do
-  let ((Var f), args) = collectArgs app
-  if isTupleConstructor f 
-    then
-      expandBuildTupleExpr binds args
-    else
-      expandApplicationExpr binds (CoreUtils.exprType app) f args
-
-expandExpr binds expr@(Case (Var v) b _ alts) =
-  case alts of
-    [alt] -> expandSingleAltCaseExpr binds v b alt
-    otherwise -> error $ "Multiple alternative case expression not supported: " ++ (showSDoc $ ppr expr)
-
-expandExpr binds expr@(Case _ b _ _) =
-  error $ "Case expression with non-variable scrutinee not supported: " ++ (showSDoc $ ppr expr)
-
-expandExpr binds expr = 
-  error $ "Unsupported expression: " ++ (showSDoc $ ppr $ expr)
-
--- Expands the construction of a tuple into VHDL
-expandBuildTupleExpr ::
-  [(CoreBndr, SignalNameMap AST.VHDLId)] 
-                                         -- A list of bindings in effect
-  -> [CoreExpr]                          -- A list of expressions to put in the tuple
-  -> VHDLState ( [AST.SigDec], [AST.ConcSm], [SignalNameMap AST.VHDLId], SignalNameMap AST.VHDLId)
-                                         -- See expandExpr
-expandBuildTupleExpr binds args = do
-  -- Split the tuple constructor arguments into types and actual values.
-  let (_, vals) = splitTupleConstructorArgs args
-  -- Expand each of the values in the tuple
-  (signals_declss, statementss, arg_signalss, res_signals) <-
-    (Monad.liftM List.unzip4) $ mapM (expandExpr binds) vals
-  if any (not . null) arg_signalss
-    then error "Putting high order functions in tuples not supported"
+    (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
     else

-      return (
-        concat signals_declss,
-        concat statementss,
-        [],
-        Tuple res_signals)
-
--- Expands the most simple case expression that scrutinizes a plain variable
--- and has a single alternative. This simple form currently allows only for
--- unpacking tuple variables.
-expandSingleAltCaseExpr ::
-  [(CoreBndr, SignalNameMap AST.VHDLId)] 
-                            -- A list of bindings in effect
-  -> Var.Var                -- The scrutinee
-  -> CoreBndr               -- The binder to bind the scrutinee to
-  -> CoreAlt                -- The single alternative
-  -> VHDLState ( [AST.SigDec], [AST.ConcSm], [SignalNameMap AST.VHDLId], SignalNameMap AST.VHDLId)
-                                         -- See expandExpr
-
-expandSingleAltCaseExpr binds v b alt@(DataAlt datacon, bind_vars, expr) =
-  if not (DataCon.isTupleCon datacon) 
-    then
-      error $ "Dataconstructors other than tuple constructors not supported in case pattern of alternative: " ++ (showSDoc $ ppr alt)
-    else
-      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)
-        -- TODO include b in the binds list
-        -- Merge our existing binds with the new binds.
-        binds' = (zip bind_vars tuple_ports) ++ binds 
-      in
-        -- Expand the expression with the new binds list
-        expandExpr binds' expr
-
-expandSingleAltCaseExpr _ _ _ alt =
-  error $ "Case patterns other than data constructors not supported in case alternative: " ++ (showSDoc $ ppr alt)
-      
-
--- Expands the application of argument to a function into VHDL
-expandApplicationExpr ::
-  [(CoreBndr, SignalNameMap AST.VHDLId)] 
-                                         -- A list of bindings in effect
-  -> Type                                -- The result type of the function call
-  -> Var.Var                             -- The function to call
-  -> [CoreExpr]                          -- A list of argumetns to apply to the function
-  -> VHDLState ( [AST.SigDec], [AST.ConcSm], [SignalNameMap AST.VHDLId], SignalNameMap AST.VHDLId)
-                                         -- See expandExpr
-expandApplicationExpr binds ty f args = do
-  let name = getOccString f
-  -- Generate a unique name for the application
-  appname <- uniqueName ("app-" ++ name)
-  -- Lookup the hwfunction to instantiate
-  HWFunction vhdl_id inports outport <- getHWFunc name
-  -- Expand each of the args, so each of them is reduced to output signals
-  (arg_signal_decls, arg_statements, arg_res_signals) <- expandArgs binds args
-  -- Bind each of the input ports to the expanded arguments
-  let inmaps = concat $ zipWith createAssocElems inports arg_res_signals
-  -- Create signal names for our result
-  let res_signal = getPortNameMapForTy (appname ++ "-out") ty
-  -- Create the corresponding signal declarations
-  let signal_decls = mkSignalsFromMap res_signal
-  -- Bind each of the output ports to our output signals
-  let outmaps = mapOutputPorts outport res_signal
-  -- Instantiate the component
-  let component = AST.CSISm $ AST.CompInsSm
-        (AST.unsafeVHDLBasicId appname)
-        (AST.IUEntity (AST.NSimple vhdl_id))
-        (AST.PMapAspect (inmaps ++ outmaps))
-  -- Merge the generated declarations
-  return (
-    signal_decls ++ arg_signal_decls,
-    component : arg_statements,
-    [], -- We don't take any extra arguments; we don't support higher order functions yet
-    res_signal)
-  
--- Creates a list of AssocElems (port map lines) that maps the given signals
--- to the given ports.
-createAssocElems ::
-  SignalNameMap AST.VHDLId      -- The port names to bind to
-  -> SignalNameMap AST.VHDLId   -- The signals to bind to it
-  -> [AST.AssocElem]            -- The resulting port map lines
-  
-createAssocElems (Signal port_id) (Signal signal_id) = 
-  [(Just port_id) AST.:=>: (AST.ADName (AST.NSimple signal_id))]
-
-createAssocElems (Tuple ports) (Tuple signals) = 
-  concat $ zipWith createAssocElems ports signals
-
--- Generate a signal declaration for a signal with the given name and the
--- given type and no value. Also returns the id of the signal.
-mkSignal :: String -> AST.TypeMark -> (AST.VHDLId, AST.SigDec)
-mkSignal name ty =
-  (id, mkSignalFromId id ty)
-  where 
-    id = AST.unsafeVHDLBasicId name
-
-mkSignalFromId :: AST.VHDLId -> AST.TypeMark -> AST.SigDec
-mkSignalFromId id ty =
-  AST.SigDec id ty Nothing
-
--- Generates signal declarations for all the signals in the given map
-mkSignalsFromMap ::
-  SignalNameMap AST.VHDLId 
-  -> [AST.SigDec]
-
-mkSignalsFromMap (Signal id) =
-  -- TODO: This uses the bit type hardcoded
-  [mkSignalFromId id vhdl_bit_ty]
-
-mkSignalsFromMap (Tuple signals) =
-  concat $ map mkSignalsFromMap signals
-
-expandArgs :: 
-  [(CoreBndr, SignalNameMap AST.VHDLId)] -- A list of bindings in effect
-  -> [CoreExpr]                          -- The arguments to expand
-  -> VHDLState ([AST.SigDec], [AST.ConcSm], [SignalNameMap AST.VHDLId])  
-                                         -- 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
-  (signal_decls, statements, arg_signals, res_signal) <- expandExpr binds e
-  if not (null arg_signals)
-    then error $ "Passing functions as arguments not supported: " ++ (showSDoc $ ppr e)
-    else do
-      (signal_decls', statements', res_signals') <- expandArgs binds exprs
-      return (
-        signal_decls ++ signal_decls',
-        statements ++ statements',
-        res_signal : res_signals')
-
-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) == "(,)"
+      ([], def)

   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)
+    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

-    (tys, vals) = splitTupleConstructorArgs es
-
-splitTupleConstructorArgs [] = ([], [])
-
-mapOutputPorts ::
-  SignalNameMap AST.VHDLId      -- The output portnames of the component
-  -> SignalNameMap AST.VHDLId   -- 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 portname) AST.:=>: (AST.ADName (AST.NSimple 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 vhdl_id inports outport <- getHWFunc name
-  sess <- State.get
-  (signal_decls, statements, arg_signals, res_signal) <- expandExpr [] expr
-  let inport_assigns = concat $ zipWith createSignalAssignments arg_signals inports
-  let outport_assigns = createSignalAssignments outport res_signal
-  return $ AST.ArchBody
-    (AST.unsafeVHDLBasicId "structural")
-    (AST.NSimple vhdl_id)
-    (map AST.BDISD signal_decls)
-    (inport_assigns ++ outport_assigns ++ statements)
-
--- Generate a VHDL entity declaration for the given function
-getEntity :: HWFunction -> AST.EntityDec  
-getEntity (HWFunction vhdl_id inports outport) = 
-  AST.EntityDec vhdl_id ports
-  where
-    ports = 
-      (concat $ map (mkIfaceSigDecs AST.In) inports)
-      ++ mkIfaceSigDecs AST.Out outport
-
-mkIfaceSigDecs ::
-  AST.Mode                        -- The port's mode (In or Out)
-  -> SignalNameMap AST.VHDLId        -- The ports to generate a map for
-  -> [AST.IfaceSigDec]            -- The resulting ports
-  
-mkIfaceSigDecs mode (Signal port_id) =
-  -- TODO: Remove hardcoded type
-  [AST.IfaceSigDec port_id mode vhdl_bit_ty]
-
-mkIfaceSigDecs mode (Tuple ports) =
-  concat $ map (mkIfaceSigDecs mode) ports
-
--- Create concurrent assignments of one map of signals to another. The maps
--- should have a similar form.
-createSignalAssignments ::
-  SignalNameMap AST.VHDLId         -- The signals to assign to
-  -> SignalNameMap AST.VHDLId      -- The signals to assign
-  -> [AST.ConcSm]                  -- The resulting assignments
-
--- A simple assignment of one signal to another (greatly complicated because
--- signal assignments can be conditional with multiple conditions in VHDL).
-createSignalAssignments (Signal dst) (Signal src) =
-    [AST.CSSASm assign]
-  where
-    src_name  = AST.NSimple src
-    src_expr  = AST.PrimName src_name
-    src_wform = AST.Wform [AST.WformElem src_expr Nothing]
-    dst_name  = (AST.NSimple dst)
-    assign    = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
-
-createSignalAssignments (Tuple dsts) (Tuple srcs) =
-  concat $ zipWith createSignalAssignments dsts srcs
-
-createSignalAssignments dst src =
-  error $ "Non matching source and destination: " ++ show dst ++ "\nand\n" ++  show src
-
-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 AST.VHDLId]
-getPortNameMapForTys prefix num [] = [] 
-getPortNameMapForTys prefix num (t:ts) =
-  (getPortNameMapForTy (prefix ++ show num) t) : getPortNameMapForTys prefix (num + 1) ts
-
-getPortNameMapForTy :: String -> Type -> SignalNameMap AST.VHDLId
-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 (AST.unsafeVHDLBasicId name)
+    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

-    (tycon, args) = Type.splitTyConApp ty 
-
-data HWFunction = HWFunction { -- A function that is available in hardware
-  vhdlId    :: AST.VHDLId,
-  inPorts   :: [SignalNameMap AST.VHDLId],
-  outPort   :: SignalNameMap AST.VHDLId
-  --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 (mkVHDLId name) inports outport)
+    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
   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)
-
--- Shortcut
-mkVHDLId :: String -> AST.VHDLId
-mkVHDLId = AST.unsafeVHDLBasicId
-
-builtin_funcs = 
-  [ 
-    ("hwxor", HWFunction (mkVHDLId "hwxor") [Signal $ mkVHDLId "a", Signal $ mkVHDLId "b"] (Signal $ mkVHDLId "o")),
-    ("hwand", HWFunction (mkVHDLId "hwand") [Signal $ mkVHDLId "a", Signal $ mkVHDLId "b"] (Signal $ mkVHDLId "o")),
-    ("hwor", HWFunction (mkVHDLId "hwor") [Signal $ mkVHDLId "a", Signal $ mkVHDLId "b"] (Signal $ mkVHDLId "o")),
-    ("hwnot", HWFunction (mkVHDLId "hwnot") [Signal $ mkVHDLId "i"] (Signal $ mkVHDLId "o"))
-  ]
-
-vhdl_bit_ty :: AST.TypeMark
-vhdl_bit_ty = AST.unsafeVHDLBasicId "Bit"
+    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: