X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=Normalize.hs;h=2ecf2fa102ba5b56cdc5b9457ac8c792666c06dd;hb=35d10dbd4dcd24f3bd8a46e3a359d6f16dccfd32;hp=9a74152ac66388d69cb570e1e806c566752c79cc;hpb=3f604aecb0825aa68463da50137adbc74acfe8de;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

diff --git a/Normalize.hs b/Normalize.hs
index 9a74152..2ecf2fa 100644
--- a/Normalize.hs
+++ b/Normalize.hs
@@ -140,7 +140,7 @@ letflattop = everywhere ("letflat", letflat)
 --------------------------------
 -- Remove a = b bindings from let expressions everywhere
 letremovetop :: Transform
-letremovetop = everywhere ("letremove", inlinebind (\(b, e) -> case e of (Var v) | not $ Id.isDataConWorkId v -> True; otherwise -> False))
+letremovetop = everywhere ("letremove", inlinebind (\(b, e) -> case e of (Var v) | not $ Id.isDataConWorkId v -> return True; otherwise -> return False))
 
 --------------------------------
 -- Function inlining
@@ -157,8 +157,8 @@ letremovetop = everywhere ("letremove", inlinebind (\(b, e) -> case e of (Var v)
 -- will just not work on those function-typed values at first, but the other
 -- transformations (in particular β-reduction) should make sure that the type
 -- of those values eventually becomes primitive.
-inlinefuntop :: Transform
-inlinefuntop = everywhere ("inlinefun", inlinebind (is_applicable . snd))
+inlinenonreptop :: Transform
+inlinenonreptop = everywhere ("inlinenonrep", inlinebind ((Monad.liftM not) . isRepr . snd))
 
 --------------------------------
 -- Scrutinee simplification
@@ -307,48 +307,17 @@ appsimpl expr = return expr
 -- Perform this transform everywhere
 appsimpltop = everywhere ("appsimpl", appsimpl)
 
---------------------------------
--- Type argument propagation
---------------------------------
--- Remove all applications to type arguments, by duplicating the function
--- called with the type application in its new definition. We leave
--- dictionaries that might be associated with the type untouched, the funprop
--- transform should propagate these later on.
-typeprop, typeproptop :: Transform
--- Transform any function that is applied to a type argument. Since type
--- arguments are always the first ones to apply and we'll remove all type
--- arguments, we can simply do them one by one. We only propagate type
--- 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
-  body_maybe <- Trans.lift $ getGlobalBind f
-  case body_maybe of
-    Just body -> do
-      let newbody = App body (Type ty)
-      -- 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).
-    Nothing -> return expr
--- Leave all other expressions unchanged
-typeprop expr = return expr
--- Perform this transform everywhere
-typeproptop = everywhere ("typeprop", typeprop)
-
-
 --------------------------------
 -- Function-typed argument propagation
 --------------------------------
 -- Remove all applications to function-typed arguments, by duplication the
 -- function called with the function-typed parameter replaced by the free
 -- variables of the argument passed in.
-funprop, funproptop :: Transform
+argprop, argproptop :: Transform
 -- Transform any application of a named function (i.e., skip applications of
 -- lambda's). Also skip applications that have arguments with free type
 -- variables, since we can't inline those.
-funprop expr@(App _ _) | is_var fexpr && not (any has_free_tyvars args) = do
+argprop expr@(App _ _) | is_var fexpr = do
   -- Find the body of the function called
   body_maybe <- Trans.lift $ getGlobalBind f
   case body_maybe of
@@ -387,32 +356,38 @@ funprop expr@(App _ _) | is_var fexpr && not (any has_free_tyvars args) = do
     -- in the new function body, and arg is the argument to apply to the old
     -- function body.
     doarg :: CoreExpr -> TransformMonad ([CoreExpr], [CoreBndr], CoreExpr)
-    doarg arg | is_fun arg = do
+    doarg arg = do
+      repr <- isRepr arg
       bndrs <- Trans.lift getGlobalBinders
-      -- Find interesting free variables, each of which should be passed to
-      -- the new function instead of the original function argument.
-      -- 
-      -- Interesting vars are those that are local, but not available from the
-      -- top level scope (functions from this module are defined as local, but
-      -- they're not local to this function, so we can freely move references
-      -- to them into another function).
       let interesting var = Var.isLocalVar var && (not $ var `elem` bndrs)
-      let free_vars = VarSet.varSetElems $ CoreFVs.exprSomeFreeVars interesting arg
-      -- Mark the current expression as changed
-      setChanged
-      return (map Var free_vars, free_vars, arg)
-    -- Non-functiontyped arguments can be unchanged. Note that this handles
-    -- both values and types.
-    doarg arg = do
-      -- TODO: preserve original naming?
-      id <- mkBinderFor arg "param"
-      -- Just pass the original argument to the new function, which binds it
-      -- to a new id and just pass that new id to the old function body.
-      return ([arg], [id], mkReferenceTo id) 
+      if not repr && not (is_var arg && interesting (exprToVar arg)) && not (has_free_tyvars arg) 
+        then do
+          -- Propagate all complex arguments that are not representable, but not
+          -- arguments with free type variables (since those would require types
+          -- not known yet, which will always be known eventually).
+          -- Find interesting free variables, each of which should be passed to
+          -- the new function instead of the original function argument.
+          -- 
+          -- Interesting vars are those that are local, but not available from the
+          -- top level scope (functions from this module are defined as local, but
+          -- they're not local to this function, so we can freely move references
+          -- to them into another function).
+          let free_vars = VarSet.varSetElems $ CoreFVs.exprSomeFreeVars interesting arg
+          -- Mark the current expression as changed
+          setChanged
+          return (map Var free_vars, free_vars, arg)
+        else do
+          -- Representable types will not be propagated, and arguments with free
+          -- type variables will be propagated later.
+          -- TODO: preserve original naming?
+          id <- mkBinderFor arg "param"
+          -- Just pass the original argument to the new function, which binds it
+          -- to a new id and just pass that new id to the old function body.
+          return ([arg], [id], mkReferenceTo id) 
 -- Leave all other expressions unchanged
-funprop expr = return expr
+argprop expr = return expr
 -- Perform this transform everywhere
-funproptop = everywhere ("funprop", funprop)
+argproptop = everywhere ("argprop", argprop)
 
 --------------------------------
 -- Function-typed argument extraction
@@ -473,7 +448,7 @@ funextracttop = everywhere ("funextract", funextract)
 
 
 -- What transforms to run?
-transforms = [typeproptop, funproptop, funextracttop, etatop, betatop, castproptop, letremovetop, letrectop, letsimpltop, letflattop, casewildtop, scrutsimpltop, casevalsimpltop, caseremovetop, inlinefuntop, appsimpltop]
+transforms = [argproptop, funextracttop, etatop, betatop, castproptop, letremovetop, letrectop, letsimpltop, letflattop, casewildtop, scrutsimpltop, casevalsimpltop, caseremovetop, inlinenonreptop, appsimpltop]
 
 -- Turns the given bind into VHDL
 normalizeModule ::