Add mapOccEnv

[ghc-hetmet.git] / ghc / compiler / simplCore / SATMonad.lhs

diff --git a/ghc/compiler/simplCore/SATMonad.lhs b/ghc/compiler/simplCore/SATMonad.lhs
index 0c33a91..9786f44 100644 (file)
--- a/ghc/compiler/simplCore/SATMonad.lhs
+++ b/ghc/compiler/simplCore/SATMonad.lhs
@@ -14,7 +14,7 @@ module SATMonad where
 
 #include "HsVersions.h"
 
-import Util            ( panic )
+import Panic           ( panic )
 
 junk_from_SATMonad = panic "SATMonad.junk"
 
@@ -35,7 +35,7 @@ import Type           ( mkTyVarTy, mkSigmaTy,
                          InstTyEnv(..)
                        )
 import MkId            ( mkSysLocal )
-import Id              ( idType, idName, mkUserId )
+import Id              ( idType, idName, mkLocalId )
 import UniqSupply
 import Util
 
@@ -139,7 +139,7 @@ newSATName id ty us env
     let
        new_name = mkCompoundName SLIT("$sat") unique (idName id)
     in
-    (mkUserId new_name ty, env) }
+    (mkLocalId new_name ty, env) }
 
 getArgLists :: CoreExpr -> ([Arg Type],[Arg Id])
 getArgLists expr
@@ -179,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))) (
@@ -205,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,
@@ -213,7 +213,7 @@ 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
+           fake_binder = mkSysLocal SLIT("sat")
                            (getUnique binder)
                            (idType binder)
            rec_body = mkValLam non_static_args
@@ -240,10 +240,12 @@ saTransform binder rhs
 
        -- 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 []                    _ = emptyVarEnv