Jaro Reinders pushed to branch wip/ad-hoc-lazifier at Glasgow Haskell Compiler / GHC
Commits:
-
18dd2fbc
by Jaro Reinders at 2026-06-18T21:03:23+02:00
6 changed files:
- compiler/GHC/Builtin/PrimOps.hs
- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/StgToCmm/Expr.hs
- compiler/GHC/StgToCmm/Layout.hs
- compiler/GHC/StgToCmm/Prim.hs
- rts/PrimOps.cmm
Changes:
| ... | ... | @@ -22,7 +22,7 @@ module GHC.Builtin.PrimOps ( |
| 22 | 22 | |
| 23 | 23 | PrimOpEffect(..), primOpEffect,
|
| 24 | 24 | |
| 25 | - getPrimOpResultInfo, isComparisonPrimOp, PrimOpResultInfo(..),
|
|
| 25 | + getPrimOpResultKind, isComparisonPrimOp,
|
|
| 26 | 26 | |
| 27 | 27 | PrimCall(..)
|
| 28 | 28 | ) where
|
| ... | ... | @@ -872,30 +872,12 @@ primOpSig op |
| 872 | 872 | Compare _occ ty -> ([], [ty,ty], intPrimTy)
|
| 873 | 873 | GenPrimOp _occ tyvars arg_tys res_ty -> (tyvars, arg_tys, res_ty )
|
| 874 | 874 | |
| 875 | -data PrimOpResultInfo
|
|
| 876 | - = ReturnsVoid
|
|
| 877 | - | ReturnsPrim PrimRep
|
|
| 878 | - | ReturnsTuple
|
|
| 879 | - |
|
| 880 | --- Some PrimOps need not return a manifest primitive or algebraic value
|
|
| 881 | --- (i.e. they might return a polymorphic value). These PrimOps *must*
|
|
| 882 | --- be out of line, or the code generator won't work.
|
|
| 883 | - |
|
| 884 | -getPrimOpResultInfo :: PrimOp -> PrimOpResultInfo
|
|
| 885 | -getPrimOpResultInfo op
|
|
| 886 | - = case (primOpInfo op) of
|
|
| 887 | - Compare _ _ -> ReturnsPrim IntRep
|
|
| 888 | - GenPrimOp _ _ _ ty | isPrimTyCon tc -> case tyConPrimRep tc of
|
|
| 889 | - [] -> ReturnsVoid
|
|
| 890 | - [rep] -> ReturnsPrim rep
|
|
| 891 | - _ -> pprPanic "getPrimOpResultInfo" (ppr op)
|
|
| 892 | - | isUnboxedTupleTyCon tc -> ReturnsTuple
|
|
| 893 | - | otherwise -> pprPanic "getPrimOpResultInfo" (ppr op)
|
|
| 894 | - where
|
|
| 895 | - tc = tyConAppTyCon ty
|
|
| 896 | - -- All primops return a tycon-app result
|
|
| 897 | - -- The tycon can be an unboxed tuple or sum, though,
|
|
| 898 | - -- which gives rise to a ReturnAlg
|
|
| 875 | +-- Will crash for primops with representation or levity polymorphic result types
|
|
| 876 | +getPrimOpResultKind:: PrimOp -> Kind
|
|
| 877 | +getPrimOpResultKind op
|
|
| 878 | + = case primOpInfo op of
|
|
| 879 | + Compare _ _ -> typeKind intPrimTy
|
|
| 880 | + GenPrimOp _ _ _ ty -> typeKind ty
|
|
| 899 | 881 | |
| 900 | 882 | {-
|
| 901 | 883 | We do not currently make use of whether primops are commutable.
|
| ... | ... | @@ -4291,12 +4291,12 @@ primop VecSqrtOp "sqrt#" GenPrimOp |
| 4291 | 4291 | { Element-wise square root. }
|
| 4292 | 4292 | with vector = FLOAT_VECTOR_TYPES
|
| 4293 | 4293 | |
| 4294 | -primop LazyOp "toLazy#" GenPrimOp
|
|
| 4294 | +primop ToLazyOp "toLazy#" GenPrimOp
|
|
| 4295 | 4295 | a_unlifted -> Lazy a_unlifted
|
| 4296 | 4296 | { comment }
|
| 4297 | 4297 | with effect = CanFail
|
| 4298 | 4298 | |
| 4299 | -primop UnlazyOp "fromLazy#" GenPrimOp
|
|
| 4299 | +primop FromLazyOp "fromLazy#" GenPrimOp
|
|
| 4300 | 4300 | Lazy a_unlifted -> a_unlifted
|
| 4301 | 4301 | { comment }
|
| 4302 | 4302 | with effect = CanFail
|
| ... | ... | @@ -1183,84 +1183,6 @@ cgIdApp fun_id args = do |
| 1183 | 1183 | -- DynFlags, then passed to StgToCmmConfig for this phase.
|
| 1184 | 1184 | |
| 1185 | 1185 | |
| 1186 | -emitEnter :: CmmExpr -> FCode ReturnKind
|
|
| 1187 | -emitEnter fun = do
|
|
| 1188 | - { platform <- getPlatform
|
|
| 1189 | - ; profile <- getProfile
|
|
| 1190 | - ; adjustHpBackwards
|
|
| 1191 | - ; sequel <- getSequel
|
|
| 1192 | - ; updfr_off <- getUpdFrameOff
|
|
| 1193 | - ; align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig
|
|
| 1194 | - ; case sequel of
|
|
| 1195 | - -- For a return, we have the option of generating a tag-test or
|
|
| 1196 | - -- not. If the value is tagged, we can return directly, which
|
|
| 1197 | - -- is quicker than entering the value. This is a code
|
|
| 1198 | - -- size/speed trade-off: when optimising for speed rather than
|
|
| 1199 | - -- size we could generate the tag test.
|
|
| 1200 | - --
|
|
| 1201 | - -- Right now, we do what the old codegen did, and omit the tag
|
|
| 1202 | - -- test, just generating an enter.
|
|
| 1203 | - Return -> do
|
|
| 1204 | - { let entry = entryCode platform
|
|
| 1205 | - $ closureInfoPtr platform align_check
|
|
| 1206 | - $ CmmReg (nodeReg platform)
|
|
| 1207 | - ; emit $ mkJump profile NativeNodeCall entry
|
|
| 1208 | - [cmmUntag platform fun] updfr_off
|
|
| 1209 | - ; return AssignedDirectly
|
|
| 1210 | - }
|
|
| 1211 | - |
|
| 1212 | - -- The result will be scrutinised in the sequel. This is where
|
|
| 1213 | - -- we generate a tag-test to avoid entering the closure if
|
|
| 1214 | - -- possible.
|
|
| 1215 | - --
|
|
| 1216 | - -- The generated code will be something like this:
|
|
| 1217 | - --
|
|
| 1218 | - -- R1 = fun -- copyout
|
|
| 1219 | - -- if (fun & 7 != 0) goto Lret else goto Lcall
|
|
| 1220 | - -- Lcall:
|
|
| 1221 | - -- call [fun] returns to Lret
|
|
| 1222 | - -- Lret:
|
|
| 1223 | - -- fun' = R1 -- copyin
|
|
| 1224 | - -- ...
|
|
| 1225 | - --
|
|
| 1226 | - -- Note in particular that the label Lret is used as a
|
|
| 1227 | - -- destination by both the tag-test and the call. This is
|
|
| 1228 | - -- because Lret will necessarily be a proc-point, and we want to
|
|
| 1229 | - -- ensure that we generate only one proc-point for this
|
|
| 1230 | - -- sequence.
|
|
| 1231 | - --
|
|
| 1232 | - -- Furthermore, we tell the caller that we generated a native
|
|
| 1233 | - -- return continuation by returning (ReturnedTo Lret off), so
|
|
| 1234 | - -- that the continuation can be reused by the heap-check failure
|
|
| 1235 | - -- code in the enclosing case expression.
|
|
| 1236 | - --
|
|
| 1237 | - AssignTo res_regs _ -> do
|
|
| 1238 | - { lret <- newBlockId
|
|
| 1239 | - ; lcall <- newBlockId
|
|
| 1240 | - ; updfr_off <- getUpdFrameOff
|
|
| 1241 | - ; align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig
|
|
| 1242 | - ; let (off, _, copyin) = copyInOflow profile NativeReturn (Young lret) res_regs []
|
|
| 1243 | - ; let area = Young lret
|
|
| 1244 | - ; let (outArgs, regs, copyout) = copyOutOflow profile NativeNodeCall Call area
|
|
| 1245 | - [fun] updfr_off []
|
|
| 1246 | - -- refer to fun via nodeReg after the copyout, to avoid having
|
|
| 1247 | - -- both live simultaneously; this sometimes enables fun to be
|
|
| 1248 | - -- inlined in the RHS of the R1 assignment.
|
|
| 1249 | - ; let node = CmmReg $ nodeReg platform
|
|
| 1250 | - entry = entryCode platform (closureInfoPtr platform align_check node)
|
|
| 1251 | - the_call = toCall entry (Just lret) updfr_off off outArgs regs
|
|
| 1252 | - ; tscope <- getTickScope
|
|
| 1253 | - ; emit $
|
|
| 1254 | - copyout <*>
|
|
| 1255 | - mkCbranch (cmmIsTagged platform node)
|
|
| 1256 | - lret lcall Nothing <*>
|
|
| 1257 | - outOfLine lcall (the_call,tscope) <*>
|
|
| 1258 | - mkLabel lret tscope <*>
|
|
| 1259 | - copyin
|
|
| 1260 | - ; return (ReturnedTo lret off)
|
|
| 1261 | - }
|
|
| 1262 | - }
|
|
| 1263 | - |
|
| 1264 | 1186 | ------------------------------------------------------------------------
|
| 1265 | 1187 | -- Ticks
|
| 1266 | 1188 | ------------------------------------------------------------------------
|
| ... | ... | @@ -11,6 +11,7 @@ |
| 11 | 11 | module GHC.StgToCmm.Layout (
|
| 12 | 12 | mkArgDescr,
|
| 13 | 13 | emitCall, emitReturn, adjustHpBackwards,
|
| 14 | + emitEnter,
|
|
| 14 | 15 | |
| 15 | 16 | emitClosureProcAndInfoTable,
|
| 16 | 17 | emitClosureAndInfoTable,
|
| ... | ... | @@ -693,3 +694,81 @@ emitClosureAndInfoTable platform info_tbl conv args body |
| 693 | 694 | ; let entry_lbl = toEntryLbl platform (cit_lbl info_tbl)
|
| 694 | 695 | ; emitProcWithConvention conv (Just info_tbl) entry_lbl args blks
|
| 695 | 696 | }
|
| 697 | + |
|
| 698 | +emitEnter :: CmmExpr -> FCode ReturnKind
|
|
| 699 | +emitEnter fun = do
|
|
| 700 | + { platform <- getPlatform
|
|
| 701 | + ; profile <- getProfile
|
|
| 702 | + ; adjustHpBackwards
|
|
| 703 | + ; sequel <- getSequel
|
|
| 704 | + ; updfr_off <- getUpdFrameOff
|
|
| 705 | + ; align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig
|
|
| 706 | + ; case sequel of
|
|
| 707 | + -- For a return, we have the option of generating a tag-test or
|
|
| 708 | + -- not. If the value is tagged, we can return directly, which
|
|
| 709 | + -- is quicker than entering the value. This is a code
|
|
| 710 | + -- size/speed trade-off: when optimising for speed rather than
|
|
| 711 | + -- size we could generate the tag test.
|
|
| 712 | + --
|
|
| 713 | + -- Right now, we do what the old codegen did, and omit the tag
|
|
| 714 | + -- test, just generating an enter.
|
|
| 715 | + Return -> do
|
|
| 716 | + { let entry = entryCode platform
|
|
| 717 | + $ closureInfoPtr platform align_check
|
|
| 718 | + $ CmmReg (nodeReg platform)
|
|
| 719 | + ; emit $ mkJump profile NativeNodeCall entry
|
|
| 720 | + [cmmUntag platform fun] updfr_off
|
|
| 721 | + ; return AssignedDirectly
|
|
| 722 | + }
|
|
| 723 | + |
|
| 724 | + -- The result will be scrutinised in the sequel. This is where
|
|
| 725 | + -- we generate a tag-test to avoid entering the closure if
|
|
| 726 | + -- possible.
|
|
| 727 | + --
|
|
| 728 | + -- The generated code will be something like this:
|
|
| 729 | + --
|
|
| 730 | + -- R1 = fun -- copyout
|
|
| 731 | + -- if (fun & 7 != 0) goto Lret else goto Lcall
|
|
| 732 | + -- Lcall:
|
|
| 733 | + -- call [fun] returns to Lret
|
|
| 734 | + -- Lret:
|
|
| 735 | + -- fun' = R1 -- copyin
|
|
| 736 | + -- ...
|
|
| 737 | + --
|
|
| 738 | + -- Note in particular that the label Lret is used as a
|
|
| 739 | + -- destination by both the tag-test and the call. This is
|
|
| 740 | + -- because Lret will necessarily be a proc-point, and we want to
|
|
| 741 | + -- ensure that we generate only one proc-point for this
|
|
| 742 | + -- sequence.
|
|
| 743 | + --
|
|
| 744 | + -- Furthermore, we tell the caller that we generated a native
|
|
| 745 | + -- return continuation by returning (ReturnedTo Lret off), so
|
|
| 746 | + -- that the continuation can be reused by the heap-check failure
|
|
| 747 | + -- code in the enclosing case expression.
|
|
| 748 | + --
|
|
| 749 | + AssignTo res_regs _ -> do
|
|
| 750 | + { lret <- newBlockId
|
|
| 751 | + ; lcall <- newBlockId
|
|
| 752 | + ; updfr_off <- getUpdFrameOff
|
|
| 753 | + ; align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig
|
|
| 754 | + ; let (off, _, copyin) = copyInOflow profile NativeReturn (Young lret) res_regs []
|
|
| 755 | + ; let area = Young lret
|
|
| 756 | + ; let (outArgs, regs, copyout) = copyOutOflow profile NativeNodeCall Call area
|
|
| 757 | + [fun] updfr_off []
|
|
| 758 | + -- refer to fun via nodeReg after the copyout, to avoid having
|
|
| 759 | + -- both live simultaneously; this sometimes enables fun to be
|
|
| 760 | + -- inlined in the RHS of the R1 assignment.
|
|
| 761 | + ; let node = CmmReg $ nodeReg platform
|
|
| 762 | + entry = entryCode platform (closureInfoPtr platform align_check node)
|
|
| 763 | + the_call = toCall entry (Just lret) updfr_off off outArgs regs
|
|
| 764 | + ; tscope <- getTickScope
|
|
| 765 | + ; emit $
|
|
| 766 | + copyout <*>
|
|
| 767 | + mkCbranch (cmmIsTagged platform node)
|
|
| 768 | + lret lcall Nothing <*>
|
|
| 769 | + outOfLine lcall (the_call,tscope) <*>
|
|
| 770 | + mkLabel lret tscope <*>
|
|
| 771 | + copyin
|
|
| 772 | + ; return (ReturnedTo lret off)
|
|
| 773 | + }
|
|
| 774 | + } |
| ... | ... | @@ -31,6 +31,7 @@ import GHC.StgToCmm.Prof ( costCentreFrom ) |
| 31 | 31 | |
| 32 | 32 | import GHC.Types.Basic
|
| 33 | 33 | import GHC.Types.Literal.Floating
|
| 34 | +import GHC.Types.RepType (kindPrimRep_maybe)
|
|
| 34 | 35 | import GHC.Cmm.BlockId
|
| 35 | 36 | import GHC.Cmm.Graph
|
| 36 | 37 | import GHC.Stg.Syntax
|
| ... | ... | @@ -858,9 +859,11 @@ emitPrimOp cfg primop = |
| 858 | 859 | WriteByteArrayOp_Word8AsWord64 -> \args -> inlinePrimop $ \res ->
|
| 859 | 860 | doWriteByteArrayOp Nothing b8 res args
|
| 860 | 861 | |
| 861 | - -- TODO: make these inline
|
|
| 862 | - LazyOp -> \args -> externalPrimop primop args
|
|
| 863 | - UnlazyOp -> \args -> externalPrimop primop args
|
|
| 862 | + ToLazyOp -> \args -> externalPrimop primop args
|
|
| 863 | + FromLazyOp -> \[addr] -> inlinePrimop $ \[res] -> do
|
|
| 864 | + platform <- getPlatform
|
|
| 865 | + _ <- withSequel (AssignTo [res] False) (emitEnter addr)
|
|
| 866 | + emitAssign (CmmLocal res) (cmmUntag platform (CmmReg (CmmLocal res)))
|
|
| 864 | 867 | |
| 865 | 868 | -- Copying and setting byte arrays
|
| 866 | 869 | CopyByteArrayOp -> \[src,src_off,dst,dst_off,n] -> inlinePrimop $ \[] ->
|
| ... | ... | @@ -1859,7 +1862,6 @@ emitPrimOp cfg primop = |
| 1859 | 1862 | where
|
| 1860 | 1863 | profile = stgToCmmProfile cfg
|
| 1861 | 1864 | platform = stgToCmmPlatform cfg
|
| 1862 | - result_info = getPrimOpResultInfo primop
|
|
| 1863 | 1865 | |
| 1864 | 1866 | opNop :: [CmmExpr] -> PrimopCmmEmit
|
| 1865 | 1867 | opNop args = inlinePrimop $ \[res] -> emitAssign (CmmLocal res) arg
|
| ... | ... | @@ -1913,15 +1915,10 @@ emitPrimOp cfg primop = |
| 1913 | 1915 | inlinePrimopWithReturnType f = PrimopCmmEmit
|
| 1914 | 1916 | { primopCmmInline = True
|
| 1915 | 1917 | , primopCmmCode = \res_ty -> do
|
| 1916 | - regs <- case result_info of
|
|
| 1917 | - ReturnsVoid -> pure []
|
|
| 1918 | - ReturnsPrim rep
|
|
| 1919 | - -> do reg <- newTemp (primRepCmmType platform rep)
|
|
| 1920 | - pure [reg]
|
|
| 1921 | - |
|
| 1922 | - ReturnsTuple
|
|
| 1923 | - -> do (regs, _hints) <- newUnboxedTupleRegs res_ty
|
|
| 1924 | - pure regs
|
|
| 1918 | + regs <-
|
|
| 1919 | + case kindPrimRep_maybe (getPrimOpResultKind primop) of
|
|
| 1920 | + Nothing -> panic "Primop result kind has no runtime representation!"
|
|
| 1921 | + Just reps -> mapM (newTemp . primRepCmmType platform) reps
|
|
| 1925 | 1922 | f res_ty regs
|
| 1926 | 1923 | emitReturn (map (CmmReg . CmmLocal) regs)
|
| 1927 | 1924 | }
|
| ... | ... | @@ -121,12 +121,6 @@ stg_newByteArrayzh ( W_ n ) |
| 121 | 121 | return (p);
|
| 122 | 122 | }
|
| 123 | 123 | |
| 124 | -stg_fromLazzyzh ( P_ p )
|
|
| 125 | -{
|
|
| 126 | - (P_ unlifted) = call stg_ap_0_fast(p);
|
|
| 127 | - return (UNTAG(unlifted));
|
|
| 128 | -}
|
|
| 129 | - |
|
| 130 | 124 | stg_toLazzyzh ( P_ p )
|
| 131 | 125 | {
|
| 132 | 126 | if (GET_INFO(p) == stg_ARR_WORDS_info) {
|