Merge branch 'cλash' of http://git.stderr.nl/matthijs/projects/master-project

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

diff --git a/Translator.hs b/Translator.hs
index b2ce3ef59d679f95afb9b8aa8010af708b4bd21b..1786332678717097892bd84c7b2ac66c0badefba 100644 (file)
--- a/Translator.hs
+++ b/Translator.hs
@@ -1,22 +1,34 @@
-module Main(main) where
-import GHC
+module Translator where
+import qualified Directory
+import qualified List
+import Debug.Trace
+import qualified Control.Arrow as Arrow
+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 HscTypes ( cm_binds, cm_types )
 import MonadUtils ( liftIO )
 import Outputable ( showSDoc, ppr )
 import GHC.Paths ( libdir )
 import DynFlags ( defaultDynFlags )

+import qualified UniqSupply

 import List ( find )
 import qualified List
 import qualified Monad
 import List ( find )
 import qualified List
 import qualified Monad


@@ -31,522 +43,252 @@ import qualified ForSyDe.Backend.Ppr
 -- This is needed for rendering the pretty printed VHDL
 import Text.PrettyPrint.HughesPJ (render)
 
 -- 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)) ["shalf_adder"]
-          liftIO $ printBinds binds
-          -- Turn bind into VHDL
-          let (vhdl, sess) = State.runState (mkVHDL binds) (VHDLSession 0 [])
-          liftIO $ putStr $ render $ ForSyDe.Backend.Ppr.ppr vhdl
-          liftIO $ ForSyDe.Backend.VHDL.FileIO.writeDesignFile vhdl "../vhdl/vhdl/output.vhdl"
-          liftIO $ putStr $ "\n\nFinal session:\n" ++ show sess
-          return ()
+import TranslatorTypes
+import HsValueMap
+import Pretty
+import Normalize
+import Flatten
+import FlattenTypes
+import VHDLTypes
+import qualified VHDL
+
+main = do
+  makeVHDL "Adders.hs" "highordtest2" 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
+  let binds = findBinds core names
+  -- Generate a UniqSupply
+  -- Running 
+  --    egrep -r "(initTcRnIf|mkSplitUniqSupply)" .
+  -- on the compiler dir of ghc suggests that 'z' is not used to generate a
+  -- unique supply anywhere.
+  uniqSupply <- UniqSupply.mkSplitUniqSupply 'z'
+  -- Turn bind into VHDL
+  let (vhdl, sess) = State.runState (mkVHDL uniqSupply 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 :: UniqSupply.UniqSupply -> [(CoreBndr, CoreExpr)] -> [Bool] -> TranslatorState [(AST.VHDLId, AST.DesignFile)]
+    mkVHDL uniqSupply binds statefuls = do
+      let binds'' = map (Arrow.second $ normalize uniqSupply) binds
+      let binds' = trace ("Before:\n\n" ++ showSDoc ( ppr binds ) ++ "\n\nAfter:\n\n" ++ showSDoc ( ppr binds'')) binds''

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

-      mapM (uncurry addFunc) builtin_funcs
+      --mapM addBuiltIn builtin_funcs

       -- Create entities and architectures for them
       -- Create entities and architectures for them

-      units <- mapM expandBind binds
-      return $ AST.DesignFile 
-        []
-        (concat units)
-
-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
+      --Monad.zipWithM processBind statefuls binds
+      --modA tsFlatFuncs (Map.map nameFlatFunction)
+      --flatfuncs <- getA tsFlatFuncs
+      return $ VHDL.createDesignFiles binds'
+
+-- | 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.compileToCoreModule 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  -- The port name to bind to
-  -> SignalNameMap 
-                            -- 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 (Single (portname, _)) (Single (signame, _)) = 
-  (Just portname) AST.:=>: (AST.ADName (AST.NSimple signame))
-expandExpr ::
-  [(CoreBndr, SignalNameMap)] 
-                                         -- 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],       -- The signal names corresponding to
-                                         -- the expression's arguments
-       SignalNameMap)         -- 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 ([], [], [], bind)
-  where
-    -- Lookup the id in our binds map
-    bind = 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
-  -- Is this a data constructor application?
-  case CoreUtils.exprIsConApp_maybe app of
-    -- Is this a tuple construction?
-    Just (dc, args) -> if DataCon.isTupleCon dc 
-      then
-        expandBuildTupleExpr binds (dataConAppArgs dc args)
-      else
-        error "Data constructors other than tuples not supported"
-    otherise ->
-      -- Normal function application, should map to a component instantiation
-      let ((Var f), args) = collectArgs app in
-      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)] 
-                                         -- A list of bindings in effect
-  -> [CoreExpr]                          -- A list of expressions to put in the tuple
-  -> VHDLState ( [AST.SigDec], [AST.ConcSm], [SignalNameMap], SignalNameMap)
-                                         -- See expandExpr
-expandBuildTupleExpr binds args = do
-  -- Split the tuple constructor arguments into types and actual values.
-  -- Expand each of the values in the tuple
-  (signals_declss, statementss, arg_signalss, res_signals) <-
-    (Monad.liftM List.unzip4) $ mapM (expandExpr binds) args
-  if any (not . null) arg_signalss
-    then error "Putting high order functions in tuples not supported"
-    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)] 
-                            -- 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], SignalNameMap)
-                                         -- 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)] 
-                                         -- 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], SignalNameMap)
-                                         -- 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 (appToHsFunction f args ty)
-  -- 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      -- The port names to bind to
-  -> SignalNameMap   -- The signals to bind to it
-  -> [AST.AssocElem]            -- The resulting port map lines
-  
-createAssocElems (Single (port_id, _)) (Single (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.SigDec]
-
-mkSignalsFromMap (Single (id, ty)) =
-  [mkSignalFromId id ty]
-
-mkSignalsFromMap (Tuple signals) =
-  concat $ map mkSignalsFromMap signals
-
-expandArgs :: 
-  [(CoreBndr, SignalNameMap)] -- A list of bindings in effect
-  -> [CoreExpr]                          -- The arguments to expand
-  -> VHDLState ([AST.SigDec], [AST.ConcSm], [SignalNameMap])  
-                                         -- 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 ([], [], [])
-
--- Extract the arguments from a data constructor application (that is, the
--- normal args, leaving out the type args).
-dataConAppArgs :: DataCon -> [CoreExpr] -> [CoreExpr]
-dataConAppArgs dc args =
-    drop tycount args
-  where
-    tycount = length $ DataCon.dataConAllTyVars dc
-
-mapOutputPorts ::
-  SignalNameMap      -- The output portnames of the component
-  -> SignalNameMap   -- 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 (Single (portname, _)) (Single (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)
-
-expandBind ::
-  CoreBind                        -- The binder to expand into VHDL
-  -> VHDLState [AST.LibraryUnit]  -- The resulting VHDL
+  find (\(var, _) -> lookfor == (occNameString $ nameOccName $ getName var)) binds

 
 

-expandBind (Rec _) = error "Recursive binders not supported"
+-- | Processes the given bind as a top level bind.
+processBind ::
+  Bool                       -- ^ Should this be stateful function?
+  -> (CoreBndr, CoreExpr)    -- ^ The bind to process
+  -> TranslatorState ()

 
 

-expandBind bind@(NonRec var expr) = do
+processBind stateful bind@(var, expr) = do

   -- Create the function signature
   -- Create the function signature

-  hwfunc <- mkHWFunction bind

   let ty = CoreUtils.exprType expr
   let ty = CoreUtils.exprType expr

-  let hsfunc = mkHsFunction var ty
-  -- Add it to the session
-  addFunc hsfunc hwfunc 
-  arch <- getArchitecture hwfunc expr
-  let entity = getEntity hwfunc
-  return $ [
-    AST.LUEntity entity,
-    AST.LUArch arch ]
-
-getArchitecture ::
-  HWFunction                -- The function to generate an architecture for
-  -> CoreExpr               -- The expression that is bound to the function
-  -> VHDLState AST.ArchBody -- The resulting architecture
-   
-getArchitecture hwfunc expr = do
-  -- Unpack our hwfunc
-  let HWFunction vhdl_id inports outport = hwfunc
-  -- Expand the expression into an architecture body
-  (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
+  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

-    ports = 
-      (concat $ map (mkIfaceSigDecs AST.In) inports)
-      ++ mkIfaceSigDecs AST.Out outport
-
-mkIfaceSigDecs ::
-  AST.Mode                        -- The port's mode (In or Out)
-  -> SignalNameMap        -- The ports to generate a map for
-  -> [AST.IfaceSigDec]            -- The resulting ports
-  
-mkIfaceSigDecs mode (Single (port_id, ty)) =
-  [AST.IfaceSigDec port_id mode 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         -- The signals to assign to
-  -> SignalNameMap      -- 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 (Single (dst, _)) (Single (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
-
-type SignalNameMap = HsValueMap (AST.VHDLId, AST.TypeMark)
-
--- | A datatype that maps each of the single values in a haskell structure to
--- a mapto. The map has the same structure as the haskell type mapped, ie
--- nested tuples etc.
-data HsValueMap mapto =
-  Tuple [HsValueMap mapto]
-  | Single mapto
-  deriving (Show, Eq)
-
--- | Creates a HsValueMap with the same structure as the given type, using the
---   given function for mapping the single types.
-mkHsValueMap ::
-  (Type -> HsValueMap mapto)    -- ^ A function to map single value Types
-                                --   (basically anything but tuples) to a
-                                --   HsValueMap (not limited to the Single
-                                --   constructor)
-  -> Type                       -- ^ The type to map to a HsValueMap
-  -> HsValueMap mapto           -- ^ The resulting map
-
-mkHsValueMap f ty =
-  case Type.splitTyConApp_maybe ty of
-    Just (tycon, args) ->
-      if (TyCon.isTupleTyCon tycon) 
-        then
-          -- Handle tuple construction especially
-          Tuple (map (mkHsValueMap f) args)
-        else
-          -- And let f handle the rest
-          f ty
-    -- And let f handle the rest
-    Nothing -> f ty
-
--- Generate a port name map (or multiple for tuple types) in the given direction for
--- each type given.
-getPortNameMapForTys :: String -> Int -> [Type] -> [SignalNameMap]
-getPortNameMapForTys prefix num [] = [] 
-getPortNameMapForTys prefix num (t:ts) =
-  (getPortNameMapForTy (prefix ++ show num) t) : getPortNameMapForTys prefix (num + 1) ts
-
-getPortNameMapForTy :: String -> Type -> SignalNameMap
-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
-    Single ((AST.unsafeVHDLBasicId name), (vhdl_ty ty))
-  where
-    (tycon, args) = Type.splitTyConApp ty 
-
-data HWFunction = HWFunction { -- A function that is available in hardware
-  vhdlId    :: AST.VHDLId,
-  inPorts   :: [SignalNameMap],
-  outPort   :: SignalNameMap
-  --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 HWFunction                    -- The function interface
-
-mkHWFunction (NonRec var expr) =
-    return $ HWFunction (mkVHDLId name) inports outport
+    (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

-    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"
-
--- | How is a given (single) value in a function's type (ie, argument or
--- return value) used?
-data HsValueUse = 
-  Port -- ^ Use it as a port (input or output)
-  | State --- ^ Use it as state (input or output)
-  deriving (Show, Eq)
-
-useAsPort = mkHsValueMap (\x -> Single Port)
-useAsState = mkHsValueMap (\x -> Single State)
-
--- | This type describes a particular use of a Haskell function and is used to
---   look up an appropriate hardware description.  
-data HsFunction = HsFunction {
-  hsName :: String,                      -- ^ What was the name of the original Haskell function?
-  hsArgs :: [HsValueMap HsValueUse],     -- ^ How are the arguments used?
-  hsRes  :: HsValueMap HsValueUse        -- ^ How is the result value used?
-} deriving (Show, Eq)
-
--- | Translate a function application to a HsFunction. i.e., which function
---   do you need to translate this function application.
-appToHsFunction ::
-  Var.Var         -- ^ The function to call
-  -> [CoreExpr]   -- ^ The function arguments
-  -> Type         -- ^ The return type
-  -> HsFunction   -- ^ The needed HsFunction
-
-appToHsFunction f args ty =
-  HsFunction hsname hsargs hsres
+    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

-    mkPort = \x -> Single Port
-    hsargs = map (mkHsValueMap mkPort . CoreUtils.exprType) args
-    hsres  = mkHsValueMap mkPort ty
-    hsname = getOccString f
+    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
+  -- Not working with new builtins -- 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
 
 -- | Translate a top level function declaration to a HsFunction. i.e., which
 --   interface will be provided by this function. This function essentially


@@ -554,49 +296,56 @@ appToHsFunction f args ty =
 mkHsFunction ::
   Var.Var         -- ^ The function defined
   -> Type         -- ^ The function type (including arguments!)
 mkHsFunction ::
   Var.Var         -- ^ The function defined
   -> Type         -- ^ The function type (including arguments!)

+  -> Bool         -- ^ Is this a stateful function?

   -> HsFunction   -- ^ The resulting HsFunction
 
   -> HsFunction   -- ^ The resulting HsFunction
 

-mkHsFunction f ty =
+mkHsFunction f ty stateful=

   HsFunction hsname hsargs hsres
   where
     hsname  = getOccString f
     (arg_tys, res_ty) = Type.splitFunTys ty
   HsFunction hsname hsargs hsres
   where
     hsname  = getOccString f
     (arg_tys, res_ty) = Type.splitFunTys ty

-    -- The last argument must be state
-    state_ty = last arg_tys
-    state    = useAsState state_ty
-    -- All but the last argument are inports
-    inports = map useAsPort (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 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."
-
-data VHDLSession = VHDLSession {
-  nameCount :: Int,                       -- A counter that can be used to generate unique names
-  funcs     :: [(HsFunction, HWFunction)] -- All functions available
-} deriving (Show)
-
-type VHDLState = State.State VHDLSession
-
--- Add the function to the session
-addFunc :: HsFunction -> HWFunction -> VHDLState ()
-addFunc hsfunc hwfunc = do
-  fs <- State.gets funcs -- Get the funcs element from the session
-  State.modify (\x -> x {funcs = (hsfunc, hwfunc) : fs }) -- Prepend name and f
-
--- Lookup the function with the given name in the current session. Errors if
--- it was not found.
-getHWFunc :: HsFunction -> VHDLState HWFunction
-getHWFunc hsfunc = do
-  fs <- State.gets funcs -- Get the funcs element from the session
-  return $ Maybe.fromMaybe
-    (error $ "Function " ++ (hsName hsfunc) ++ "is unknown? This should not happen!")
-    (lookup hsfunc fs)
+    (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.
 
 -- | Splits a tuple type into a list of element types, or Nothing if the type
 --   is not a tuple type.


@@ -613,46 +362,4 @@ splitTupleType ty =
         Nothing
     Nothing -> Nothing
 
         Nothing
     Nothing -> Nothing
 

--- 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 = 
-  [ 
-    (HsFunction "hwxor" [(Single Port), (Single Port)] (Single Port), HWFunction (mkVHDLId "hwxor") [Single (mkVHDLId "a", vhdl_bit_ty), Single (mkVHDLId "b", vhdl_bit_ty)] (Single (mkVHDLId "o", vhdl_bit_ty))),
-    (HsFunction "hwand" [(Single Port), (Single Port)] (Single Port), HWFunction (mkVHDLId "hwand") [Single (mkVHDLId "a", vhdl_bit_ty), Single (mkVHDLId "b", vhdl_bit_ty)] (Single (mkVHDLId "o", vhdl_bit_ty))),
-    (HsFunction "hwor" [(Single Port), (Single Port)] (Single Port), HWFunction (mkVHDLId "hwor") [Single (mkVHDLId "a", vhdl_bit_ty), Single (mkVHDLId "b", vhdl_bit_ty)] (Single (mkVHDLId "o", vhdl_bit_ty))),
-    (HsFunction "hwnot" [(Single Port)] (Single Port), HWFunction (mkVHDLId "hwnot") [Single (mkVHDLId "i", vhdl_bit_ty)] (Single (mkVHDLId "o", vhdl_bit_ty)))
-  ]
-
-vhdl_bit_ty :: AST.TypeMark
-vhdl_bit_ty = AST.unsafeVHDLBasicId "Bit"
-
--- Translate a Haskell type to a VHDL type
-vhdl_ty :: Type -> AST.TypeMark
-vhdl_ty ty = Maybe.fromMaybe
-  (error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty))
-  (vhdl_ty_maybe ty)
-
--- Translate a Haskell type to a VHDL type
-vhdl_ty_maybe :: Type -> Maybe AST.TypeMark
-vhdl_ty_maybe ty =
-  case Type.splitTyConApp_maybe ty of
-    Just (tycon, args) ->
-      let name = TyCon.tyConName tycon in
-        -- TODO: Do something more robust than string matching
-        case getOccString name of
-          "Bit"      -> Just vhdl_bit_ty
-          otherwise  -> Nothing
-    otherwise -> Nothing
-

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