[commit: ghc] : Tag primops specially, skip wrappers for saturated occurrences (98ac939)

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : 

http://hackage.haskell.org/trac/ghc/changeset/98ac939666b06db9a24ef2a1ff29b807ff4b4aa3

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

commit 98ac939666b06db9a24ef2a1ff29b807ff4b4aa3
Author: Max Bolingbroke <[email protected]>
Date:   Thu Mar 22 14:26:59 2012 +0000

    Tag primops specially, skip wrappers for saturated occurrences

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

 compiler/supercompile/Supercompile/Core/Tag.hs |   22 +++++++++++++++++-----
 compiler/supercompile/Supercompile/GHC.hs      |   13 +++++++++++--
 2 files changed, 28 insertions(+), 7 deletions(-)

diff --git a/compiler/supercompile/Supercompile/Core/Tag.hs b/compiler/supercompile/Supercompile/Core/Tag.hs
index 924149d..fbfe9f8 100644
--- a/compiler/supercompile/Supercompile/Core/Tag.hs
+++ b/compiler/supercompile/Supercompile/Core/Tag.hs
@@ -9,6 +9,8 @@ import Supercompile.Core.Size
 import Supercompile.Core.Syntax
 
 import Literal (hashLiteral)
+import Unique  (mkPrimOpIdUnique)
+import qualified PrimOp as PrimOp (primOpTag)
 
 
 tagTerm :: UniqSupply -> Term -> TaggedTerm
@@ -22,13 +24,23 @@ tagFVedTerm = mkTagger (\tg e -> Comp (Tagged tg e))
 -- be one tag for a particular value. If we give every occurrence of (:) in the input
 -- program a different tag we can get weird situations (like gen_regexps) where programs
 -- are specialised on very long repititions of the same constructor.
+--
+-- The special treatment of PrimOp has a similar reason, and is necessary because I started
+-- treating PrimOp specially and unfolding it without going through the wrapper if it is
+-- saturated. This saves us from ANFing the arguments to a primop, which is cool!
+
+uniqueToTag :: Unique -> Tag
+uniqueToTag = mkTag . negate . abs . getKey -- Works well because (hashLiteral l) is always positive
 
 dataConTag :: DataCon -> Tag
-dataConTag dc = mkTag (negate (abs (getKey (getUnique dc)))) -- Works well because (hashLiteral l) is always positive. Don't use dataConTag because tags are shared between DC families
+dataConTag = uniqueToTag . getUnique -- Don't use dataConTag because tags are shared between DC families, and [], True and all dictionary all get the same tag!!
 
 literalTag :: Literal -> Tag
 literalTag = mkTag . hashLiteral
 
+primOpTag :: PrimOp -> Tag
+primOpTag = uniqueToTag . mkPrimOpIdUnique . PrimOp.primOpTag
+
 
 {-# INLINE mkTagger #-}
 mkTagger :: (Copointed ann, Functor ann')
@@ -47,8 +59,8 @@ mkTagger rec = term
         TyApp e ty        -> tag $ \ids -> TyApp (term ids e) ty
         CoApp e co        -> tag $ \ids -> CoApp (term ids e) co
         App e x           -> tag $ \ids -> App (term ids e) x
-        PrimOp pop tys es -> tag $ \ids -> let idss' = listSplitUniqSupply ids
-                                           in PrimOp pop tys (zipWith term idss' es)
+        PrimOp pop tys es -> rec (primOpTag pop) $ replace e $ let idss' = listSplitUniqSupply ids
+                                                               in PrimOp pop tys (zipWith term idss' es)
         Case e x ty alts  -> tag $ \ids -> let (ids0', ids1') = splitUniqSupply ids
                                            in Case (term ids0' e) x ty (alternatives ids1' alts)
         Let x e1 e2       -> tag $ \ids -> let (ids0', ids1') = splitUniqSupply ids
@@ -63,8 +75,8 @@ mkTagger rec = term
         Indirect x         -> tag $ \_ -> Indirect x
         TyLambda x e       -> tag $ \ids -> TyLambda x (term ids e)
         Lambda x e         -> tag $ \ids -> Lambda x (term ids e)
-        Data dc tys cos xs -> rec (dataConTag dc) (replace e (Data dc tys cos xs))
-        Literal l          -> rec (literalTag l)  (replace e (Literal l))
+        Data dc tys cos xs -> rec (dataConTag dc) $ replace e (Data dc tys cos xs)
+        Literal l          -> rec (literalTag l)  $ replace e (Literal l)
         Coercion co        -> tag $ \_ -> Coercion co
       where tag = tag_rec ids e
 
diff --git a/compiler/supercompile/Supercompile/GHC.hs b/compiler/supercompile/Supercompile/GHC.hs
index 5e5ff06..50e8754 100644
--- a/compiler/supercompile/Supercompile/GHC.hs
+++ b/compiler/supercompile/Supercompile/GHC.hs
@@ -26,6 +26,7 @@ import CoreUnfold (exprIsConApp_maybe)
 import Coercion   (Coercion, isCoVar, isCoVarType, mkCoVarCo, mkAxInstCo)
 import DataCon    (DataCon, dataConWorkId, dataConTyCon, dataConName)
 import Var        (isTyVar)
+import PrimOp     (primOpSig)
 import Id
 import MkId       (mkPrimOpId)
 import FastString (mkFastString)
@@ -148,10 +149,18 @@ conAppToTerm dc es
 coreExprToTerm :: CoreExpr -> ParseM S.Term
 coreExprToTerm init_e = {-# SCC "coreExprToTerm" #-} term init_e
   where
-    -- PrimOp and (partially applied) Data are dealt with later on by generating appropriate unfoldings
-    -- We use exprIsConApp_maybe here to ensure we desugar explicit constructor use into something that looks cheap
+    -- Partially-applied PrimOp and Data are dealt with later on by generating appropriate unfoldings
+    -- We use exprIsConApp_maybe here to ensure we desugar explicit constructor use into something that looks cheap,
+    -- and we do our own thing to spot saturated primop applications
     term e | Just (dc, univ_tys, es) <- exprIsConApp_maybe (const NoUnfolding) e
            = conAppToTerm dc (map Type univ_tys ++ es)
+           | (Var x, es) <- collectArgs e
+           , Just pop <- isPrimOpId_maybe x
+           , (tys, es) <- takeWhileJust (\e -> case e of Type ty -> Just ty; _ -> Nothing) es
+           , all isValArg es
+           , (_,_,_,arity,_) <- primOpSig pop
+           , length es == arity
+           = fmap (S.primOp pop tys) (mapM term es)
     term (Var x)                   = return $ S.var x
     term (Lit l)                   = return $ S.value (S.Literal l)
     term (App e_fun (Type ty_arg)) = fmap (flip S.tyApp ty_arg) (term e_fun)