GitLab

2655e4f2

by Simon Peyton Jones at 2026-03-12T17:43:18+00:00

Immprove lambda handling in Prep

All Lam in `body` rather than just `rhs`; indeed
collapse the two.

Then CoreToStg creates the lambda if needed

@@ -794,6 +794,7 @@ classOpSize opts cls top_args (dict_arg:other_val_args)
      arg_discount (Var dict) | dict `elem` top_args = unitBag (dict, dict_discount)
      arg_discount _                                 = emptyBag
 +-- TODO: document this change!
      dict_discount
        | null other_val_args = unfoldingDictDiscount opts
        | otherwise           = unfoldingDictDiscount opts + unfoldingFunAppDiscount opts

@@ -420,16 +420,22 @@ coreToStgExpr expr@(App _ _)
        res_ty                  = exprType expr
        (app_head, args, ticks) = myCollectArgs expr res_ty
 -coreToStgExpr expr@(Lam _ _)
 -  = let
 -        (args, body) = myCollectBinders expr
 -    in
 -    case filterStgBinders args of
+-
 -      [] -> coreToStgExpr body
+-
 -      _ -> pprPanic "coretoStgExpr" $
 -        text "Unexpected value lambda:" $$ ppr expr
 +coreToStgExpr expr@(Lam {})
 +  | null val_bndrs
 +  = coreToStgExpr body
 +  | otherwise
 +  = do { body' <- extendVarEnvCts [ (a, LambdaBound) | a <- val_bndrs ] $
 +                  coreToStgExpr body
 +       ; let body_ty = exprType body
 +             fun_ty  = mkLamTypes bndrs body_ty
 +             rhs = StgRhsClosure noExtFieldSilent currentCCS
 +                                 ReEntrant val_bndrs body' body_ty
 +             tmp_fun = mkTemplateLocal 0 fun_ty
 +       ; return (StgLet noExtFieldSilent (StgNonRec tmp_fun rhs) $
 +                 StgApp tmp_fun []) }
 +  where
 +    (bndrs, body) = myCollectBinders expr
 +    val_bndrs = filterStgBinders bndrs
  coreToStgExpr (Tick tick expr)
    = do

@@ -925,6 +925,7 @@ cpeBody env expr
  rhsToBody :: CorePrepEnv -> CpeRhs -> UniqSM (Floats, CpeBody)
  -- Remove top level lambdas by let-binding
 +{-
  rhsToBody env (Tick t expr)
    | tickishScoped t == NoScope  -- only float out of non-scoped annotations
    = do { (floats, expr') <- rhsToBody env expr
@@ -946,6 +947,7 @@ rhsToBody env expr@(Lam {})   -- See Note [No eta reduction needed in rhsToBody]
         ; return (unitFloat float, Var fn) }
    where
      (bndrs,_) = collectBinders expr
 +-}
  rhsToBody _env expr = return (emptyFloats, expr)

@@ -10,7 +10,7 @@ f :: forall a b. C a b => a -> b
   Str=<1P(A,1C(1,C(1,L)))><L>,
   Unf=Unf{Src=<vanilla>, TopLvl=True,
           Value=True, ConLike=True, WorkFree=True, Expandable=True,
 -         Guidance=IF_ARGS [30 0] 40 0}]
 +         Guidance=IF_ARGS [90 0] 40 0}]
  f = \ (@a) (@b) ($dC :: C a b) (x :: a) -> op @a @b $dC x x