X-Git-Url: https://git.stderr.nl/gitweb?p=matthijs%2Fmaster-project%2Fc%CE%BBash.git;a=blobdiff_plain;f=Flatten.hs;h=d25ef73aceabb2feec43007b1a469b267a72ce09;hp=f62046c369c5889e507ab546d979e6e9a7389cc9;hb=HEAD;hpb=14367b6b9fd0770a78e02fad425daa369df4bec6 diff --git a/Flatten.hs b/Flatten.hs index f62046c..d25ef73 100644 --- a/Flatten.hs +++ b/Flatten.hs @@ -1,6 +1,6 @@ module Flatten where import CoreSyn -import Control.Monad +import qualified Control.Monad as Monad import qualified Var import qualified Type import qualified Name @@ -8,6 +8,7 @@ import qualified Maybe import qualified Control.Arrow as Arrow import qualified DataCon import qualified TyCon +import qualified Literal import qualified CoreUtils import qualified TysWiredIn import qualified IdInfo @@ -15,11 +16,12 @@ import qualified Data.Traversable as Traversable import qualified Data.Foldable as Foldable import Control.Applicative import Outputable ( showSDoc, ppr ) -import qualified Control.Monad.State as State +import qualified Control.Monad.Trans.State as State import HsValueMap import TranslatorTypes import FlattenTypes +import CoreTools -- Extract the arguments from a data constructor application (that is, the -- normal args, leaving out the type args). @@ -52,11 +54,10 @@ markSignal use id = markSignals use [id] -- | Flatten a haskell function flattenFunction :: HsFunction -- ^ The function to flatten - -> CoreBind -- ^ The function value + -> (CoreBndr, CoreExpr) -- ^ The function value -> FlatFunction -- ^ The resulting flat function -flattenFunction _ (Rec _) = error "Recursive binders not supported" -flattenFunction hsfunc bind@(NonRec var expr) = +flattenFunction hsfunc (var, expr) = FlatFunction args res defs sigs where init_state = ([], [], 0) @@ -138,6 +139,9 @@ flattenExpr binds lam@(Lam b expr) = do let (arg_ty, _) = Type.splitFunTy (CoreUtils.exprType lam) -- Create signal names for the binder defs <- genSignals arg_ty + -- Add name hints to the generated signals + let binder_name = Name.getOccString b + Traversable.mapM (addNameHint binder_name) defs let binds' = (b, Left defs):binds (args, res) <- flattenExpr binds' expr return (defs : args, res) @@ -154,11 +158,21 @@ flattenExpr binds var@(Var id) = Left sig_use -> return ([], sig_use) Right _ -> error "Higher order functions not supported." IdInfo.DataConWorkId datacon -> do - lit <- dataConToLiteral datacon - let ty = CoreUtils.exprType var - id <- genSignalId SigInternal ty - addDef (UncondDef (Right $ Literal lit) id) - return ([], Single id) + if DataCon.isTupleCon datacon && (null $ DataCon.dataConAllTyVars datacon) + then do + -- Empty tuple construction + return ([], Tuple []) + else do + lit <- dataConToLiteral datacon + let ty = CoreUtils.exprType var + sig_id <- genSignalId SigInternal ty + -- Add a name hint to the signal + addNameHint (Name.getOccString id) sig_id + addDef (UncondDef (Right $ Literal lit Nothing) sig_id) + return ([], Single sig_id) + IdInfo.VanillaGlobal -> + -- Treat references to globals as an application with zero elements + flattenApplicationExpr binds (CoreUtils.exprType var) id [] otherwise -> error $ "Ids other than local vars and dataconstructors not supported: " ++ (showSDoc $ ppr id) @@ -184,6 +198,8 @@ flattenExpr binds app@(App _ _) = do let (argtys, resty) = Type.splitFunTys $ CoreUtils.exprType app args <- mapM genSignals argtys res <- genSignals resty + mapM (Traversable.mapM (addNameHint "NC")) args + Traversable.mapM (addNameHint "NC") res return (args, res) else if fname == "==" then do -- Flatten the last two arguments (this skips the type arguments) @@ -191,6 +207,23 @@ flattenExpr binds app@(App _ _) = do ([], b) <- flattenExpr binds (last args) res <- mkEqComparisons a b return ([], res) + else if fname == "fromInteger" then do + let [to_ty, to_dict, val] = args + -- We assume this is an application of the GHC.Integer.smallInteger + -- function to a literal + let App smallint (Lit lit) = val + let (Literal.MachInt int) = lit + let ty = CoreUtils.exprType app + sig_id <- genSignalId SigInternal ty + -- TODO: fromInteger is defined for more types than just SizedWord + let len = sized_word_len ty + -- Use a to_unsigned to translate the number (a natural) to an unsiged + -- (array of bits) + let lit_str = "to_unsigned(" ++ (show int) ++ ", " ++ (show len) ++ ")" + -- Set the signal to our literal unconditionally, but add the type so + -- the literal will be typecast to the proper type. + addDef $ UncondDef (Right $ Literal lit_str (Just ty)) sig_id + return ([], Single sig_id) else flattenApplicationExpr binds (CoreUtils.exprType app) f args where @@ -203,51 +236,29 @@ flattenExpr binds app@(App _ _) = do mkEqComparison (a, b) = do -- Generate a signal to hold our result res <- genSignalId SigInternal TysWiredIn.boolTy + -- Add a name hint to the signal + addNameHint ("s" ++ show a ++ "_eq_s" ++ show b) res addDef (UncondDef (Right $ Eq a b) res) return res flattenBuildTupleExpr binds args = do -- Flatten each of our args - flat_args <- (State.mapM (flattenExpr binds) args) + flat_args <- (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 <- genSignals ty - -- Create the function application - let app = FApp { - appFunc = func, - appArgs = arg_ress, - appRes = res - } - addDef 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 + else do + let binds' = (b, Left b_res) : binds + -- Add name hints to the generated signals + let binder_name = Name.getOccString b + Traversable.mapM (addNameHint binder_name) b_res flattenExpr binds' expr flattenExpr binds l@(Let (Rec _) _) = error $ "Recursive let definitions not supported: " ++ (showSDoc $ ppr l) @@ -256,9 +267,12 @@ flattenExpr binds expr@(Case scrut b _ alts) = do -- TODO: Special casing for higher order functions -- Flatten the scrutinee (_, res) <- flattenExpr binds scrut + -- Put the scrutinee in the BindMap + let binds' = (b, Left res) : binds case alts of - [alt] -> flattenSingleAltCaseExpr binds res b alt - otherwise -> flattenMultipleAltCaseExpr binds res b alts + [alt] -> flattenSingleAltCaseExpr binds' res b alt + -- Reverse the alternatives, so the __DEFAULT alternative ends up last + otherwise -> flattenMultipleAltCaseExpr binds' res b (reverse alts) where flattenSingleAltCaseExpr :: BindMap @@ -270,18 +284,18 @@ flattenExpr binds expr@(Case scrut b _ alts) = do flattenSingleAltCaseExpr binds scrut b alt@(DataAlt datacon, bind_vars, expr) = if DataCon.isTupleCon datacon - then - let - -- Unpack 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. - Tuple tuple_sigs = scrut - -- 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 + then do + -- Unpack 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. + let Tuple tuple_sigs = scrut + -- Add name hints to the returned signals + let binder_name = Name.getOccString b + Monad.zipWithM (\name sigs -> Traversable.mapM (addNameHint $ Name.getOccString name) sigs) bind_vars tuple_sigs + -- Merge our existing binds with the new binds. + let binds' = (zip bind_vars (map Left tuple_sigs)) ++ binds + -- Expand the expression with the new binds list + flattenExpr binds' expr else if null bind_vars then @@ -290,6 +304,10 @@ flattenExpr binds expr@(Case scrut b _ alts) = do flattenExpr binds expr else error $ "Dataconstructors other than tuple constructors cannot have binder arguments in case pattern of alternative: " ++ (showSDoc $ ppr alt) + + flattenSingleAltCaseExpr binds _ _ alt@(DEFAULT, [], expr) = + flattenExpr binds expr + flattenSingleAltCaseExpr _ _ _ alt = error $ "Case patterns other than data constructors not supported in case alternative: " ++ (showSDoc $ ppr alt) flattenMultipleAltCaseExpr :: @@ -310,11 +328,13 @@ flattenExpr binds expr@(Case scrut b _ alts) = do let Single sig = scrut -- Create a signal that contains a boolean boolsigid <- genSignalId SigInternal TysWiredIn.boolTy + addNameHint ("s" ++ show sig ++ "_eq_" ++ lit) boolsigid let expr = EqLit sig lit addDef (UncondDef (Right expr) boolsigid) -- Create conditional assignments of either args/res or -- args'/res based on boolsigid, and return the result. - our_args <- zipWithM (mkConditionals boolsigid) args args' + -- TODO: It seems this adds the name hint twice? + our_args <- Monad.zipWithM (mkConditionals boolsigid) args args' our_res <- mkConditionals boolsigid res res' return (our_args, our_res) otherwise -> @@ -341,6 +361,36 @@ flattenExpr binds expr@(Case scrut b _ alts) = do flattenExpr _ expr = do error $ "Unsupported expression: " ++ (showSDoc $ ppr expr) +-- | 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 <- (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 <- genSignals ty + -- Add name hints to the generated signals + let resname = Name.getOccString f ++ "_res" + Traversable.mapM (addNameHint resname) res + -- Create the function application + let app = FApp { + appFunc = func, + appArgs = arg_ress, + appRes = res + } + addDef 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 + -- | Translates a dataconstructor without arguments to the corresponding -- literal. dataConToLiteral :: DataCon.DataCon -> FlattenState String @@ -395,28 +445,4 @@ stateList :: stateList uses signals = Maybe.catMaybes $ Foldable.toList $ zipValueMapsWith filterState signals uses --- | Returns pairs of signals that should be mapped to state in this function. -getOwnStates :: - HsFunction -- | The function to look at - -> FlatFunction -- | The function to look at - -> [(StateId, SignalInfo, SignalInfo)] - -- | The state signals. The first is the state number, the second the - -- signal to assign the current state to, the last is the signal - -- that holds the new state. - -getOwnStates hsfunc flatfunc = - [(old_num, old_info, new_info) - | (old_num, old_info) <- args_states - , (new_num, new_info) <- res_states - , old_num == new_num] - where - sigs = flat_sigs flatfunc - -- Translate args and res to lists of (statenum, sigid) - args = concat $ zipWith stateList (hsFuncArgs hsfunc) (flat_args flatfunc) - res = stateList (hsFuncRes hsfunc) (flat_res flatfunc) - -- Replace the second tuple element with the corresponding SignalInfo - args_states = map (Arrow.second $ signalInfo sigs) args - res_states = map (Arrow.second $ signalInfo sigs) res - - -- vim: set ts=8 sw=2 sts=2 expandtab: