Commit 31478ab9 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Revive the static argument transformation

This patch revives the Static Argument Transformation, thanks to
Max Bolingbroke.  It is enabled with 
	-fstatic-argument-transformation
or	-O2

Headline nofib results

                  Size    Allocs   Runtime
Min             +0.0%    -13.7%    -21.4%
Max             +0.1%     +0.0%     +5.4%
Geometric Mean  +0.0%     -0.2%     -6.9%
parent 27061b5b
......@@ -237,6 +237,7 @@ data DynFlag
-- optimisation opts
| Opt_Strictness
| Opt_FullLaziness
| Opt_StaticArgumentTransformation
| Opt_CSE
| Opt_LiberateCase
| Opt_SpecConstr
......@@ -708,6 +709,7 @@ optLevelFlags
, ([2], Opt_LiberateCase)
, ([2], Opt_SpecConstr)
, ([2], Opt_StaticArgumentTransformation)
, ([0,1,2], Opt_DoLambdaEtaExpansion)
-- This one is important for a tiresome reason:
......@@ -827,6 +829,7 @@ getCoreToDo dflags
liberate_case = dopt Opt_LiberateCase dflags
rule_check = ruleCheck dflags
vectorisation = dopt Opt_Vectorise dflags
static_args = dopt Opt_StaticArgumentTransformation dflags
maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase)
......@@ -875,6 +878,12 @@ getCoreToDo dflags
[simpl_phase 0 ["final"] max_iter]
else {- opt_level >= 1 -} [
-- We want to do the static argument transform before full laziness as it
-- may expose extra opportunities to float things outwards. However, to fix
-- up the output of the transformation we need at do at least one simplify
-- after this before anything else
runWhen static_args CoreDoStaticArgs,
-- initial simplify: mk specialiser happy: minimum effort please
simpl_gently,
......@@ -1249,6 +1258,7 @@ fFlags = [
( "warn-tabs", Opt_WarnTabs ),
( "print-explicit-foralls", Opt_PrintExplicitForalls ),
( "strictness", Opt_Strictness ),
( "static-argument-transformation", Opt_StaticArgumentTransformation ),
( "full-laziness", Opt_FullLaziness ),
( "liberate-case", Opt_LiberateCase ),
( "spec-constr", Opt_SpecConstr ),
......
This diff is collapsed.
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
%************************************************************************
%* *
\section[SATMonad]{The Static Argument Transformation pass Monad}
%* *
%************************************************************************
96/03: We aren't using the static-argument transformation right now.
\begin{code}
{-# OPTIONS -w #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
-- for details
module SATMonad where
#include "HsVersions.h"
import Panic ( panic )
junk_from_SATMonad = panic "SATMonad.junk"
{- LATER: to end of file:
module SATMonad (
SATInfo(..), updSAEnv,
SatM(..), initSAT, emptyEnvSAT,
returnSAT, thenSAT, thenSAT_, mapSAT, getSATInfo, newSATName,
getArgLists, Arg(..), insSAEnv, saTransform,
SATEnv(..), isStatic, dropStatics
) where
import Type ( mkTyVarTy, mkSigmaTy,
splitSigmaTy, splitFunTys,
glueTyArgs, substTy,
InstTyEnv(..)
)
import MkId ( mkSysLocal )
import Id ( idType, idName, mkLocalId )
import UniqSupply
import Util
infixr 9 `thenSAT`, `thenSAT_`
\end{code}
%************************************************************************
%* *
\subsection{Static Argument Transformation Environment}
%* *
%************************************************************************
\begin{code}
type SATEnv = IdEnv SATInfo
type SATInfo = ([Arg Type],[Arg Id])
data Arg a = Static a | NotStatic
deriving Eq
delOneFromSAEnv v us env
= ((), delVarEnv env v)
updSAEnv :: Maybe (Id,SATInfo) -> SatM ()
updSAEnv Nothing
= returnSAT ()
updSAEnv (Just (b,(tyargs,args)))
= getSATInfo b `thenSAT` (\ r ->
case r of
Nothing -> returnSAT ()
Just (tyargs',args') -> delOneFromSAEnv b `thenSAT_`
insSAEnv b (checkArgs tyargs tyargs',
checkArgs args args')
)
checkArgs as [] = notStatics (length as)
checkArgs [] as = notStatics (length as)
checkArgs (a:as) (a':as') | a == a' = a:checkArgs as as'
checkArgs (_:as) (_:as') = NotStatic:checkArgs as as'
notStatics :: Int -> [Arg a]
notStatics n = nOfThem n NotStatic
insSAEnv :: Id -> SATInfo -> SatM ()
insSAEnv b info us env
= ((), extendVarEnv env b info)
\end{code}
%************************************************************************
%* *
\subsection{Static Argument Transformation Monad}
%* *
%************************************************************************
Two items of state to thread around: a UniqueSupply and a SATEnv.
\begin{code}
type SatM result
= UniqSupply -> SATEnv -> (result, SATEnv)
initSAT :: SatM a -> UniqSupply -> a
initSAT f us = fst (f us emptyVarEnv)
thenSAT m k us env
= case splitUniqSupply us of { (s1, s2) ->
case m s1 env of { (m_result, menv) ->
k m_result s2 menv }}
thenSAT_ m k us env
= case splitUniqSupply us of { (s1, s2) ->
case m s1 env of { (_, menv) ->
k s2 menv }}
emptyEnvSAT :: SatM ()
emptyEnvSAT us _ = ((), emptyVarEnv)
returnSAT v us env = (v, env)
mapSAT f [] = returnSAT []
mapSAT f (x:xs)
= f x `thenSAT` \ x' ->
mapSAT f xs `thenSAT` \ xs' ->
returnSAT (x':xs')
\end{code}
%************************************************************************
%* *
\subsection{Utility Functions}
%* *
%************************************************************************
\begin{code}
getSATInfo :: Id -> SatM (Maybe SATInfo)
getSATInfo var us env
= (lookupVarEnv env var, env)
newSATName :: Id -> Type -> SatM Id
newSATName id ty us env
= case (getUnique us) of { unique ->
let
new_name = mkCompoundName SLIT("$sat") unique (idName id)
in
(mkLocalId new_name ty, env) }
getArgLists :: CoreExpr -> ([Arg Type],[Arg Id])
getArgLists expr
= let
(tvs, lambda_bounds, body) = collectBinders expr
in
([ Static (mkTyVarTy tv) | tv <- tvs ],
[ Static v | v <- lambda_bounds ])
dropArgs :: CoreExpr -> CoreExpr
dropArgs (Lam _ e) = dropArgs e
dropArgs (CoTyLam _ e) = dropArgs e
dropArgs e = e
\end{code}
We implement saTransform using shadowing of binders, that is
we transform
map = \f as -> case as of
[] -> []
(a':as') -> let x = f a'
y = map f as'
in x:y
to
map = \f as -> let map = \f as -> map' as
in let rec map' = \as -> case as of
[] -> []
(a':as') -> let x = f a'
y = map f as'
in x:y
in map' as
the inner map should get inlined and eliminated.
\begin{code}
saTransform :: Id -> CoreExpr -> SatM CoreBinding
saTransform binder rhs
= getSATInfo binder `thenSAT` \ r ->
case r of
-- [Andre] test: do it only if we have more than one static argument.
--Just (tyargs,args) | any isStatic args
Just (tyargs,args) | (filter isStatic args) `lengthExceeds` 1
-> newSATName binder (new_ty tyargs args) `thenSAT` \ binder' ->
mkNewRhs binder binder' tyargs args rhs `thenSAT` \ new_rhs ->
trace ("SAT "++ show (length (filter isStatic args))) (
returnSAT (NonRec binder new_rhs)
)
_ -> returnSAT (Rec [(binder, rhs)])
where
mkNewRhs binder binder' tyargs args rhs
= let
non_static_args :: [Id]
non_static_args
= get_nsa args (snd (getArgLists rhs))
where
get_nsa :: [Arg a] -> [Arg a] -> [a]
get_nsa [] _ = []
get_nsa _ [] = []
get_nsa (NotStatic:args) (Static v:as) = v:get_nsa args as
get_nsa (_:args) (_:as) = get_nsa args as
local_body = foldl App (Var binder')
[VarArg a | a <- non_static_args]
nonrec_rhs = origLams local_body
-- HACK! The following is a fake SysLocal binder with
-- *the same* unique as binder.
-- the reason for this is the following:
-- this binder *will* get inlined but if it happen to be
-- a top level binder it is never removed as dead code,
-- therefore we have to remove that information (of it being
-- top-level or exported somehow.)
-- A better fix is to use binder directly but with the TopLevel
-- tag (or Exported tag) modified.
fake_binder = mkSysLocal SLIT("sat")
(getUnique binder)
(idType binder)
rec_body = mkValLam non_static_args
( Let (NonRec fake_binder nonrec_rhs)
{-in-} (dropArgs rhs))
in
returnSAT (
origLams (Let (Rec [(binder',rec_body)]) {-in-} local_body)
)
where
origLams = origLams' rhs
where
origLams' (Lam v e) e' = Lam v (origLams' e e')
origLams' (CoTyLam ty e) e' = CoTyLam ty (origLams' e e')
origLams' _ e' = e'
new_ty tyargs args
= substTy (mk_inst_tyenv tyargs tv_tmpl)
(mkSigmaTy tv_tmpl' dict_tys' tau_ty')
where
-- get type info for the local function:
(tv_tmpl, dict_tys, tau_ty) = (splitSigmaTy . idType) binder
(reg_arg_tys, res_type) = splitFunTys tau_ty
-- now, we drop the ones that are
-- static, that is, the ones we will not pass to the local function
tv_tmpl' = dropStatics tyargs tv_tmpl
(args1, args2) = splitAtList dict_tys args
dict_tys' = dropStatics args1 dict_tys
reg_arg_tys' = dropStatics args2 reg_arg_tys
tau_ty' = glueTyArgs reg_arg_tys' res_type
mk_inst_tyenv [] _ = emptyVarEnv
mk_inst_tyenv (Static s:args) (t:ts) = extendVarEnv (mk_inst_tyenv args ts) t s
mk_inst_tyenv (_:args) (_:ts) = mk_inst_tyenv args ts
dropStatics [] t = t
dropStatics (Static _:args) (t:ts) = dropStatics args ts
dropStatics (_:args) (t:ts) = t:dropStatics args ts
isStatic :: Arg a -> Bool
isStatic NotStatic = False
isStatic _ = True
-}
\end{code}
......@@ -155,7 +155,7 @@ doCorePass CoreCSE = {-# SCC "CommonSubExpr" #-} trBinds cseProgram
doCorePass CoreLiberateCase = {-# SCC "LiberateCase" #-} liberateCase
doCorePass CoreDoFloatInwards = {-# SCC "FloatInwards" #-} trBinds floatInwards
doCorePass (CoreDoFloatOutwards f) = {-# SCC "FloatOutwards" #-} trBindsU (floatOutwards f)
doCorePass CoreDoStaticArgs = {-# SCC "StaticArgs" #-} trBinds doStaticArgs
doCorePass CoreDoStaticArgs = {-# SCC "StaticArgs" #-} trBindsU doStaticArgs
doCorePass CoreDoStrictness = {-# SCC "Stranal" #-} trBinds dmdAnalPgm
doCorePass CoreDoWorkerWrapper = {-# SCC "WorkWrap" #-} trBindsU wwTopBinds
doCorePass CoreDoSpecialising = {-# SCC "Specialise" #-} trBindsU specProgram
......
......@@ -1340,6 +1340,13 @@
<entry>-fno-liberate-case</entry>
</row>
<row>
<entry><option>-fstatic-argument-transformation</option></entry>
<entry>Turn on the static argument transformation. Implied by <option>-O2</option>.</entry>
<entry>dynamic</entry>
<entry>-fno-static-argument-transformation</entry>
</row>
<row>
<entry><option>-fliberate-case-threshold</option>=<replaceable>n</replaceable></entry>
<entry>Set the size threshold for the liberate-case transformation to <replaceable>n</replaceable> (default: 200)</entry>
......
......@@ -1522,15 +1522,31 @@ f "2" = 2
<varlistentry>
<term>
<option>-fno-state-hack</option>
<indexterm><primary><option>-fno-state-hack</option></primary></indexterm>
<option>-fspec-constr</option>
<indexterm><primary><option>-fspec-constr</option></primary></indexterm>
</term>
<listitem>
<para>Turn off the "state hack" whereby any lambda with a
<literal>State#</literal> token as argument is considered to be
single-entry, hence it is considered OK to inline things inside
it. This can improve performance of IO and ST monad code, but it
runs the risk of reducing sharing.</para>
<para>Turn on call-pattern specialisation.</para>
</listitem>
</varlistentry>
<varlistentry>
<term>
<option>-fliberate-case</option>
<indexterm><primary><option>-fliberate-case</option></primary></indexterm>
</term>
<listitem>
<para>Turn on the liberate-case transformation.</para>
</listitem>
</varlistentry>
<varlistentry>
<term>
<option>-fstatic-argument-transformation</option>
<indexterm><primary><option>-fstatic-argument-transformation</option></primary></indexterm>
</term>
<listitem>
<para>Turn on the static argument transformation.</para>
</listitem>
</varlistentry>
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment