X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=Flatten.hs;h=e550db8b695045a808bc97f6dc570fb15051c8e2;hb=a07f47bf0b471c935e3e76e814b2f6ebfb298d35;hp=7ce63a536a40595211a59e8888e065adf4931080;hpb=fd283d841521c3b87bc0de64f21188f6d282c058;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git diff --git a/Flatten.hs b/Flatten.hs index 7ce63a5..e550db8 100644 --- a/Flatten.hs +++ b/Flatten.hs @@ -1,39 +1,19 @@ module Flatten where import CoreSyn +import Control.Monad +import qualified Var import qualified Type import qualified Name -import qualified TyCon import qualified Maybe import qualified DataCon import qualified CoreUtils +import Control.Applicative 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 --- 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 +import HsValueMap +import TranslatorTypes +import FlattenTypes -- Extract the arguments from a data constructor application (that is, the -- normal args, leaving out the type args). @@ -43,101 +23,9 @@ dataConAppArgs dc args = where tycount = length $ DataCon.dataConAllTyVars dc - - -data FlatFunction = FlatFunction { - args :: [SignalDefMap], - res :: SignalUseMap, - --sigs :: [SignalDef], - 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 -} deriving (Show, Eq) - -data SignalDef = SignalDef { - sigDefId :: SignalId -} deriving (Show, Eq) - -data FApp = FApp { - 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 = [( - CoreBndr, -- ^ The bind name - Either -- ^ The bind value which is either - SignalUseMap -- ^ a signal - ( - HsValueUse, -- ^ or a HighOrder function - [SignalUse] -- ^ With these signals already applied to it - ) - )] - -type FlattenState = State.State ([FApp], [CondDef], SignalId) - --- | Add an application to the current FlattenState -addApp :: FApp -> 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 + -> FlattenState (SignalUseMap UnnamedSignal) genSignalUses ty = do typeMapToUseMap tymap @@ -147,14 +35,14 @@ genSignalUses ty = do typeMapToUseMap :: HsValueMap Type.Type - -> FlattenState SignalUseMap + -> FlattenState (SignalUseMap UnnamedSignal) typeMapToUseMap (Single ty) = do id <- genSignalId return $ Single (SignalUse id) typeMapToUseMap (Tuple tymaps) = do - usemaps <- mapM typeMapToUseMap tymaps + usemaps <- State.mapM typeMapToUseMap tymaps return $ Tuple usemaps -- | Flatten a haskell function @@ -175,7 +63,7 @@ flattenFunction hsfunc bind@(NonRec var expr) = flattenExpr :: BindMap -> CoreExpr - -> FlattenState ([SignalDefMap], SignalUseMap) + -> FlattenState ([SignalDefMap UnnamedSignal], (SignalUseMap UnnamedSignal)) flattenExpr binds lam@(Lam b expr) = do -- Find the type of the binder @@ -209,11 +97,101 @@ 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) - flattenApplicationExpr binds ty f args = error $ "Function application 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 + 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 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 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 UnnamedSignal], SignalUseMap UnnamedSignal) + -- 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 []) +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: