X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSATMonad.lhs;h=9786f448af825a805347be3262e29de47fe4a89b;hb=1f5e3b2472084434edf71a89c4764d1509e8e9b0;hp=b61deb36a4bded450222fa2af6e7bc140dcd7f8f;hpb=0596517a9b4b2b32e5d375a986351102ac4540fc;p=ghc-hetmet.git

diff --git a/ghc/compiler/simplCore/SATMonad.lhs b/ghc/compiler/simplCore/SATMonad.lhs
index b61deb3..9786f44 100644
--- a/ghc/compiler/simplCore/SATMonad.lhs
+++ b/ghc/compiler/simplCore/SATMonad.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
 %************************************************************************
 %*									*
@@ -10,12 +10,11 @@
 96/03: We aren't using the static-argument transformation right now.
 
 \begin{code}
-#include "HsVersions.h"
-
 module SATMonad where
 
-import Ubiq{-uitous-}
-import Util		( panic )
+#include "HsVersions.h"
+
+import Panic		( panic )
 
 junk_from_SATMonad = panic "SATMonad.junk"
 
@@ -30,15 +29,13 @@ module SATMonad (
 	SATEnv(..), isStatic, dropStatics
     ) where
 
-import Type		( mkTyVarTy, mkSigmaTy, TyVarTemplate,
-			  splitSigmaTy, splitTyArgs,
-			  glueTyArgs, instantiateTy, TauType(..),
-			  Class, ThetaType(..), SigmaType(..),
+import Type		( mkTyVarTy, mkSigmaTy,
+			  splitSigmaTy, splitFunTys,
+			  glueTyArgs, substTy,
 			  InstTyEnv(..)
 			)
-import Id		( mkSysLocal, idType )
-import Maybes		( Maybe(..) )
-import SrcLoc		( SrcLoc, mkUnknownSrcLoc )
+import MkId		( mkSysLocal )
+import Id		( idType, idName, mkLocalId )
 import UniqSupply
 import Util
 
@@ -60,7 +57,7 @@ data Arg a = Static a | NotStatic
     deriving Eq
 
 delOneFromSAEnv v us env
-  = ((), delOneFromIdEnv env v)
+  = ((), delVarEnv env v)
 
 updSAEnv :: Maybe (Id,SATInfo) -> SatM ()
 updSAEnv Nothing
@@ -84,7 +81,7 @@ notStatics n = nOfThem n NotStatic
 
 insSAEnv :: Id -> SATInfo -> SatM ()
 insSAEnv b info us env
-  = ((), addOneToIdEnv env b info)
+  = ((), extendVarEnv env b info)
 \end{code}
 
 %************************************************************************
@@ -101,7 +98,7 @@ type SatM result
 
 initSAT :: SatM a -> UniqSupply -> a
 
-initSAT f us = fst (f us nullIdEnv)
+initSAT f us = fst (f us emptyVarEnv)
 
 thenSAT m k us env
   = case splitUniqSupply us	of { (s1, s2) ->
@@ -114,7 +111,7 @@ thenSAT_ m k us env
     k s2 menv }}
 
 emptyEnvSAT :: SatM ()
-emptyEnvSAT us _ = ((), nullIdEnv)
+emptyEnvSAT us _ = ((), emptyVarEnv)
 
 returnSAT v us env = (v, env)
 
@@ -134,19 +131,20 @@ mapSAT f (x:xs)
 \begin{code}
 getSATInfo :: Id -> SatM (Maybe SATInfo)
 getSATInfo var us env
-  = (lookupIdEnv env var, env)
+  = (lookupVarEnv env var, env)
 
 newSATName :: Id -> Type -> SatM Id
 newSATName id ty us env
   = case (getUnique us) of { unique ->
-    (mkSysLocal new_str unique ty mkUnknownSrcLoc, env) }
-  where
-    new_str = getOccurrenceName id _APPEND_ SLIT("_sat")
+    let
+	new_name = mkCompoundName SLIT("$sat") unique (idName id)
+    in
+    (mkLocalId new_name ty, env) }
 
 getArgLists :: CoreExpr -> ([Arg Type],[Arg Id])
 getArgLists expr
   = let
-	(uvs, tvs, lambda_bounds, body) = collectBinders expr
+	(tvs, lambda_bounds, body) = collectBinders expr
     in
     ([ Static (mkTyVarTy tv) | tv <- tvs ],
      [ Static v		     | v <- lambda_bounds ])
@@ -181,7 +179,7 @@ saTransform binder rhs
     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) | length (filter isStatic args) > 1
+      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))) (
@@ -207,7 +205,7 @@ saTransform binder rhs
 	    nonrec_rhs = origLams local_body
 
 	    -- HACK! The following is a fake SysLocal binder with
-	    -- *the same* unique as binder.
+	    --  *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,
@@ -215,11 +213,9 @@ saTransform binder rhs
 	    -- 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
-			    (getOccurrenceName binder _APPEND_ SLIT("_fsat"))
-			    (getItsUnique binder)
+	    fake_binder = mkSysLocal SLIT("sat")
+			    (getUnique binder)
 			    (idType binder)
-			    mkUnknownSrcLoc
 	    rec_body = mkValLam non_static_args
 			       ( Let (NonRec fake_binder nonrec_rhs)
 				 {-in-} (dropArgs rhs))
@@ -235,23 +231,25 @@ saTransform binder rhs
 		   origLams' _		     e' = e'
 
     new_ty tyargs args
-      = instantiateTy (mk_inst_tyenv tyargs tv_tmpl)
+      = 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)	    = splitTyArgs tau_ty
+	(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
-	l   	     = length dict_tys
 	tv_tmpl'     = dropStatics tyargs tv_tmpl
-	dict_tys'    = dropStatics (take l args) dict_tys
-	reg_arg_tys' = dropStatics (drop l args) reg_arg_tys
+
+	(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 []		    _ = []
-	mk_inst_tyenv (Static s:args) (t:ts)  = (t,s) : mk_inst_tyenv args ts
+	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