import CoreUtils ( coreExprType )
import SimplUtils ( etaCoreExpr, typeOkForCase )
import CoreUnfold
-import Literal ( Literal(..), literalType, mkMachInt )
+import Literal ( Literal(..), literalType, mkMachInt, mkMachInt_safe )
import ErrUtils ( ghcExit, dumpIfSet, doIfSet )
import FiniteMap ( FiniteMap, emptyFM )
import FloatIn ( floatInwards )
import FloatOut ( floatOutwards )
import FoldrBuildWW ( mkFoldrBuildWW )
import MkId ( mkSysLocal, mkUserId )
-import Id ( setIdVisibility,
+import Id ( setIdVisibility, getIdSpecialisation, setIdSpecialisation,
getIdDemandInfo, idType,
nullIdEnv, addOneToIdEnv, delOneFromIdEnv,
lookupIdEnv, IdEnv,
import SimplMonad ( zeroSimplCount, showSimplCount, SimplCount )
import SimplPgm ( simplifyPgm )
import Specialise
+import SpecEnv ( substSpecEnv, isEmptySpecEnv )
import StrictAnal ( saWwTopBinds )
-import TyVar ( TyVar, nameTyVar )
+import TyVar ( TyVar, nameTyVar, emptyTyVarEnv )
import Unique ( Unique{-instance Eq-}, Uniquable(..),
integerTyConKey, ratioTyConKey,
mkUnique, incrUnique,
import UniqSupply ( UniqSupply, mkSplitUniqSupply,
splitUniqSupply, getUnique
)
-import UniqFM ( UniqFM, lookupUFM, addToUFM )
+import UniqFM ( UniqFM, lookupUFM, addToUFM, delFromUFM )
import Util ( mapAccumL )
import SrcLoc ( noSrcLoc )
import Constants ( tARGET_MIN_INT, tARGET_MAX_INT )
\end{code}
\begin{code}
-tidyPrimOp (CCallOp fn casm gc tys ty)
+tidyPrimOp (CCallOp fn casm gc cconv tys ty)
= mapTM tidyTy tys `thenTM` \ tys' ->
tidyTy ty `thenTM` \ ty' ->
- returnTM (CCallOp fn casm gc tys' ty')
+ returnTM (CCallOp fn casm gc cconv tys' ty')
tidyPrimOp other_prim_op = returnTM other_prim_op
\end{code}
then -- Must cater for NULs in literal string
mkGenApp (Var unpackCString2Id)
[LitArg (MachStr s),
- LitArg (mkMachInt (toInteger (_LENGTH_ s)))]
+ LitArg (mkMachInt_safe (toInteger (_LENGTH_ s)))]
else -- No NULs in the string
App (Var unpackCStringId) (LitArg (MachStr s))
| i > tARGET_MIN_INT && -- Small enough, so start from an Int
i < tARGET_MAX_INT
- = Prim Int2IntegerOp [LitArg (mkMachInt i)]
+ = Prim Int2IntegerOp [LitArg (mkMachInt (fromInteger i))]
| otherwise -- Big, so start from a string
= Prim Addr2IntegerOp [LitArg (MachStr (_PK_ (show i)))]
\begin{code}
-- Need to extend the environment when we munge a binder, so that occurrences
--- of the binder will print the correct way (i.e. as a global not a local)
+-- of the binder will print the correct way (e.g. as a global not a local)
mungeTopBinder :: Id -> (Id -> TopTidyM a) -> TopTidyM a
mungeTopBinder id thing_inside mod env us
= -- Give it a new print-name unless it's an exported thing
-- setNameVisibility also does the local/global thing
let
- (id', us') | isExported id = (id, us)
+ (id1, us') | isExported id = (id, us)
| otherwise
= (setIdVisibility (Just mod) us id,
incrUnique us)
- new_env = addToUFM env id (ValBinder id')
+
+ -- Tidy the Id's SpecEnv
+ spec_env = getIdSpecialisation id
+ id2 | isEmptySpecEnv spec_env = id1
+ | otherwise = setIdSpecialisation id1 (tidySpecEnv env spec_env)
+
+ new_env = addToUFM env id (ValBinder id2)
in
- thing_inside id' mod new_env us'
+ thing_inside id2 mod new_env us'
+
+tidySpecEnv env spec_env
+ = substSpecEnv
+ emptyTyVarEnv -- Top level only
+ (tidy_spec_rhs env)
+ spec_env
+ where
+ -- tidy_spec_rhs is another horrid little hacked-up function for
+ -- the RHS of specialisation templates.
+ -- It assumes there is no type substitution.
+ --
+ -- See also SimplVar.substSpecEnvRhs Urgh
+ tidy_spec_rhs env (Var v) = case lookupUFM env v of
+ Just (ValBinder v') -> Var v'
+ Nothing -> Var v
+ tidy_spec_rhs env (App f (VarArg v)) = App (tidy_spec_rhs env f) (case lookupUFM env v of
+ Just (ValBinder v') -> VarArg v'
+ Nothing -> VarArg v)
+ tidy_spec_rhs env (App f arg) = App (tidy_spec_rhs env f) arg
+ tidy_spec_rhs env (Lam b e) = Lam b (tidy_spec_rhs env' e)
+ where
+ env' = case b of
+ ValBinder id -> delFromUFM env id
+ TyBinder _ -> env
mungeTopBinders [] k = k []
mungeTopBinders (b:bs) k = mungeTopBinder b $ \ b' ->