From: Matthijs Kooijman Date: Mon, 9 Feb 2009 15:20:26 +0000 (+0100) Subject: Learn flattenExpr about function application. X-Git-Url: https://git.stderr.nl/gitweb?a=commitdiff_plain;h=fd283d841521c3b87bc0de64f21188f6d282c058;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git Learn flattenExpr about function application. This only distinguishes tuple construction, other data constructor application and other function applications, but does not actually flatten any of these yet. --- diff --git a/Flatten.hs b/Flatten.hs index 598c8c6..7ce63a5 100644 --- a/Flatten.hs +++ b/Flatten.hs @@ -4,7 +4,9 @@ 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 @@ -33,11 +35,21 @@ 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) @@ -57,7 +69,7 @@ data SignalDef = SignalDef { sigDefId :: SignalId } deriving (Show, Eq) -data App = App { +data FApp = FApp { appFunc :: HsFunction, appArgs :: [SignalUseMap], appRes :: SignalDefMap @@ -102,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) @@ -183,6 +195,23 @@ flattenExpr binds (Var id) = (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 [])