Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 6eef855b by Sylvain Henry at 2026-03-13T15:08:18-04:00 Stg/Unarise: constant-folding during unarisation (#25650) When building an unboxed sum from a literal argument, mkUbxSum previously emitted a runtime cast via `case primop [lit] of var -> ...`. This wrapper prevented GHC from recognising the result as a static StgRhsCon, causing top-level closures to be allocated as thunks instead of being statically allocated. Fix: try to perform the numeric literal cast at compile time using mkLitNumberWrap (wrapping semantics). If successful, return the cast literal directly with an identity wrapper (no case expression). The runtime cast path is kept as fallback for non-literal arguments. Test: codeGen/should_compile/T25650 - - - - - 7 changed files: - compiler/GHC/Stg/Pipeline.hs - compiler/GHC/Stg/Unarise.hs - testsuite/tests/codeGen/should_compile/Makefile - + testsuite/tests/codeGen/should_compile/T25650.hs - + testsuite/tests/codeGen/should_compile/T25650.stdout-ws-32 - + testsuite/tests/codeGen/should_compile/T25650.stdout-ws-64 - testsuite/tests/codeGen/should_compile/all.T Changes: ===================================== compiler/GHC/Stg/Pipeline.hs ===================================== @@ -143,7 +143,7 @@ stg2stg logger extra_vars opts this_mod binds StgUnarise -> do us <- getUniqueSupplyM liftIO (stg_linter False "Pre-unarise" binds) - let binds' = {-# SCC "StgUnarise" #-} unarise us (stgPipeline_allowTopLevelConApp opts this_mod) binds + let binds' = {-# SCC "StgUnarise" #-} unarise (stgPlatform opts) us (stgPipeline_allowTopLevelConApp opts this_mod) binds liftIO (dump_when Opt_D_dump_stg_unarised "Unarised STG:" binds') liftIO (stg_linter True "Unarise" binds') return binds' ===================================== compiler/GHC/Stg/Unarise.hs ===================================== @@ -413,6 +413,7 @@ import Data.Maybe (mapMaybe) import qualified Data.IntMap as IM import GHC.Builtin.PrimOps import GHC.Builtin.PrimOps.Casts +import GHC.Platform import Data.List (mapAccumL) -- import GHC.Utils.Trace @@ -441,12 +442,13 @@ import Data.List (mapAccumL) -- (i.e. no unboxed tuples, sums or voids) -- data UnariseEnv = UnariseEnv - { ue_rho :: (VarEnv UnariseVal) + { ue_platform :: !Platform + , ue_rho :: VarEnv UnariseVal , ue_allow_static_conapp :: DataCon -> [StgArg] -> Bool } -initUnariseEnv :: VarEnv UnariseVal -> (DataCon -> [StgArg] -> Bool) -> UnariseEnv -initUnariseEnv = UnariseEnv +initUnariseEnv :: Platform -> VarEnv UnariseVal -> (DataCon -> [StgArg] -> Bool) -> UnariseEnv +initUnariseEnv platform rho is_dll = UnariseEnv platform rho is_dll data UnariseVal = MultiVal [OutStgArg] -- MultiVal to tuple. Can be empty list (void). @@ -479,8 +481,8 @@ lookupRho env v = lookupVarEnv (ue_rho env) v -------------------------------------------------------------------------------- -unarise :: UniqSupply -> (DataCon -> [StgArg] -> Bool) -> [StgTopBinding] -> [StgTopBinding] -unarise us is_dll_con_app binds = initUs_ us (mapM (unariseTopBinding (initUnariseEnv emptyVarEnv is_dll_con_app)) binds) +unarise :: Platform -> UniqSupply -> (DataCon -> [StgArg] -> Bool) -> [StgTopBinding] -> [StgTopBinding] +unarise platform us is_dll_con_app binds = initUs_ us (mapM (unariseTopBinding (initUnariseEnv platform emptyVarEnv is_dll_con_app)) binds) unariseTopBinding :: UnariseEnv -> StgTopBinding -> UniqSM StgTopBinding unariseTopBinding rho (StgTopLifted bind) @@ -627,7 +629,7 @@ unariseUbxSumOrTupleArgs rho us dc args ty_args | isUnboxedSumDataCon dc , let args1 = assert (isSingleton args) (unariseConArgs rho args) - = let (args2, cast_wrapper) = mkUbxSum dc ty_args args1 us + = let (args2, cast_wrapper) = mkUbxSum (ue_platform rho) dc ty_args args1 us in (args2, Just cast_wrapper) | otherwise @@ -848,29 +850,29 @@ mapSumIdBinders alt_bndr args rhs rho0 -- right type. -- Select only the args which contain parts of the current field. id_arg_exprs = [ args !! i | i <- layout1 ] - id_vars = [v | StgVarArg v <- id_arg_exprs] - typed_id_arg_input = assert (equalLength id_vars fld_reps) $ - zip3 id_vars fld_reps uss - - mkCastInput :: (Id,PrimRep,UniqSupply) -> ([(PrimOp,Type,Unique)],Id,Id) - mkCastInput (id,rep,bndr_us) = - let (ops,types) = unzip $ getCasts (typePrimRepU $ idType id) rep + typed_id_arg_input = assert (equalLength id_arg_exprs fld_reps) $ + zip3 id_arg_exprs fld_reps uss + + -- Process each (arg, target rep, unique supply) to produce + -- (rhs wrapper, typed arg). Handles both literal and variable args. + -- Literal args can arise after constant-folding in mkUbxSum + -- (see Note [Constant-folding during unarisation]). + mkCastArg :: (StgArg, PrimRep, UniqSupply) -> (StgExpr -> StgExpr, StgArg) + mkCastArg (StgLitArg lit, rep, _us) + | Just lit' <- castLiteralArg (ue_platform rho0) rep lit + = (id, StgLitArg lit') + | otherwise = pprPanic "mapSumIdBinders: cannot cast literal" (ppr lit $$ ppr rep) + mkCastArg (StgVarArg v, rep, bndr_us) = + let (ops,types) = unzip $ getCasts (typePrimRepU $ idType v) rep cst_opts = zip3 ops types $ uniqsFromSupply bndr_us out_id = case cst_opts of - [] -> id - _ -> let (_,ty,uq) = last cst_opts - in mkCastVar uq ty - in (cst_opts,id,out_id) - - cast_inputs = map mkCastInput typed_id_arg_input - (rhs_with_casts,typed_ids) = mapAccumL cast_arg (\x->x) cast_inputs - where - cast_arg rhs_in (cast_ops,in_id,out_id) = - let rhs_out = castArgRename cast_ops (StgVarArg in_id) - in (rhs_in . rhs_out, out_id) + [] -> v + _ -> let (_,ty,uq) = last cst_opts in mkCastVar uq ty + in (castArgRename cst_opts (StgVarArg v), StgVarArg out_id) - typed_id_args = map StgVarArg typed_ids + (wrappers, typed_id_args) = unzip $ map mkCastArg typed_id_arg_input + rhs_with_casts = foldr (.) id wrappers if isMultiValBndr alt_bndr then return (extendRho rho0 alt_bndr (MultiVal typed_id_args), rhs_with_casts rhs) @@ -913,14 +915,15 @@ mkCast arg_in cast_op out_id out_ty in_rhs = -- mkUbxSum :: HasDebugCallStack - => DataCon -- Sum data con + => Platform -- For compile-time constant-folding + -> DataCon -- Sum data con -> [[PrimRep]] -- Representations of type arguments of the sum data con -> [OutStgArg] -- Actual arguments of the alternative. -> UniqSupply -> ([OutStgArg] -- Final tuple arguments ,(StgExpr->StgExpr) -- We might need to cast the args first ) -mkUbxSum dc ty_args args0 us +mkUbxSum platform dc ty_args args0 us = let tag_slot :| sum_slots = ubxSumRepType ty_args -- drop tag slot @@ -961,6 +964,11 @@ mkUbxSum dc ty_args args0 us , ubxSumRubbishArg slot) castArg :: UniqSupply -> SlotTy -> StgArg -> Maybe (StgArg,UniqSupply,StgExpr -> StgExpr) + castArg us slot_ty arg@(StgLitArg lit) + -- See Note [Constant-folding during unarisation] + | slotPrimRep slot_ty /= stgArgRepU arg + , Just lit' <- castLiteralArg platform (slotPrimRep slot_ty) lit + = Just (StgLitArg lit', us, id) castArg us slot_ty arg -- Cast the argument to the type of the slot if required | slotPrimRep slot_ty /= stgArgRepU arg @@ -1006,6 +1014,101 @@ ubxSumRubbishArg DoubleSlot = StgLitArg (LitDouble 0) ubxSumRubbishArg (VecSlot n e) = StgLitArg (LitRubbish TypeLike vec_rep) where vec_rep = primRepToRuntimeRep (VecRep n e) +{- +Note [Constant-folding during unarisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See #25650. + +Goal: ensure that top-level bindings whose unboxed-sum fields are literals +become statically allocated closures (i.e. compile-time constants in the +object file) rather than CAFs. + +Background: A top-level RHS is statically allocated when it is a plain +`StgRhsCon`: a data constructor applied to arguments with no surrounding +expression. Any `StgCase` wrapper, even one that is a no-op at runtime, turns +the RHS into a CAF. + +The problem: When `mkUbxSum` builds an unboxed sum whose argument PrimRep does +not match the slot PrimRep, the general `castArg` path emits a runtime conversion +wrapper: + + case <conversion_primop> arg of x' -> <rhs using x'> + +For a *variable* argument this is unavoidable, the value is not known at +compile time. For a *literal* argument, however, the conversion can be performed +at compile time, avoiding the `StgCase` wrapper entirely. + +Example +~~~~~~~ +Consider: + + data A = MkA (# Int16# | Int32# #) + foo = MkA (# 10#Int16 | #) + +By the time this gets to the end of the Simplifier pipeline, this still looks +like: + foo = MkA (# 10#Int16 | #) +That is: the worker for the data constructor takes an unboxed sum as its +argument. + +The Unarise pass, which works on STG, decides that + (# 10#Int16 | #) :: (# Int16# | Int32# #) +should be represented as an pair of an integer tag (of type `Int8#`) and a payload +value (of type `Word32#`). But to do that it has to convert `10#Int16` into +`Word32#`, and that conversion is not a no-op. So without constant-folding we +get: + + foo = + \u [] + case int16ToWord16# [10#Int16] of cst_sum_gio { + __DEFAULT -> + case word16ToWord# [cst_sum_gio] of cst_sum_gip { + __DEFAULT -> MkA [1# cst_sum_gip]; + }; + }; + +Note that in the output of the unarise pass, the worker `MkA` takes two +arguments: the tag and the payload of our unboxed sum.. + +However it's a bit silly to generate a CAF here because with some +constant-folding we can easily avoid this thunk and generate a static datacon +instead. That's why the literal clause of `castArg` intercepts `Int16# 10`, +calls `castLiteralArg` to compute `Word32# 10` at compile time, and returns the +identity wrapper. The result is: + + foo = MkA! [1#Word8 10#Word32]; + + +Note that `castLiteralArg` uses `mkLitNumberWrap`, which matches the +semantics of GHC's integer-conversion primops (zero/sign extension to the target +width) — exactly the same transformation the runtime conversion would have +performed. + +-} + +-- | Try to convert a numeric literal to a new PrimRep at compile time. +-- Uses wrapping semantics (same as GHC's integer conversion primops). +-- Returns Nothing for non-numeric literals or unsupported PrimReps. +-- See Note [Constant-folding during unarisation]. +castLiteralArg :: Platform -> PrimRep -> Literal -> Maybe Literal +castLiteralArg platform to_rep (LitNumber _ n) + | Just to_ty <- litNumTypeFromPrimRep to_rep + = Just (mkLitNumberWrap platform to_ty n) +castLiteralArg _ _ _ = Nothing + +litNumTypeFromPrimRep :: PrimRep -> Maybe LitNumType +litNumTypeFromPrimRep WordRep = Just LitNumWord +litNumTypeFromPrimRep Word8Rep = Just LitNumWord8 +litNumTypeFromPrimRep Word16Rep = Just LitNumWord16 +litNumTypeFromPrimRep Word32Rep = Just LitNumWord32 +litNumTypeFromPrimRep Word64Rep = Just LitNumWord64 +litNumTypeFromPrimRep IntRep = Just LitNumInt +litNumTypeFromPrimRep Int8Rep = Just LitNumInt8 +litNumTypeFromPrimRep Int16Rep = Just LitNumInt16 +litNumTypeFromPrimRep Int32Rep = Just LitNumInt32 +litNumTypeFromPrimRep Int64Rep = Just LitNumInt64 +litNumTypeFromPrimRep _ = Nothing + -------------------------------------------------------------------------------- {- ===================================== testsuite/tests/codeGen/should_compile/Makefile ===================================== @@ -80,3 +80,6 @@ T17648: T25166: '$(TEST_HC)' $(TEST_HC_OPTS) -O2 -dno-typeable-binds -ddump-cmm T25166.hs | awk '/foo_closure/{flag=1}/}]/{flag=0}flag' + +T25650: + '$(TEST_HC)' $(TEST_HC_OPTS) -O2 -dno-typeable-binds -ddump-cmm T25650.hs | awk '/baz_foo_closure|baz_bar_closure/{flag=1}/}]/{flag=0}flag' ===================================== testsuite/tests/codeGen/should_compile/T25650.hs ===================================== @@ -0,0 +1,17 @@ +module T25650 (baz_foo, baz_bar) where + +import Data.Word + +data A + = A1 {-# UNPACK #-} !Word32 + | A2 {-# UNPACK #-} !B + +data B = B1 | B2 + +foo = A1 10 +bar = A2 B2 + +data C = C {-# UNPACK #-} !A + +baz_foo = C foo +baz_bar = C bar ===================================== testsuite/tests/codeGen/should_compile/T25650.stdout-ws-32 ===================================== @@ -0,0 +1,14 @@ +[section ""data" . T25650.baz_foo_closure" { + T25650.baz_foo_closure: + const T25650.C_con_info; + const 10; + const 1 :: W8; + const 0 :: W8; + const 0 :: W16; +[section ""data" . T25650.baz_bar_closure" { + T25650.baz_bar_closure: + const T25650.C_con_info; + const 2; + const 2 :: W8; + const 0 :: W8; + const 0 :: W16; ===================================== testsuite/tests/codeGen/should_compile/T25650.stdout-ws-64 ===================================== @@ -0,0 +1,14 @@ +[section ""data" . T25650.baz_foo_closure" { + T25650.baz_foo_closure: + const T25650.C_con_info; + const 10 :: W32; + const 1 :: W8; + const 0 :: W8; + const 0 :: W16; +[section ""data" . T25650.baz_bar_closure" { + T25650.baz_bar_closure: + const T25650.C_con_info; + const 2 :: W32; + const 2 :: W8; + const 0 :: W8; + const 0 :: W16; ===================================== testsuite/tests/codeGen/should_compile/all.T ===================================== @@ -140,6 +140,7 @@ test('callee-no-local', [ ) test('T25166', [req_cmm], makefile_test, []) +test('T25650', [req_cmm], makefile_test, []) # dump Core to ensure that d is defined as: d = D 10## RUBBISH(IntRep) test('T25177', normal, compile, ['-O2 -dno-typeable-binds -ddump-simpl -dsuppress-all -dsuppress-uniques -v0']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6eef855b6b7fadb9038dfb52b95d0e5f... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6eef855b6b7fadb9038dfb52b95d0e5f... You're receiving this email because of your account on gitlab.haskell.org.