Make record selectors into ordinary functions

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

diff --git a/compiler/simplCore/SetLevels.lhs b/compiler/simplCore/SetLevels.lhs
index 2c84589..6f48272 100644 (file)
--- a/compiler/simplCore/SetLevels.lhs
+++ b/compiler/simplCore/SetLevels.lhs
@@ -376,6 +376,13 @@ lvlMFE ::  Bool                    -- True <=> strict context [body of case or let]
 lvlMFE _ _ _ (_, AnnType ty)
   = return (Type ty)
 
+-- No point in floating out an expression wrapped in a coercion;
+-- If we do we'll transform  lvl = e |> co 
+--                      to  lvl' = e; lvl = lvl' |> co
+-- and then inline lvl.  Better just to float out the payload.
+lvlMFE strict_ctxt ctxt_lvl env (_, AnnCast e co)
+  = do { expr' <- lvlMFE strict_ctxt ctxt_lvl env e
+       ; return (Cast expr' co) }
 
 lvlMFE strict_ctxt ctxt_lvl env ann_expr@(fvs, _)
   |  isUnLiftedType ty                 -- Can't let-bind it; see Note [Unlifted MFEs]
@@ -518,7 +525,7 @@ lvlBind top_lvl ctxt_lvl env (AnnRec pairs)
        new_rhss <- mapM (lvlExpr ctxt_lvl new_env) rhss
        return (Rec ([TB b dest_lvl | b <- new_bndrs] `zip` new_rhss), new_env)
 
-  | isSingleton pairs && count isIdVar abs_vars > 1
+  | isSingleton pairs && count isId abs_vars > 1
   = do -- Special case for self recursion where there are
        -- several variables carried around: build a local loop:        
        --      poly_f = \abs_vars. \lam_vars . letrec f = \lam_vars. rhs in f lam_vars
@@ -598,7 +605,7 @@ lvlLamBndrs lvl bndrs
        [] bndrs
   where
     go old_lvl bumped_major rev_lvld_bndrs (bndr:bndrs)
-       | isIdVar bndr &&               -- Go to the next major level if this is a value binder,
+       | isId bndr &&                  -- Go to the next major level if this is a value binder,
          not bumped_major &&           -- and we havn't already gone to the next level (one jump per group)
          not (isOneShotLambda bndr)    -- and it isn't a one-shot lambda
        = go new_lvl True (TB bndr new_lvl : rev_lvld_bndrs) bndrs
@@ -640,7 +647,7 @@ isFunction :: CoreExprWithFVs -> Bool
 -- We may only want to do this if there are sufficiently few free 
 -- variables.  We certainly only want to do it for values, and not for
 -- constructors.  So the simple thing is just to look for lambdas
-isFunction (_, AnnLam b e) | isIdVar b = True
+isFunction (_, AnnLam b e) | isId b    = True
                            | otherwise = isFunction e
 isFunction (_, AnnNote _ e)            = isFunction e
 isFunction _                           = False
@@ -684,10 +691,10 @@ initialEnv :: FloatOutSwitches -> LevelEnv
 initialEnv float_lams = (float_lams, emptyVarEnv, emptySubst, emptyVarEnv)
 
 floatLams :: LevelEnv -> Bool
-floatLams (FloatOutSw float_lams _, _, _, _) = float_lams
+floatLams (fos, _, _, _) = floatOutLambdas fos
 
 floatConsts :: LevelEnv -> Bool
-floatConsts (FloatOutSw _ float_consts, _, _, _) = float_consts
+floatConsts (fos, _, _, _) = floatOutConstants fos
 
 extendLvlEnv :: LevelEnv -> [TaggedBndr Level] -> LevelEnv
 -- Used when *not* cloning
@@ -758,10 +765,10 @@ maxIdLevel (_, lvl_env,_,id_env) var_set
                                                Nothing            -> [in_var])
 
     max_out out_var lvl 
-       | isIdVar out_var = case lookupVarEnv lvl_env out_var of
+       | isId out_var = case lookupVarEnv lvl_env out_var of
                                Just lvl' -> maxLvl lvl' lvl
                                Nothing   -> lvl 
-       | otherwise       = lvl -- Ignore tyvars in *maxIdLevel*
+       | otherwise    = lvl    -- Ignore tyvars in *maxIdLevel*
 
 lookupVar :: LevelEnv -> Id -> LevelledExpr
 lookupVar (_, _, _, id_env) v = case lookupVarEnv id_env v of
@@ -801,7 +808,7 @@ abstractVars dest_lvl (_, lvl_env, _, id_env) fvs
 
        -- We are going to lambda-abstract, so nuke any IdInfo,
        -- and add the tyvars of the Id (if necessary)
-    zap v | isIdVar v = WARN( workerExists (idWorkerInfo v) ||
+    zap v | isId v = WARN( workerExists (idWorkerInfo v) ||
                           not (isEmptySpecInfo (idSpecialisation v)),
                           text "absVarsOf: discarding info on" <+> ppr v )
                     setIdInfo v vanillaIdInfo
@@ -816,7 +823,7 @@ absVarsOf :: IdEnv ([Var], LevelledExpr) -> Var -> [Var]
        --      we must look in x's type
        -- And similarly if x is a coercion variable.
 absVarsOf id_env v 
-  | isIdVar v = [av2 | av1 <- lookup_avs v
+  | isId v    = [av2 | av1 <- lookup_avs v
                     , av2 <- add_tyvars av1]
   | isCoVar v = add_tyvars v
   | otherwise = [v]
@@ -864,7 +871,7 @@ cloneVar :: TopLevelFlag -> LevelEnv -> Id -> Level -> Level -> LvlM (LevelEnv,
 cloneVar TopLevel env v _ _
   = return (env, v)    -- Don't clone top level things
 cloneVar NotTopLevel env@(_,_,subst,_) v ctxt_lvl dest_lvl
-  = ASSERT( isIdVar v ) do
+  = ASSERT( isId v ) do
     us <- getUniqueSupplyM
     let
       (subst', v1) = cloneIdBndr subst us v
@@ -876,7 +883,7 @@ cloneRecVars :: TopLevelFlag -> LevelEnv -> [Id] -> Level -> Level -> LvlM (Leve
 cloneRecVars TopLevel env vs _ _
   = return (env, vs)   -- Don't clone top level things
 cloneRecVars NotTopLevel env@(_,_,subst,_) vs ctxt_lvl dest_lvl
-  = ASSERT( all isIdVar vs ) do
+  = ASSERT( all isId vs ) do
     us <- getUniqueSupplyM
     let
       (subst', vs1) = cloneRecIdBndrs subst us vs