X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=Flatten.hs;h=598c8c6050df46cba753bb97351aff4abf4c559a;hb=3bd18744c55ac99fbc0fff05c74926e80be92ff9;hp=a6b3be8f294eaed3ed07320975161c15d4fa91c1;hpb=17a24cefad374d2ac91e3249867ff291fe0a761e;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

diff --git a/Flatten.hs b/Flatten.hs
index a6b3be8..598c8c6 100644
--- a/Flatten.hs
+++ b/Flatten.hs
@@ -1,7 +1,38 @@
 module Flatten where
-import Translator (HsValueMap)
+import CoreSyn
+import qualified Type
+import qualified Name
+import qualified TyCon
+import qualified Maybe
+import qualified CoreUtils
+import qualified Control.Monad.State as State
+
+-- | 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.Type                         -- ^ The type to map to a HsValueMap
+  -> HsValueMap Type.Type           -- ^ The resulting map and state
+
+mkHsValueMap ty =
+  case Type.splitTyConApp_maybe ty of
+    Just (tycon, args) ->
+      if (TyCon.isTupleTyCon tycon) 
+        then
+          Tuple (map mkHsValueMap args)
+        else
+          Single ty
+    Nothing -> Single ty
+
 data FlatFunction = FlatFunction {
   args   :: [SignalDefMap],
   res    :: SignalUseMap,
@@ -13,12 +44,17 @@ data FlatFunction = FlatFunction {
 type SignalUseMap = HsValueMap SignalUse
 type SignalDefMap = HsValueMap SignalDef
 
+useMapToDefMap :: SignalUseMap -> SignalDefMap
+useMapToDefMap (Single (SignalUse u)) = Single (SignalDef u)
+useMapToDefMap (Tuple uses) = Tuple (map useMapToDefMap uses)
+
+type SignalId = Int
 data SignalUse = SignalUse {
-  sigUseId :: Int
+  sigUseId :: SignalId
 } deriving (Show, Eq)
 
 data SignalDef = SignalDef {
-  sigDefId :: Int
+  sigDefId :: SignalId
 } deriving (Show, Eq)
 
 data App = App {
@@ -57,12 +93,98 @@ data HsFunction = HsFunction {
 } deriving (Show, Eq)
 
 type BindMap = [(
-  String,              -- ^ The bind name
+  CoreBndr,            -- ^ The bind name
   Either               -- ^ The bind value which is either
-    SignalUse          -- ^ a signal
+    SignalUseMap       -- ^ a signal
     (
       HsValueUse,      -- ^ or a HighOrder function
       [SignalUse]      -- ^ With these signals already applied to it
     )
   )]
+
+type FlattenState = State.State ([App], [CondDef], SignalId)
+
+-- | Add an application to the current FlattenState
+addApp :: App -> FlattenState ()
+addApp a = do
+  (apps, conds, n) <- State.get
+  State.put (a:apps, conds, n)
+
+-- | Add a conditional definition to the current FlattenState
+addCondDef :: CondDef -> FlattenState ()
+addCondDef c = do
+  (apps, conds, n) <- State.get
+  State.put (apps, c:conds, n)
+
+-- | Generates a new signal id, which is unique within the current flattening.
+genSignalId :: FlattenState SignalId 
+genSignalId = do
+  (apps, conds, n) <- State.get
+  State.put (apps, conds, n+1)
+  return n
+
+genSignalUses ::
+  Type.Type
+  -> FlattenState SignalUseMap
+
+genSignalUses ty = do
+  typeMapToUseMap tymap
+  where
+    -- First generate a map with the right structure containing the types
+    tymap = mkHsValueMap ty
+
+typeMapToUseMap ::
+  HsValueMap Type.Type
+  -> FlattenState SignalUseMap
+
+typeMapToUseMap (Single ty) = do
+  id <- genSignalId
+  return $ Single (SignalUse id)
+
+typeMapToUseMap (Tuple tymaps) = do
+  usemaps <- mapM typeMapToUseMap tymaps
+  return $ Tuple usemaps
+
+-- | Flatten a haskell function
+flattenFunction ::
+  HsFunction                      -- ^ The function to flatten
+  -> CoreBind                     -- ^ The function value
+  -> FlatFunction                 -- ^ The resulting flat function
+
+flattenFunction _ (Rec _) = error "Recursive binders not supported"
+flattenFunction hsfunc bind@(NonRec var expr) =
+  FlatFunction args res apps conds
+  where
+    init_state        = ([], [], 0)
+    (fres, end_state) = State.runState (flattenExpr [] expr) init_state
+    (args, res)       = fres
+    (apps, conds, _)  = end_state
+
+flattenExpr ::
+  BindMap
+  -> CoreExpr
+  -> FlattenState ([SignalDefMap], SignalUseMap)
+
+flattenExpr binds lam@(Lam b expr) = do
+  -- Find the type of the binder
+  let (arg_ty, _) = Type.splitFunTy (CoreUtils.exprType lam)
+  -- Create signal names for the binder
+  defs <- genSignalUses arg_ty
+  let binds' = (b, Left defs):binds
+  (args, res) <- flattenExpr binds' expr
+  return ((useMapToDefMap defs) : args, res)
+
+flattenExpr binds (Var id) =
+  case bind of
+    Left sig_use -> return ([], sig_use)
+    Right _ -> error "Higher order functions not supported."
+  where
+    bind = Maybe.fromMaybe
+      (error $ "Argument " ++ Name.getOccString id ++ "is unknown")
+      (lookup id binds)
+
+flattenExpr _ _ = do
+  return ([], Tuple [])
+
+
 -- vim: set ts=8 sw=2 sts=2 expandtab: