Sebastian Graf pushed to branch wip/sg/enter-taggable-invariant at Glasgow Haskell Compiler / GHC Commits: 7e37b737 by Sebastian Graf at 2026-08-02T19:03:01+02:00 StgToCmm: evaluate in tail position through stg_enter_data stg_enter_data is stg_ap_0_fast specialised to values whose type rules out functions, the only values for which getCallMethod selects EnterIt: the closure is a thunk, a constructor, or an indirection to one, so the FUN/PAP/BCO arms of the generic evaluation are unreachable and an indirection's entry code performs the following. The stub reduces to the tag test and an entry jump, and emitEnter's Return case reduces to a single jump to it. Compiling T13960 allocates 1.6% less than with the open-coded tag test and return. - - - - - 4 changed files: - compiler/GHC/StgToCmm/Expr.hs - rts/Apply.cmm - rts/RtsSymbols.c - rts/include/stg/MiscClosures.h Changes: ===================================== compiler/GHC/StgToCmm/Expr.hs ===================================== @@ -35,7 +35,9 @@ import GHC.Cmm.Graph import GHC.Cmm.BlockId import GHC.Cmm hiding ( succ ) import GHC.Cmm.Info -import GHC.Cmm.Utils ( cmmTagMask, mkWordCLit, cmmLoadGCWord ) +import GHC.Cmm.Utils ( cmmTagMask, mkWordCLit ) +import GHC.Cmm.CLabel ( mkCmmCodeLabel ) +import GHC.Unit ( rtsUnitId ) import GHC.Platform.Tag ( mAX_PTR_TAG ) import GHC.Core import GHC.Core.DataCon @@ -1190,32 +1192,17 @@ emitEnter fun = do ; adjustHpBackwards ; sequel <- getSequel ; updfr_off <- getUpdFrameOff - ; align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig ; case sequel of - -- For a return we test the tag and, if the value is already tagged - -- (hence evaluated), return it directly rather than entering it. This - -- upholds the invariant that the entry code of a taggable normal form is - -- never reached: only an untagged closure is entered. The tag test costs - -- a branch on every tail enter, but a tagged value reaching here is the - -- common case. + -- For a return we evaluate through stg_enter_data, the specialisation + -- of stg_ap_0_fast to values whose type rules out functions + -- (getCallMethod selects EnterIt only for those): it returns a tagged + -- (hence evaluated) value directly and enters an untagged closure, so + -- the entry code of a taggable normal form is never reached and the + -- tail enter costs a single jump in the generated code. Return -> do - { fun_tmp <- assignTemp fun - ; let funR = CmmReg (CmmLocal fun_tmp) - entry = entryCode platform - $ closureInfoPtr platform align_check - $ CmmReg (nodeReg platform) - ret_addr = entryCode platform - $ cmmLoadGCWord platform (CmmStackSlot Old updfr_off) - ; lenter <- newBlockId - ; lret <- newBlockId - ; tscope <- getTickScope - ; emit $ - mkCbranch (cmmIsTagged platform funR) lret lenter Nothing <*> - outOfLine lenter - ( mkJump profile NativeNodeCall entry [cmmUntag platform funR] updfr_off - , tscope ) <*> - mkLabel lret tscope <*> - mkReturn profile ret_addr [funR] updfr_off + { let enter_data = CmmLit (CmmLabel + (mkCmmCodeLabel rtsUnitId (fsLit "stg_enter_data"))) + ; emit $ mkJump profile NativeNodeCall enter_data [fun] updfr_off ; return AssignedDirectly } ===================================== rts/Apply.cmm ===================================== @@ -54,6 +54,25 @@ import CLOSURE stg_restore_cccs_eval_info; * everything being returned is guaranteed evaluated, so it would be a no-op. */ +/* ----------------------------------------------------------------------------- + Evaluate a value whose type rules out functions. + + A specialisation of stg_ap_0_fast (below) to closures that are a + thunk, a constructor, or an indirection to one: the FUN/PAP/BCO arms + of the generic evaluation are unreachable, and an indirection's own + entry code performs the following, so evaluation reduces to the tag + test and an entry jump. The code generator jumps here to evaluate in + tail position; see emitEnter in GHC.StgToCmm.Expr. + -------------------------------------------------------------------------- */ + +stg_enter_data ( P_ x ) +{ + if (GETTAG(x) != 0) { + return (x); + } + jump %GET_ENTRY(x) (x); +} + STRING(stg_ap_0_ret_str,"stg_ap_0_ret... ") stg_ap_0_fast ( P_ fun ) ===================================== rts/RtsSymbols.c ===================================== @@ -848,6 +848,7 @@ extern char **environ; SymI_HasDataProto(stg_ap_ppppp_info) \ SymI_HasDataProto(stg_ap_pppppp_info) \ SymI_HasDataProto(stg_ap_0_fast) \ + SymI_HasDataProto(stg_enter_data) \ SymI_HasDataProto(stg_ap_v_fast) \ SymI_HasDataProto(stg_ap_f_fast) \ SymI_HasDataProto(stg_ap_d_fast) \ ===================================== rts/include/stg/MiscClosures.h ===================================== @@ -302,6 +302,7 @@ RTS_RET(stg_ap_ppppp); RTS_RET(stg_ap_pppppp); RTS_FUN_DECL(stg_ap_0_fast); +RTS_FUN_DECL(stg_enter_data); RTS_FUN_DECL(stg_ap_v_fast); RTS_FUN_DECL(stg_ap_f_fast); RTS_FUN_DECL(stg_ap_d_fast); View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7e37b73766e6e931cad507cf41847ac0... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7e37b73766e6e931cad507cf41847ac0... You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help