From: Matthijs Kooijman Date: Sun, 21 Jun 2009 15:59:24 +0000 (+0200) Subject: Add and use a mkFunction utility function. X-Git-Url: https://git.stderr.nl/gitweb?a=commitdiff_plain;h=9e042c5d285ad14daeee9847116e6338aa609903;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git Add and use a mkFunction utility function. This function creates a new function with a given body and adds it to the TransformMonad state. The function is named after an existing binder, but with a new Unique. --- diff --git a/Normalize.hs b/Normalize.hs index a011991..93e89b6 100644 --- a/Normalize.hs +++ b/Normalize.hs @@ -302,14 +302,13 @@ typeprop, typeproptop :: Transform -- arguments without any free tyvars, since tyvars those wouldn't be in scope -- in the new function. typeprop expr@(App (Var f) arg@(Type ty)) | not $ has_free_tyvars arg = do - id <- cloneVar f - let newty = Type.applyTy (Id.idType f) ty - let newf = Var.setVarType id newty body_maybe <- Trans.lift $ getGlobalBind f case body_maybe of Just body -> do let newbody = App body (Type ty) - Trans.lift $ addGlobalBind newf newbody + -- Create a new function with the same name but a new body + newf <- mkFunction f newbody + -- Replace the application with this new function change (Var newf) -- If we don't have a body for the function called, leave it unchanged (it -- should be a primitive function then). @@ -346,11 +345,8 @@ funprop expr@(App _ _) | is_var fexpr && not (any has_free_tyvars args) = do -- Create a new body that consists of a lambda for all new arguments and -- the old body applied to some arguments. let newbody = MkCore.mkCoreLams newparams (MkCore.mkCoreApps body oldargs) - -- Create a new function name - id <- cloneVar f - let newf = Var.setVarType id (CoreUtils.exprType newbody) - -- Add the new function - Trans.lift $ addGlobalBind newf newbody + -- Create a new function with the same name but a new body + newf <- mkFunction f newbody -- Replace the original application with one of the new function to the -- new arguments. change $ MkCore.mkCoreApps (Var newf) newargs diff --git a/NormalizeTools.hs b/NormalizeTools.hs index c36d85f..25c9273 100644 --- a/NormalizeTools.hs +++ b/NormalizeTools.hs @@ -74,6 +74,17 @@ cloneVar v = do -- contains, but vannillaIdInfo is always correct, since it means "no info"). return $ Var.lazySetVarIdInfo (Var.setVarUnique v uniq) IdInfo.vanillaIdInfo +-- Creates a new function with the same name as the given binder (but with a +-- new unique) and with the given function body. Returns the new binder for +-- this function. +mkFunction :: CoreBndr -> CoreExpr -> TransformMonad CoreBndr +mkFunction bndr body = do + let ty = CoreUtils.exprType body + id <- cloneVar bndr + let newid = Var.setVarType id ty + Trans.lift $ addGlobalBind newid body + return newid + -- Apply the given transformation to all expressions in the given expression, -- including the expression itself. everywhere :: (String, Transform) -> Transform