Learn flattenExpr about function application.

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

diff --git a/Flatten.hs b/Flatten.hs
index f3057e86399a1a2d895730719dc9954b87d17e87..7ce63a536a40595211a59e8888e065adf4931080 100644 (file)
--- a/Flatten.hs
+++ b/Flatten.hs
@@ -1,8 +1,12 @@
 module Flatten where
 import CoreSyn
 import qualified Type
+import qualified Name
 import qualified TyCon
+import qualified Maybe
+import qualified DataCon
 import qualified CoreUtils
+import Outputable ( showSDoc, ppr )
 import qualified Control.Monad.State as State
 
 -- | A datatype that maps each of the single values in a haskell structure to
@@ -31,17 +35,31 @@ mkHsValueMap ty =
           Single ty
     Nothing -> Single ty
 
+-- Extract the arguments from a data constructor application (that is, the
+-- normal args, leaving out the type args).
+dataConAppArgs :: DataCon.DataCon -> [CoreExpr] -> [CoreExpr]
+dataConAppArgs dc args =
+    drop tycount args
+  where
+    tycount = length $ DataCon.dataConAllTyVars dc
+
+
+
 data FlatFunction = FlatFunction {
   args   :: [SignalDefMap],
   res    :: SignalUseMap,
   --sigs   :: [SignalDef],
-  apps   :: [App],
+  apps   :: [FApp],
   conds  :: [CondDef]
 } deriving (Show, Eq)
     
 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 :: SignalId
@@ -51,7 +69,7 @@ data SignalDef = SignalDef {
   sigDefId :: SignalId
 } deriving (Show, Eq)
 
-data App = App {
+data FApp = FApp {
   appFunc :: HsFunction,
   appArgs :: [SignalUseMap],
   appRes  :: SignalDefMap
@@ -96,10 +114,10 @@ type BindMap = [(
     )
   )]
 
-type FlattenState = State.State ([App], [CondDef], SignalId)
+type FlattenState = State.State ([FApp], [CondDef], SignalId)
 
 -- | Add an application to the current FlattenState
-addApp :: App -> FlattenState ()
+addApp :: FApp -> FlattenState ()
 addApp a = do
   (apps, conds, n) <- State.get
   State.put (a:apps, conds, n)
@@ -165,7 +183,34 @@ flattenExpr binds lam@(Lam b expr) = do
   -- Create signal names for the binder
   defs <- genSignalUses arg_ty
   let binds' = (b, Left defs):binds
-  flattenExpr binds' expr
+  (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 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
+        flattenBuildTupleExpr binds (dataConAppArgs dc args)
+      else
+        error $ "Data constructors other than tuples not supported: " ++ (showSDoc $ ppr app)
+    otherwise ->
+      -- Normal function application
+      let ((Var f), args) = collectArgs app in
+      flattenApplicationExpr binds (CoreUtils.exprType app) f args
+  where
+    flattenBuildTupleExpr = error $ "Tuple construction not supported: " ++ (showSDoc $ ppr app)
+    flattenApplicationExpr binds ty f args = error $ "Function application not supported: " ++ (showSDoc $ ppr app)
 
 flattenExpr _ _ = do
   return ([], Tuple [])