X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=Flatten.hs;h=14fd781c5c6653ca989c393eb038f5af42cb38ab;hb=3ed479f405a79b401f3f1e88a7a4a735ce62d5d6;hp=b12663df05ec8eaee5e22337c2cacddaac08c9dc;hpb=b7821e23b33faefc7de2fad54513e0d4d70e9729;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git diff --git a/Flatten.hs b/Flatten.hs index b12663d..14fd781 100644 --- a/Flatten.hs +++ b/Flatten.hs @@ -1,12 +1,17 @@ module Flatten where import CoreSyn +import Control.Monad +import qualified Var 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 +24,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 +127,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 +204,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 @@ -214,11 +259,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], 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 []) +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: