X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSAT.lhs;h=c79a174b4e0152931d3fe8a273f665fb512cf7df;hb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;hp=6f484cfddfc742f26db8d7ea471b382da857cf11;hpb=e7d21ee4f8ac907665a7e170c71d59e13a01da09;p=ghc-hetmet.git

diff --git a/ghc/compiler/simplCore/SAT.lhs b/ghc/compiler/simplCore/SAT.lhs
index 6f484cf..c79a174 100644
--- a/ghc/compiler/simplCore/SAT.lhs
+++ b/ghc/compiler/simplCore/SAT.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
 %************************************************************************
 %*									*
@@ -7,6 +7,8 @@
 %*									*
 %************************************************************************
 
+96/03: We aren't using the static-argument transformation right now.
+
 May be seen as removing invariants from loops:
 Arguments of recursive functions that do not change in recursive
 calls are removed from the recursion, which is done locally
@@ -33,51 +35,54 @@ they will eventually be removed in later stages of the compiler,
 therefore there is no penalty in keeping them.
 
 Experimental Evidence: Heap: +/- 7%
-                       Instrs: Always improves for 2 or more Static Args.
+		       Instrs: Always improves for 2 or more Static Args.
 
 \begin{code}
+module SAT ( doStaticArgs ) where
+
 #include "HsVersions.h"
 
-module SAT (
-	doStaticArgs,
+import Util		( panic )
+
+doStaticArgs = panic "SAT.doStaticArgs (ToDo)"
 
-	-- and to make the interface self-sufficient...
-	PlainCoreProgram(..), CoreExpr, CoreBinding, Id
-    ) where
+{- LATER: to end of file:
 
-import IdEnv
-import Maybes		( Maybe(..) )
-import PlainCore
 import SATMonad
-import SplitUniq
 import Util
 \end{code}
 
 \begin{code}
-doStaticArgs :: PlainCoreProgram -> SplitUniqSupply -> PlainCoreProgram
+doStaticArgs :: [CoreBind] -> UniqSupply -> [CoreBind]
 
 doStaticArgs binds
-  = initSAT (mapSAT sat_bind binds)
+  = do {
+	beginPass "Static argument";
+	let { binds' = initSAT (mapSAT sat_bind binds) };
+	endPass "Static argument" 
+		False		-- No specific flag for dumping SAT
+		binds'
+    }
   where
-    sat_bind (CoNonRec binder expr)
+    sat_bind (NonRec binder expr)
       = emptyEnvSAT  `thenSAT_`
 	satExpr expr `thenSAT` (\ expr' ->
-	returnSAT (CoNonRec binder expr') )
-    sat_bind (CoRec [(binder,rhs)])
+	returnSAT (NonRec binder expr') )
+    sat_bind (Rec [(binder,rhs)])
       = emptyEnvSAT			  `thenSAT_`
 	insSAEnv binder (getArgLists rhs) `thenSAT_`
 	satExpr rhs			  `thenSAT` (\ rhs' ->
 	saTransform binder rhs')
-    sat_bind (CoRec pairs)
+    sat_bind (Rec pairs)
       = emptyEnvSAT		`thenSAT_`
 	mapSAT satExpr rhss	`thenSAT` \ rhss' ->
-	returnSAT (CoRec (binders `zip` rhss'))
+	returnSAT (Rec (zipEqual "doStaticArgs" binders rhss'))
       where
 	(binders, rhss)	= unzip pairs
 \end{code}
 
 \begin{code}
-satAtom (CoVarAtom v)
+satAtom (VarArg v)
   = updSAEnv (Just (v,([],[]))) `thenSAT_`
     returnSAT ()
 
@@ -85,102 +90,100 @@ satAtom _ = returnSAT ()
 \end{code}
 
 \begin{code}
-satExpr :: PlainCoreExpr -> SatM PlainCoreExpr
+satExpr :: CoreExpr -> SatM CoreExpr
 
-satExpr var@(CoVar v)
+satExpr var@(Var v)
   = updSAEnv (Just (v,([],[]))) `thenSAT_`
     returnSAT var
 
-satExpr lit@(CoLit _) = returnSAT lit
+satExpr lit@(Lit _) = returnSAT lit
 
-satExpr e@(CoCon con types args)
+satExpr e@(Con con types args)
   = mapSAT satAtom args	    `thenSAT_`
     returnSAT e
 
-satExpr e@(CoPrim prim ty args)
+satExpr e@(Prim prim ty args)
   = mapSAT satAtom args	    `thenSAT_`
     returnSAT e
 
-satExpr (CoLam binders body)
+satExpr (Lam binders body)
   = satExpr body		`thenSAT` \ body' ->
-    returnSAT (CoLam binders body')
+    returnSAT (Lam binders body')
 
 satExpr (CoTyLam tyvar body)
   = satExpr body	   `thenSAT` (\ body' ->
     returnSAT (CoTyLam tyvar body') )
 
-satExpr app@(CoApp _ _)
+satExpr app@(App _ _)
   = getAppArgs app
 
 satExpr app@(CoTyApp _ _)
   = getAppArgs app
 
-satExpr (CoCase expr alts)
+satExpr (Case expr alts)
   = satExpr expr	`thenSAT` \ expr' ->
     sat_alts alts	`thenSAT` \ alts' ->
-    returnSAT (CoCase expr' alts')
+    returnSAT (Case expr' alts')
   where
-    sat_alts (CoAlgAlts alts deflt)
+    sat_alts (AlgAlts alts deflt)
       = mapSAT satAlgAlt alts	    `thenSAT` \ alts' ->
 	sat_default deflt	    `thenSAT` \ deflt' ->
-	returnSAT (CoAlgAlts alts' deflt')
+	returnSAT (AlgAlts alts' deflt')
       where
 	satAlgAlt (con, params, rhs)
 	  = satExpr rhs		 `thenSAT` \ rhs' ->
 	    returnSAT (con, params, rhs')
 
-    sat_alts (CoPrimAlts alts deflt)
+    sat_alts (PrimAlts alts deflt)
       = mapSAT satPrimAlt alts	    `thenSAT` \ alts' ->
 	sat_default deflt	    `thenSAT` \ deflt' ->
-	returnSAT (CoPrimAlts alts' deflt')
+	returnSAT (PrimAlts alts' deflt')
       where
 	satPrimAlt (lit, rhs)
 	  = satExpr rhs `thenSAT` \ rhs' ->
 	    returnSAT (lit, rhs')
 
-    sat_default CoNoDefault
-      = returnSAT CoNoDefault
-    sat_default (CoBindDefault binder rhs)
+    sat_default NoDefault
+      = returnSAT NoDefault
+    sat_default (BindDefault binder rhs)
       = satExpr rhs		     `thenSAT` \ rhs' ->
-	returnSAT (CoBindDefault binder rhs')
+	returnSAT (BindDefault binder rhs')
 
-satExpr (CoLet (CoNonRec binder rhs) body)
+satExpr (Let (NonRec binder rhs) body)
   = satExpr body		`thenSAT` \ body' ->
     satExpr rhs			`thenSAT` \ rhs' ->
-    returnSAT (CoLet (CoNonRec binder rhs') body')
+    returnSAT (Let (NonRec binder rhs') body')
 
-satExpr (CoLet (CoRec [(binder,rhs)]) body)
+satExpr (Let (Rec [(binder,rhs)]) body)
   = satExpr body		      `thenSAT` \ body' ->
     insSAEnv binder (getArgLists rhs) `thenSAT_`
     satExpr rhs			      `thenSAT` \ rhs' ->
     saTransform binder rhs'	      `thenSAT` \ binding ->
-    returnSAT (CoLet binding body')
+    returnSAT (Let binding body')
 
-satExpr (CoLet (CoRec binds) body)
+satExpr (Let (Rec binds) body)
   = let
 	(binders, rhss) = unzip binds
     in
     satExpr body		    `thenSAT` \ body' ->
     mapSAT satExpr rhss		    `thenSAT` \ rhss' ->
-    returnSAT (CoLet (CoRec (binders `zip` rhss')) body')
+    returnSAT (Let (Rec (zipEqual "satExpr:Rec" binders rhss')) body')
 
-satExpr (CoSCC cc expr)
+satExpr (Note note expr)
   = satExpr expr		    `thenSAT` \ expr2 ->
-    returnSAT (CoSCC cc expr2)
-
--- ToDo: DPH stuff
+    returnSAT (Note note expr2)
 \end{code}
 
 \begin{code}
-getAppArgs :: PlainCoreExpr -> SatM PlainCoreExpr
+getAppArgs :: CoreExpr -> SatM CoreExpr
 
 getAppArgs app
   = get app		`thenSAT` \ (app',result) ->
     updSAEnv result	`thenSAT_`
     returnSAT app'
   where
-    get :: PlainCoreExpr
-	-> SatM (PlainCoreExpr, Maybe (Id, SATInfo))
+    get :: CoreExpr
+	-> SatM (CoreExpr, Maybe (Id, SATInfo))
 
     get (CoTyApp e ty)
       = get e		`thenSAT` \ (e',result) ->
@@ -191,25 +194,25 @@ getAppArgs app
 	    Just (v,(tv,lv)) -> Just (v,(tv++[Static ty],lv))
 	)
 
-    get (CoApp e a)
+    get (App e a)
       = get e		`thenSAT` \ (e', result) ->
 	satAtom a	`thenSAT_`
 	let si = case a of
-		   (CoVarAtom v) -> Static v
+		   (VarArg v) -> Static v
 		   _	         -> NotStatic
 	in
 	  returnSAT (
-	    CoApp e' a,
+	    App e' a,
 	    case result of
 		Just (v,(tv,lv)) -> Just (v,(tv,lv++[si]))
 		Nothing	    	 -> Nothing
 	  )
 
-    get var@(CoVar v)
+    get var@(Var v)
       = returnSAT (var, Just (v,([],[])))
 
     get e
       = satExpr e	`thenSAT` \ e2 ->
 	returnSAT (e2, Nothing)
+-}
 \end{code}
-