import Name ( getOccName, isExternalName, nameOccName )
import OccName ( occNameString, occNameFS )
import BasicTypes ( Arity )
-import StaticFlags ( opt_RuntimeTypes )
import Module
import Outputable
import MonadUtils
+import FastString
+import Util
\end{code}
%************************************************************************
bind = StgNonRec id stg_rhs
in
- ASSERT2(manifestArity rhs == stgRhsArity stg_rhs, ppr id $$ (ptext SLIT("rhs:")) <+> ppr rhs $$ (ptext SLIT("stg_rhs:"))<+> ppr stg_rhs $$ (ptext SLIT("Manifest:")) <+> (ppr $ manifestArity rhs) $$ (ptext SLIT("STG:")) <+>(ppr $ stgRhsArity stg_rhs) )
- ASSERT2(consistentCafInfo id bind, ppr id)
+ ASSERT2(manifestArity rhs == stgRhsArity stg_rhs, ppr id $$ (ptext (sLit "rhs:")) <+> ppr rhs $$ (ptext (sLit "stg_rhs:"))<+> ppr stg_rhs $$ (ptext (sLit "Manifest:")) <+> (ppr $ manifestArity rhs) $$ (ptext (sLit "STG:")) <+>(ppr $ stgRhsArity stg_rhs) )
+ ASSERT2(consistentCafInfo id bind, ppr id $$ ppr rhs $$ ppr bind)
-- WARN(not (consistent caf_info bind), ppr id <+> ppr cafs <+> ppCafInfo caf_info)
(env', fvs' `unionFVInfo` body_fvs, bind)
-- CafInfo will be exact in all cases except when CorePrep has
-- floated out a binding, in which case it will be approximate.
consistentCafInfo id bind
- | occNameFS (nameOccName (idName id)) == FSLIT("sat")
+ | occNameFS (nameOccName (idName id)) == fsLit "sat"
= safe
| otherwise
= WARN (not exact, ppr id) safe
let
n_val_args = valArgCount args
not_letrec_bound = not (isLetBound how_bound)
- fun_fvs
- = let fvs = singletonFVInfo f how_bound fun_occ in
+ fun_fvs = singletonFVInfo f how_bound fun_occ
-- e.g. (f :: a -> int) (x :: a)
-- Here the free variables are "f", "x" AND the type variable "a"
-- coreToStgArgs will deal with the arguments recursively
- if opt_RuntimeTypes then
- fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType (idType f))
- else fvs
-- Mostly, the arity info of a function is in the fn's IdInfo
-- But new bindings introduced by CoreSat may not have no
coreToStgArgs (Type ty : args) = do -- Type argument
(args', fvs) <- coreToStgArgs args
- if opt_RuntimeTypes then
- return (StgTypeArg ty : args', fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType ty))
- else
- return (args', fvs)
+ return (args', fvs)
coreToStgArgs (arg : args) = do -- Non-type argument
(stg_args, args_fvs) <- coreToStgArgs args
-- we complain.
-- We also want to check if a pointer is cast to a non-ptr etc
- WARN( bad_args, ptext SLIT("Dangerous-looking argument. Probable cause: bad unsafeCoerce#") $$ ppr arg )
+ WARN( bad_args, ptext (sLit "Dangerous-looking argument. Probable cause: bad unsafeCoerce#") $$ ppr arg )
return (stg_arg : stg_args, fvs)
no_binder_escapes = isEmptyVarSet (set_of_binders `intersectVarSet` all_escs)
-#ifdef DEBUG
-- Debugging code as requested by Andrew Kennedy
checked_no_binder_escapes
- | not no_binder_escapes && any is_join_var binders
+ | debugIsOn && not no_binder_escapes && any is_join_var binders
= pprTrace "Interesting! A join var that isn't let-no-escaped" (ppr binders)
False
| otherwise = no_binder_escapes
-#else
- checked_no_binder_escapes = no_binder_escapes
-#endif
-- Mustn't depend on the passed-in let_no_escape flag, since
-- no_binder_escapes is used by the caller to derive the flag!
singletonFVInfo id how_bound info = unitVarEnv id (id, how_bound, info)
tyvarFVInfo :: TyVarSet -> FreeVarsInfo
-tyvarFVInfo tvs = foldVarSet add emptyFVInfo tvs
- where
- add tv fvs = extendVarEnv fvs tv (tv, LambdaBound, noBinderInfo)
- -- Type variables must be lambda-bound
+tyvarFVInfo tvs = emptyFVInfo -- Type variables are not recorded
+-- Old code recorded free tyvars for when we supported runtime types:
+-- foldVarSet add emptyFVInfo tvs
+-- where
+-- add tv fvs = extendVarEnv fvs tv (tv, LambdaBound, noBinderInfo)
+-- -- Type variables must be lambda-bound
unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo
unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2
minusFVBinders vs fv = foldr minusFVBinder fv vs
minusFVBinder :: Id -> FreeVarsInfo -> FreeVarsInfo
-minusFVBinder v fv | isId v && opt_RuntimeTypes
- = (fv `delVarEnv` v) `unionFVInfo`
- tyvarFVInfo (tyVarsOfType (idType v))
- | otherwise = fv `delVarEnv` v
+minusFVBinder v fv = fv `delVarEnv` v
-- When removing a binder, remember to add its type variables
-- c.f. CoreFVs.delBinderFV
Just (_,_,info) -> info
allFreeIds :: FreeVarsInfo -> [(Id,HowBound)] -- Both top level and non-top-level Ids
-allFreeIds fvs = [(id,how_bound) | (id,how_bound,_) <- varEnvElts fvs, isId id]
+allFreeIds fvs = ASSERT( all (isId . fst) ids ) ids
+ where
+ ids = [(id,how_bound) | (id,how_bound,_) <- varEnvElts fvs]
-- Non-top-level things only, both type variables and ids
--- (type variables only if opt_RuntimeTypes)
getFVs :: FreeVarsInfo -> [Var]
getFVs fvs = [id | (id, how_bound, _) <- varEnvElts fvs,
not (topLevelBound how_bound) ]
Misc.
\begin{code}
filterStgBinders :: [Var] -> [Var]
-filterStgBinders bndrs
- | opt_RuntimeTypes = bndrs
- | otherwise = filter isId bndrs
+filterStgBinders bndrs = filter isId bndrs
\end{code}