1 files changed, 263 insertions, 0 deletions
diff --git a/compiler/simplCore/SATMonad.lhs b/compiler/simplCore/SATMonad.lhs
new file mode 100644
index 0000000000..9786f448af
--- /dev/null
+++ b/compiler/simplCore/SATMonad.lhs
@@ -0,0 +1,263 @@
+%
+% (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}
+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}