%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
%************************************************************************
%* *
96/03: We aren't using the static-argument transformation right now.
\begin{code}
-#include "HsVersions.h"
-
module SATMonad where
-IMP_Ubiq(){-uitous-}
-import Util ( panic )
+#include "HsVersions.h"
+
+import Panic ( panic )
junk_from_SATMonad = panic "SATMonad.junk"
SATEnv(..), isStatic, dropStatics
) where
-import Type ( mkTyVarTy, mkSigmaTy, TyVarTemplate,
- splitSigmaTy, splitFunTy,
- glueTyArgs, instantiateTy, SYN_IE(TauType),
- Class, SYN_IE(ThetaType), SYN_IE(SigmaType),
+import Type ( mkTyVarTy, mkSigmaTy,
+ splitSigmaTy, splitFunTys,
+ glueTyArgs, substTy,
InstTyEnv(..)
)
-import Id ( mkSysLocal, idType )
-import SrcLoc ( SrcLoc, mkUnknownSrcLoc )
+import MkId ( mkSysLocal )
+import Id ( idType, idName, mkLocalId )
import UniqSupply
import Util
deriving Eq
delOneFromSAEnv v us env
- = ((), delOneFromIdEnv env v)
+ = ((), delVarEnv env v)
updSAEnv :: Maybe (Id,SATInfo) -> SatM ()
updSAEnv Nothing
insSAEnv :: Id -> SATInfo -> SatM ()
insSAEnv b info us env
- = ((), addOneToIdEnv env b info)
+ = ((), extendVarEnv env b info)
\end{code}
%************************************************************************
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) ->
k s2 menv }}
emptyEnvSAT :: SatM ()
-emptyEnvSAT us _ = ((), nullIdEnv)
+emptyEnvSAT us _ = ((), emptyVarEnv)
returnSAT v us env = (v, env)
\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 = panic "SATMonad.newSATName (ToDo)" -- getOccName 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 ])
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))) (
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,
-- 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
- (getOccName binder _APPEND_ SLIT("_fsat"))
- (uniqueOf 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))
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) = splitFunTy 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