[commit: ghc] wip/T12626: Optimize mkApps and collectArgs (ed151f6)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/T12626
Link       : http://ghc.haskell.org/trac/ghc/changeset/ed151f6641372b4fbb59ba82031d0bfb95ae1dbe/ghc

>---------------------------------------------------------------

commit ed151f6641372b4fbb59ba82031d0bfb95ae1dbe
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Mon Sep 26 10:54:22 2016 -0400

    Optimize mkApps and collectArgs
    
    so that these do pack/unpack only once, and not repeatedly, and maintain
    the invariant that Apps constructors do not nest (this invariant can be
    revisited; it is not crucial here.)


>---------------------------------------------------------------

ed151f6641372b4fbb59ba82031d0bfb95ae1dbe
 compiler/coreSyn/CoreSyn.hs | 38 +++++++++++++++++++-------------------
 1 file changed, 19 insertions(+), 19 deletions(-)

diff --git a/compiler/coreSyn/CoreSyn.hs b/compiler/coreSyn/CoreSyn.hs
index 9adfb07..7dcad45 100644
--- a/compiler/coreSyn/CoreSyn.hs
+++ b/compiler/coreSyn/CoreSyn.hs
@@ -280,22 +280,21 @@ data Expr b
 
 
 class CompressArgs b where
-    unpackArgs :: Expr b -> Arity -> [Expr b] -> [Expr b]
+    unpackArgs :: Expr b -> Arity -> [Arg b] -> [Arg b]
     unpackArgs _ _ l = l
 
-    packArgs :: Expr b -> [Expr b] -> [Expr b]
+    packArgs :: Expr b -> [Arg b] -> [Arg b]
     packArgs _ l = l
 
-popArg :: CompressArgs b => Expr b -> Maybe (Expr b, Expr b)
-popArg (Apps e a xs) = case unpackArgs e a xs of
-    [x] -> Just (e, x)
-    xs  -> Just (Apps e (a-1) (packArgs e (init xs)), last xs)
-popArg _ = Nothing
+popArg :: CompressArgs b => Expr b -> Maybe (Expr b, Arg b)
+popArg e = case collectArgs e of
+    (_, []) -> Nothing
+    (f, xs) -> Just (mkApps f (init xs), last xs)
 
 pattern App :: () => CompressArgs b => Expr b -> Arg b -> Expr b
 pattern App e1 e2 <- (popArg -> Just (e1, e2))
   where App e1 e2 | (f, args) <- collectArgs e1
-                  = Apps f (length args +1) (packArgs f (args ++ [e2]))
+                  = mkApps f (args ++ [e2])
 
 -- | Type synonym for expressions that occur in function argument positions.
 -- Only 'Arg' should contain a 'Type' at top level, general 'Expr' should not
@@ -1444,7 +1443,7 @@ type CoreAlt  = Alt  CoreBndr
 
 -- Simple compression scheme, as a proof of concept: Only look for type
 -- arguments that thare the type of one argument.
-defaultPackArgs :: (Expr b -> Type) -> Expr b -> [Expr b] -> [Expr b]
+defaultPackArgs :: (Expr b -> Type) -> Expr b -> [Arg b] -> [Arg b]
 defaultPackArgs typeOf f args
     = go pis args
  where
@@ -1468,7 +1467,7 @@ defaultPackArgs typeOf f args
     isTyVar v (Anon t) | Just v' <- getTyVar_maybe t, v == v' = True
     isTyVar _ _ = False
 
-defaultUnpackArgs :: (Expr b -> Type) -> Expr b -> Arity -> [Expr b] -> [Expr b]
+defaultUnpackArgs :: (Expr b -> Type) -> Expr b -> Arity -> [Arg b] -> [Arg b]
 defaultUnpackArgs typeOf f arity args
     = go pis args
  where
@@ -1564,12 +1563,16 @@ mkVarApps :: CompressArgs b => Expr b -> [Var] -> Expr b
 -- use 'MkCore.mkCoreConApps' if possible
 mkConApp  :: CompressArgs b => DataCon -> [Arg b] -> Expr b
 
-mkApps    f args = foldl App                       f args
-mkCoApps  f args = foldl (\ e a -> App e (Coercion a)) f args
-mkVarApps f vars = foldl (\ e a -> App e (varToCoreExpr a)) f vars
+mkApps e [] = e
+mkApps e args2 = Apps f (length args) (packArgs f args)
+  where
+    (f, args1) = collectArgs e
+    args = args1 ++ args2
+mkCoApps  f args = mkApps f (map Coercion args)
+mkVarApps f vars = mkApps f (map varToCoreExpr vars)
 mkConApp con args = mkApps (Var (dataConWorkId con)) args
 
-mkTyApps  f args = foldl (\ e a -> App e (typeOrCoercion a)) f args
+mkTyApps  f args = mkApps f (map typeOrCoercion args)
   where
     typeOrCoercion ty
       | Just co <- isCoercionTy_maybe ty = Coercion co
@@ -1763,11 +1766,8 @@ collectTyAndValBinders expr
 -- | Takes a nested application expression and returns the the function
 -- being applied and the arguments to which it is applied
 collectArgs :: CompressArgs b => Expr b -> (Expr b, [Arg b])
-collectArgs expr
-  = go expr []
-  where
-    go (App f a) as = go f (a:as)
-    go e         as = (e, as)
+collectArgs (Apps e a xs) = (e, unpackArgs e a xs)
+collectArgs e = (e, [])
 
 -- | Like @collectArgs@, but also collects looks through floatable
 -- ticks if it means that we can find more arguments.