From 17a24cefad374d2ac91e3249867ff291fe0a761e Mon Sep 17 00:00:00 2001 From: Matthijs Kooijman Date: Fri, 6 Feb 2009 09:36:59 +0100 Subject: [PATCH 01/16] Add a new module "Flatten". Only contains data structures so far, but this module will also contain code for translaten Core to FlatFunctions. --- Flatten.hs | 68 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 68 insertions(+) create mode 100644 Flatten.hs diff --git a/Flatten.hs b/Flatten.hs new file mode 100644 index 0000000..a6b3be8 --- /dev/null +++ b/Flatten.hs @@ -0,0 +1,68 @@ +module Flatten where +import Translator (HsValueMap) + + +data FlatFunction = FlatFunction { + args :: [SignalDefMap], + res :: SignalUseMap, + --sigs :: [SignalDef], + apps :: [App], + conds :: [CondDef] +} deriving (Show, Eq) + +type SignalUseMap = HsValueMap SignalUse +type SignalDefMap = HsValueMap SignalDef + +data SignalUse = SignalUse { + sigUseId :: Int +} deriving (Show, Eq) + +data SignalDef = SignalDef { + sigDefId :: Int +} deriving (Show, Eq) + +data App = App { + appFunc :: HsFunction, + appArgs :: [SignalUseMap], + appRes :: SignalDefMap +} deriving (Show, Eq) + +data CondDef = CondDef { + cond :: SignalUse, + high :: SignalUse, + low :: SignalUse, + condRes :: SignalDef +} deriving (Show, Eq) + +-- | 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 Int -- ^ Use it as state (input or output). The int is used to + -- match input state to output state. + | HighOrder { -- ^ Use it as a high order function input + hoName :: String, -- ^ Which function is passed in? + hoArgs :: [HsUseMap] -- ^ Which arguments are already applied? This + -- ^ map should only contain Port and other + -- HighOrder values. + } + deriving (Show, Eq) + +type HsUseMap = HsValueMap HsValueUse + +data HsFunction = HsFunction { + hsFuncName :: String, + hsFuncArgs :: [HsUseMap], + hsFuncRes :: HsUseMap +} deriving (Show, Eq) + +type BindMap = [( + String, -- ^ The bind name + Either -- ^ The bind value which is either + SignalUse -- ^ a signal + ( + HsValueUse, -- ^ or a HighOrder function + [SignalUse] -- ^ With these signals already applied to it + ) + )] +-- vim: set ts=8 sw=2 sts=2 expandtab: -- 2.30.2 From ec4c3ac86e30289a4eab441edc96a5d6556eeb57 Mon Sep 17 00:00:00 2001 From: Matthijs Kooijman Date: Fri, 6 Feb 2009 12:13:13 +0100 Subject: [PATCH 02/16] Add flattenFunction and flattenExpr. This does not add any actual implementation for flattenExpr, just an empty function. This also duplicates the HsValueMap type from Translator, to prevent dependency loops when testing. --- Flatten.hs | 39 ++++++++++++++++++++++++++++++++++++++- 1 file changed, 38 insertions(+), 1 deletion(-) diff --git a/Flatten.hs b/Flatten.hs index a6b3be8..3c5fda7 100644 --- a/Flatten.hs +++ b/Flatten.hs @@ -1,6 +1,15 @@ module Flatten where -import Translator (HsValueMap) +import CoreSyn +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 + | Unused + deriving (Show, Eq) data FlatFunction = FlatFunction { args :: [SignalDefMap], @@ -65,4 +74,32 @@ type BindMap = [( [SignalUse] -- ^ With these signals already applied to it ) )] + +type FlattenState = State.State ([App], [CondDef], Int) + +-- | 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 :: + CoreExpr + -> FlattenState ([SignalDefMap], SignalUseMap) + +flattenExpr _ = do + return ([], Tuple []) + + + + -- vim: set ts=8 sw=2 sts=2 expandtab: -- 2.30.2 From 1730303a697c4c35941919ada4e45e7a64803a7f Mon Sep 17 00:00:00 2001 From: Matthijs Kooijman Date: Fri, 6 Feb 2009 12:19:36 +0100 Subject: [PATCH 03/16] Add accessor methods for FlattenState. --- Flatten.hs | 26 +++++++++++++++++++++++--- 1 file changed, 23 insertions(+), 3 deletions(-) diff --git a/Flatten.hs b/Flatten.hs index 3c5fda7..ee70446 100644 --- a/Flatten.hs +++ b/Flatten.hs @@ -22,12 +22,13 @@ data FlatFunction = FlatFunction { type SignalUseMap = HsValueMap SignalUse type SignalDefMap = HsValueMap SignalDef +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 { @@ -75,7 +76,26 @@ type BindMap = [( ) )] -type FlattenState = State.State ([App], [CondDef], Int) +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 -- | Flatten a haskell function flattenFunction :: -- 2.30.2 From e659acb706f7f097be7882d2feaecba2b9e91544 Mon Sep 17 00:00:00 2001 From: Matthijs Kooijman Date: Fri, 6 Feb 2009 12:23:25 +0100 Subject: [PATCH 04/16] Add a BindMap argument to flattenExpr. --- Flatten.hs | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/Flatten.hs b/Flatten.hs index ee70446..0ee9595 100644 --- a/Flatten.hs +++ b/Flatten.hs @@ -108,15 +108,17 @@ flattenFunction hsfunc bind@(NonRec var expr) = FlatFunction args res apps conds where init_state = ([], [], 0) - (fres, end_state) = State.runState (flattenExpr expr) init_state + (fres, end_state) = State.runState (flattenExpr [] expr) init_state (args, res) = fres (apps, conds, _) = end_state flattenExpr :: - CoreExpr + BindMap + -> CoreExpr -> FlattenState ([SignalDefMap], SignalUseMap) -flattenExpr _ = do + +flattenExpr _ _ = do return ([], Tuple []) -- 2.30.2 From 32aa5de7a4cce4eff72bafb70221854302056f11 Mon Sep 17 00:00:00 2001 From: Matthijs Kooijman Date: Mon, 9 Feb 2009 15:36:03 +0100 Subject: [PATCH 05/16] Learn flattenExpr about Lambda expressions. --- Flatten.hs | 57 +++++++++++++++++++++++++++++++++++++++++++++++++----- 1 file changed, 52 insertions(+), 5 deletions(-) diff --git a/Flatten.hs b/Flatten.hs index 0ee9595..f3057e8 100644 --- a/Flatten.hs +++ b/Flatten.hs @@ -1,5 +1,8 @@ module Flatten where import CoreSyn +import qualified Type +import qualified TyCon +import qualified CoreUtils import qualified Control.Monad.State as State -- | A datatype that maps each of the single values in a haskell structure to @@ -8,9 +11,26 @@ import qualified Control.Monad.State as State data HsValueMap mapto = Tuple [HsValueMap mapto] | Single mapto - | Unused 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, @@ -67,9 +87,9 @@ 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 @@ -97,6 +117,28 @@ genSignalId = do 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 @@ -117,11 +159,16 @@ flattenExpr :: -> 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 + flattenExpr binds' expr flattenExpr _ _ = do return ([], Tuple []) - - -- vim: set ts=8 sw=2 sts=2 expandtab: -- 2.30.2 From 0b61849203b38c59a3878a1208d1de68943d6882 Mon Sep 17 00:00:00 2001 From: Matthijs Kooijman Date: Mon, 9 Feb 2009 15:53:10 +0100 Subject: [PATCH 06/16] Learn flattenExpr about Var expressions. --- Flatten.hs | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/Flatten.hs b/Flatten.hs index f3057e8..52316ec 100644 --- a/Flatten.hs +++ b/Flatten.hs @@ -1,7 +1,9 @@ module Flatten where import CoreSyn import qualified Type +import qualified Name import qualified TyCon +import qualified Maybe import qualified CoreUtils import qualified Control.Monad.State as State @@ -167,6 +169,15 @@ flattenExpr binds lam@(Lam b expr) = do let binds' = (b, Left defs):binds flattenExpr binds' expr +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 []) -- 2.30.2 From 3bd18744c55ac99fbc0fff05c74926e80be92ff9 Mon Sep 17 00:00:00 2001 From: Matthijs Kooijman Date: Mon, 9 Feb 2009 16:00:01 +0100 Subject: [PATCH 07/16] Make flattenExpr return signal definitions for arguments. This makes the "wire" example be flattened properly. --- Flatten.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/Flatten.hs b/Flatten.hs index 52316ec..598c8c6 100644 --- a/Flatten.hs +++ b/Flatten.hs @@ -44,6 +44,10 @@ 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 :: SignalId @@ -167,7 +171,8 @@ 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 -- 2.30.2 From fd283d841521c3b87bc0de64f21188f6d282c058 Mon Sep 17 00:00:00 2001 From: Matthijs Kooijman Date: Mon, 9 Feb 2009 16:20:26 +0100 Subject: [PATCH 08/16] 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. --- Flatten.hs | 37 +++++++++++++++++++++++++++++++++---- 1 file changed, 33 insertions(+), 4 deletions(-) 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 []) -- 2.30.2 From 9d4873628a889f02b7a4124505dbe18307ecb6e8 Mon Sep 17 00:00:00 2001 From: Matthijs Kooijman Date: Mon, 9 Feb 2009 17:18:40 +0100 Subject: [PATCH 09/16] Make HsValueMap an instance of Functor. --- Flatten.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/Flatten.hs b/Flatten.hs index 7ce63a5..42ce020 100644 --- a/Flatten.hs +++ b/Flatten.hs @@ -17,7 +17,9 @@ data HsValueMap mapto = | Single mapto deriving (Show, Eq) - +instance Functor HsValueMap where + fmap f (Single s) = Single (f s) + fmap f (Tuple maps) = Tuple (fmap (fmap f) maps) -- | Creates a HsValueMap with the same structure as the given type, using the -- given function for mapping the single types. @@ -57,8 +59,7 @@ 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) +useMapToDefMap = fmap (\(SignalUse u) -> SignalDef u) type SignalId = Int data SignalUse = SignalUse { -- 2.30.2 From b7821e23b33faefc7de2fad54513e0d4d70e9729 Mon Sep 17 00:00:00 2001 From: Matthijs Kooijman Date: Mon, 9 Feb 2009 17:18:49 +0100 Subject: [PATCH 10/16] Add defMapTouseMap function. --- Flatten.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/Flatten.hs b/Flatten.hs index 42ce020..b12663d 100644 --- a/Flatten.hs +++ b/Flatten.hs @@ -61,6 +61,10 @@ type SignalDefMap = HsValueMap SignalDef useMapToDefMap :: SignalUseMap -> SignalDefMap useMapToDefMap = fmap (\(SignalUse u) -> SignalDef u) +defMapToUseMap :: SignalDefMap -> SignalUseMap +defMapToUseMap = fmap (\(SignalDef u) -> SignalUse u) + + type SignalId = Int data SignalUse = SignalUse { sigUseId :: SignalId -- 2.30.2 From 9b95e5fa73bad447aeb98bcd3270e8ed721cc18a Mon Sep 17 00:00:00 2001 From: Matthijs Kooijman Date: Wed, 11 Feb 2009 12:05:59 +0100 Subject: [PATCH 11/16] Add useAsPort and useAsState functions. For this, HsValueMap is made Traversable and a PassState type to wrap a function was added as well. --- Flatten.hs | 48 ++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 46 insertions(+), 2 deletions(-) diff --git a/Flatten.hs b/Flatten.hs index b12663d..4157e1b 100644 --- a/Flatten.hs +++ b/Flatten.hs @@ -1,12 +1,16 @@ module Flatten where import CoreSyn +import Control.Monad import qualified Type import qualified Name import qualified TyCon import qualified Maybe +import Data.Traversable import qualified DataCon import qualified CoreUtils +import Control.Applicative import Outputable ( showSDoc, ppr ) +import qualified Data.Foldable as Foldable import qualified Control.Monad.State as State -- | A datatype that maps each of the single values in a haskell structure to @@ -19,7 +23,26 @@ data HsValueMap mapto = instance Functor HsValueMap where fmap f (Single s) = Single (f s) - fmap f (Tuple maps) = Tuple (fmap (fmap f) maps) + fmap f (Tuple maps) = Tuple (map (fmap f) maps) + +instance Foldable.Foldable HsValueMap where + foldMap f (Single s) = f s + -- The first foldMap folds a list of HsValueMaps, the second foldMap folds + -- each of the HsValueMaps in that list + foldMap f (Tuple maps) = Foldable.foldMap (Foldable.foldMap f) maps + +instance Traversable HsValueMap where + traverse f (Single s) = Single <$> f s + traverse f (Tuple maps) = Tuple <$> (traverse (traverse f) maps) + +data PassState s x = PassState (s -> (s, x)) + +instance Functor (PassState s) where + fmap f (PassState a) = PassState (\s -> let (s', a') = a s in (s', f a')) + +instance Applicative (PassState s) where + pure x = PassState (\s -> (s, x)) + PassState f <*> PassState x = PassState (\s -> let (s', f') = f s; (s'', x') = x s' in (s'', f' x')) -- | Creates a HsValueMap with the same structure as the given type, using the -- given function for mapping the single types. @@ -103,6 +126,27 @@ data HsValueUse = type HsUseMap = HsValueMap HsValueUse +-- | Builds a HsUseMap with the same structure has the given HsValueMap in +-- which all the Single elements are marked as State, with increasing state +-- numbers. +useAsState :: HsValueMap a -> HsUseMap +useAsState map = + map' + where + -- Traverse the existing map, resulting in a function that maps an initial + -- state number to the final state number and the new map + PassState f = traverse asState map + -- Run this function to get the new map + (_, map') = f 0 + -- This function maps each element to a State with a unique number, by + -- incrementing the state count. + asState x = PassState (\s -> (s+1, State s)) + +-- | Builds a HsUseMap with the same structure has the given HsValueMap in +-- which all the Single elements are marked as Port. +useAsPort :: HsValueMap a -> HsUseMap +useAsPort map = fmap (\x -> Port) map + data HsFunction = HsFunction { hsFuncName :: String, hsFuncArgs :: [HsUseMap], @@ -159,7 +203,7 @@ typeMapToUseMap (Single ty) = do return $ Single (SignalUse id) typeMapToUseMap (Tuple tymaps) = do - usemaps <- mapM typeMapToUseMap tymaps + usemaps <- State.mapM typeMapToUseMap tymaps return $ Tuple usemaps -- | Flatten a haskell function -- 2.30.2 From ade131124b0b12d47b4bcafd3808bd9db31428cd Mon Sep 17 00:00:00 2001 From: Matthijs Kooijman Date: Wed, 11 Feb 2009 12:25:59 +0100 Subject: [PATCH 12/16] Learn flattenExpr to flatten normal applications. --- Flatten.hs | 40 +++++++++++++++++++++++++++++++++++++++- 1 file changed, 39 insertions(+), 1 deletion(-) diff --git a/Flatten.hs b/Flatten.hs index 4157e1b..9d05043 100644 --- a/Flatten.hs +++ b/Flatten.hs @@ -1,6 +1,7 @@ module Flatten where import CoreSyn import Control.Monad +import qualified Var import qualified Type import qualified Name import qualified TyCon @@ -259,10 +260,47 @@ flattenExpr binds app@(App _ _) = do 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) + -- | Flatten a normal application expression + flattenApplicationExpr binds ty f args = do + -- Find the function to call + let func = appToHsFunction ty f args + -- Flatten each of our args + flat_args <- (State.mapM (flattenExpr binds) args) + -- Check and split each of the arguments + let (_, arg_ress) = unzip (zipWith checkArg args flat_args) + -- Generate signals for our result + res <- genSignalUses ty + -- Create the function application + let app = FApp { + appFunc = func, + appArgs = arg_ress, + appRes = useMapToDefMap res + } + addApp app + return ([], res) + -- | Check a flattened expression to see if it is valid to use as a + -- function argument. The first argument is the original expression for + -- use in the error message. + checkArg arg flat = + let (args, res) = flat in + if not (null args) + then error $ "Passing lambda expression or function as a function argument not supported: " ++ (showSDoc $ ppr arg) + else flat flattenExpr _ _ = do return ([], Tuple []) +appToHsFunction :: + Type.Type -- ^ The return type + -> Var.Var -- ^ The function to call + -> [CoreExpr] -- ^ The function arguments + -> HsFunction -- ^ The needed HsFunction + +appToHsFunction ty f args = + HsFunction hsname hsargs hsres + where + hsname = Name.getOccString f + hsargs = map (useAsPort . mkHsValueMap . CoreUtils.exprType) args + hsres = useAsPort (mkHsValueMap ty) -- vim: set ts=8 sw=2 sts=2 expandtab: -- 2.30.2 From 0649eca400625120642cb5eaf5c482cf1c858ee1 Mon Sep 17 00:00:00 2001 From: Matthijs Kooijman Date: Wed, 11 Feb 2009 12:37:50 +0100 Subject: [PATCH 13/16] Learn flattenExpr about building tuples. --- Flatten.hs | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/Flatten.hs b/Flatten.hs index 9d05043..7dc261e 100644 --- a/Flatten.hs +++ b/Flatten.hs @@ -259,7 +259,14 @@ flattenExpr binds app@(App _ _) = do let ((Var f), args) = collectArgs app in flattenApplicationExpr binds (CoreUtils.exprType app) f args where - flattenBuildTupleExpr = error $ "Tuple construction not supported: " ++ (showSDoc $ ppr app) + flattenBuildTupleExpr binds args = do + -- Flatten each of our args + flat_args <- (State.mapM (flattenExpr binds) args) + -- Check and split each of the arguments + let (_, arg_ress) = unzip (zipWith checkArg args flat_args) + let res = Tuple arg_ress + return ([], res) + -- | Flatten a normal application expression flattenApplicationExpr binds ty f args = do -- Find the function to call -- 2.30.2 From 2b45c15cd9100b39789e276bd8a5d7263298b4a9 Mon Sep 17 00:00:00 2001 From: Matthijs Kooijman Date: Wed, 11 Feb 2009 12:48:36 +0100 Subject: [PATCH 14/16] Learn flattenExpr about Let expressions. --- Flatten.hs | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/Flatten.hs b/Flatten.hs index 7dc261e..20efce5 100644 --- a/Flatten.hs +++ b/Flatten.hs @@ -294,6 +294,17 @@ flattenExpr binds app@(App _ _) = do then error $ "Passing lambda expression or function as a function argument not supported: " ++ (showSDoc $ ppr arg) else flat +flattenExpr binds l@(Let (NonRec b bexpr) expr) = do + (b_args, b_res) <- flattenExpr binds bexpr + if not (null b_args) + then + error $ "Higher order functions not supported in let expression: " ++ (showSDoc $ ppr l) + else + let binds' = (b, Left b_res) : binds in + flattenExpr binds' expr + +flattenExpr binds l@(Let (Rec _) _) = error $ "Recursive let definitions not supported: " ++ (showSDoc $ ppr l) + flattenExpr _ _ = do return ([], Tuple []) -- 2.30.2 From 5c2c241b255ef85381694cf48961b43d1deeb16e Mon Sep 17 00:00:00 2001 From: Matthijs Kooijman Date: Wed, 11 Feb 2009 12:58:28 +0100 Subject: [PATCH 15/16] Learn flattenExpr about single alt Case expressions. --- Flatten.hs | 35 +++++++++++++++++++++++++++++++++++ 1 file changed, 35 insertions(+) diff --git a/Flatten.hs b/Flatten.hs index 20efce5..14fd781 100644 --- a/Flatten.hs +++ b/Flatten.hs @@ -305,6 +305,41 @@ flattenExpr binds l@(Let (NonRec b bexpr) expr) = do flattenExpr binds l@(Let (Rec _) _) = error $ "Recursive let definitions not supported: " ++ (showSDoc $ ppr l) +flattenExpr binds expr@(Case (Var v) b _ alts) = + case alts of + [alt] -> flattenSingleAltCaseExpr binds v b alt + otherwise -> error $ "Multiple alternative case expression not supported: " ++ (showSDoc $ ppr expr) + where + flattenSingleAltCaseExpr :: + BindMap + -- A list of bindings in effect + -> Var.Var -- The scrutinee + -> CoreBndr -- The binder to bind the scrutinee to + -> CoreAlt -- The single alternative + -> FlattenState ( [SignalDefMap], SignalUseMap) + -- See expandExpr + flattenSingleAltCaseExpr 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. + Left (Tuple tuple_sigs) = Maybe.fromMaybe + (error $ "Case expression uses unknown scrutinee " ++ Name.getOccString v) + (lookup v binds) + -- TODO include b in the binds list + -- Merge our existing binds with the new binds. + binds' = (zip bind_vars (map Left tuple_sigs)) ++ binds + in + -- Expand the expression with the new binds list + flattenExpr binds' expr + flattenSingleAltCaseExpr _ _ _ alt = error $ "Case patterns other than data constructors not supported in case alternative: " ++ (showSDoc $ ppr alt) + + + flattenExpr _ _ = do return ([], Tuple []) -- 2.30.2 From 289124685555aeb479d5ab238585c5e27346cf09 Mon Sep 17 00:00:00 2001 From: Matthijs Kooijman Date: Wed, 11 Feb 2009 15:39:57 +0100 Subject: [PATCH 16/16] Add pretty printing functions for FlatFunction. These pretty printing functions are based on Text.PrettyPrint.HughesPJ and the related Text.PrettyPrint.HughesPJClass from the prettyclass package. --- Pretty.hs | 40 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 40 insertions(+) create mode 100644 Pretty.hs diff --git a/Pretty.hs b/Pretty.hs new file mode 100644 index 0000000..bb62591 --- /dev/null +++ b/Pretty.hs @@ -0,0 +1,40 @@ +module Pretty (prettyShow) where + +import Text.PrettyPrint.HughesPJClass +import Flatten + +instance Pretty HsFunction where + pPrint (HsFunction name args res) = + text name <> char ' ' <> parens (hsep $ punctuate comma args') <> text " -> " <> res' + where + args' = map pPrint args + res' = pPrint res + +instance Pretty x => Pretty (HsValueMap x) where + pPrint (Tuple maps) = parens (hsep $ punctuate comma (map pPrint maps)) + pPrint (Single s) = pPrint s + +instance Pretty HsValueUse where + pPrint Port = char 'P' + pPrint (State n) = char 'C' <> int n + pPrint (HighOrder _ _) = text "Higher Order" + +instance Pretty FlatFunction where + pPrint (FlatFunction args res apps conds) = + (text "Args: ") $$ nest 10 (pPrint args) + $+$ (text "Result: ") $$ nest 10 (pPrint res) + $+$ (text "Apps: ") $$ nest 10 (vcat (map pPrint apps)) + $+$ (text "Conds: ") $$ nest 10 (pPrint conds) + +instance Pretty FApp where + pPrint (FApp func args res) = + pPrint func <> text " : " <> pPrint args <> text " -> " <> pPrint res + +instance Pretty SignalDef where + pPrint (SignalDef id) = pPrint id + +instance Pretty SignalUse where + pPrint (SignalUse id) = pPrint id + +instance Pretty CondDef where + pPrint _ = text "TODO" -- 2.30.2