96/03: We aren't using the static-argument transformation right now.
\begin{code}
-#include "HsVersions.h"
-
module SATMonad where
-import Ubiq{-uitous-}
+#include "HsVersions.h"
+
import Util ( panic )
junk_from_SATMonad = panic "SATMonad.junk"
) where
import Type ( mkTyVarTy, mkSigmaTy, TyVarTemplate,
- splitSigmaTy, splitTyArgs,
- glueTyArgs, instantiateTy, TauType(..),
- Class, ThetaType(..), SigmaType(..),
+ splitSigmaTy, splitFunTys,
+ glueTyArgs, instantiateTy, TauType,
+ Class, ThetaType, SigmaType,
InstTyEnv(..)
)
import Id ( mkSysLocal, idType )
-import Maybes ( Maybe(..) )
-import SrcLoc ( SrcLoc, mkUnknownSrcLoc )
+import SrcLoc ( SrcLoc, noSrcLoc )
import UniqSupply
import Util
newSATName :: Id -> Type -> SatM Id
newSATName id ty us env
= case (getUnique us) of { unique ->
- (mkSysLocal new_str unique ty mkUnknownSrcLoc, env) }
+ (mkSysLocal new_str unique ty noSrcLoc, env) }
where
- new_str = getOccurrenceName id _APPEND_ SLIT("_sat")
+ new_str = getOccName id _APPEND_ SLIT("_sat")
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 ])
-- 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)
+ (getOccName binder _APPEND_ SLIT("_fsat"))
+ (uniqueOf binder)
(idType binder)
- mkUnknownSrcLoc
+ noSrcLoc
rec_body = mkValLam non_static_args
( Let (NonRec fake_binder nonrec_rhs)
{-in-} (dropArgs rhs))
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
reg_arg_tys' = dropStatics (drop l args) 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 [] _ = emptyTyVarEnv
+ mk_inst_tyenv (Static s:args) (t:ts) = addToTyVarEnv (mk_inst_tyenv args ts) t s
mk_inst_tyenv (_:args) (_:ts) = mk_inst_tyenv args ts
dropStatics [] t = t