Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch :
http://hackage.haskell.org/trac/ghc/changeset/98ac939666b06db9a24ef2a1ff29b807ff4b4aa3 >--------------------------------------------------------------- commit 98ac939666b06db9a24ef2a1ff29b807ff4b4aa3 Author: Max Bolingbroke <batterseapo...@hotmail.com> 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) _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
