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 Inline fromLazy# - - - - - 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: ===================================== compiler/GHC/Builtin/PrimOps.hs ===================================== @@ -22,7 +22,7 @@ module GHC.Builtin.PrimOps ( PrimOpEffect(..), primOpEffect, - getPrimOpResultInfo, isComparisonPrimOp, PrimOpResultInfo(..), + getPrimOpResultKind, isComparisonPrimOp, PrimCall(..) ) where @@ -872,30 +872,12 @@ primOpSig op Compare _occ ty -> ([], [ty,ty], intPrimTy) GenPrimOp _occ tyvars arg_tys res_ty -> (tyvars, arg_tys, res_ty ) -data PrimOpResultInfo - = ReturnsVoid - | ReturnsPrim PrimRep - | ReturnsTuple - --- Some PrimOps need not return a manifest primitive or algebraic value --- (i.e. they might return a polymorphic value). These PrimOps *must* --- be out of line, or the code generator won't work. - -getPrimOpResultInfo :: PrimOp -> PrimOpResultInfo -getPrimOpResultInfo op - = case (primOpInfo op) of - Compare _ _ -> ReturnsPrim IntRep - GenPrimOp _ _ _ ty | isPrimTyCon tc -> case tyConPrimRep tc of - [] -> ReturnsVoid - [rep] -> ReturnsPrim rep - _ -> pprPanic "getPrimOpResultInfo" (ppr op) - | isUnboxedTupleTyCon tc -> ReturnsTuple - | otherwise -> pprPanic "getPrimOpResultInfo" (ppr op) - where - tc = tyConAppTyCon ty - -- All primops return a tycon-app result - -- The tycon can be an unboxed tuple or sum, though, - -- which gives rise to a ReturnAlg +-- Will crash for primops with representation or levity polymorphic result types +getPrimOpResultKind:: PrimOp -> Kind +getPrimOpResultKind op + = case primOpInfo op of + Compare _ _ -> typeKind intPrimTy + GenPrimOp _ _ _ ty -> typeKind ty {- We do not currently make use of whether primops are commutable. ===================================== compiler/GHC/Builtin/primops.txt.pp ===================================== @@ -4291,12 +4291,12 @@ primop VecSqrtOp "sqrt#" GenPrimOp { Element-wise square root. } with vector = FLOAT_VECTOR_TYPES -primop LazyOp "toLazy#" GenPrimOp +primop ToLazyOp "toLazy#" GenPrimOp a_unlifted -> Lazy a_unlifted { comment } with effect = CanFail -primop UnlazyOp "fromLazy#" GenPrimOp +primop FromLazyOp "fromLazy#" GenPrimOp Lazy a_unlifted -> a_unlifted { comment } with effect = CanFail ===================================== compiler/GHC/StgToCmm/Expr.hs ===================================== @@ -1183,84 +1183,6 @@ cgIdApp fun_id args = do -- DynFlags, then passed to StgToCmmConfig for this phase. -emitEnter :: CmmExpr -> FCode ReturnKind -emitEnter fun = do - { platform <- getPlatform - ; profile <- getProfile - ; adjustHpBackwards - ; sequel <- getSequel - ; updfr_off <- getUpdFrameOff - ; align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig - ; case sequel of - -- For a return, we have the option of generating a tag-test or - -- not. If the value is tagged, we can return directly, which - -- is quicker than entering the value. This is a code - -- size/speed trade-off: when optimising for speed rather than - -- size we could generate the tag test. - -- - -- Right now, we do what the old codegen did, and omit the tag - -- test, just generating an enter. - Return -> do - { let entry = entryCode platform - $ closureInfoPtr platform align_check - $ CmmReg (nodeReg platform) - ; emit $ mkJump profile NativeNodeCall entry - [cmmUntag platform fun] updfr_off - ; return AssignedDirectly - } - - -- The result will be scrutinised in the sequel. This is where - -- we generate a tag-test to avoid entering the closure if - -- possible. - -- - -- The generated code will be something like this: - -- - -- R1 = fun -- copyout - -- if (fun & 7 != 0) goto Lret else goto Lcall - -- Lcall: - -- call [fun] returns to Lret - -- Lret: - -- fun' = R1 -- copyin - -- ... - -- - -- Note in particular that the label Lret is used as a - -- destination by both the tag-test and the call. This is - -- because Lret will necessarily be a proc-point, and we want to - -- ensure that we generate only one proc-point for this - -- sequence. - -- - -- Furthermore, we tell the caller that we generated a native - -- return continuation by returning (ReturnedTo Lret off), so - -- that the continuation can be reused by the heap-check failure - -- code in the enclosing case expression. - -- - AssignTo res_regs _ -> do - { lret <- newBlockId - ; lcall <- newBlockId - ; updfr_off <- getUpdFrameOff - ; align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig - ; let (off, _, copyin) = copyInOflow profile NativeReturn (Young lret) res_regs [] - ; let area = Young lret - ; let (outArgs, regs, copyout) = copyOutOflow profile NativeNodeCall Call area - [fun] updfr_off [] - -- refer to fun via nodeReg after the copyout, to avoid having - -- both live simultaneously; this sometimes enables fun to be - -- inlined in the RHS of the R1 assignment. - ; let node = CmmReg $ nodeReg platform - entry = entryCode platform (closureInfoPtr platform align_check node) - the_call = toCall entry (Just lret) updfr_off off outArgs regs - ; tscope <- getTickScope - ; emit $ - copyout <*> - mkCbranch (cmmIsTagged platform node) - lret lcall Nothing <*> - outOfLine lcall (the_call,tscope) <*> - mkLabel lret tscope <*> - copyin - ; return (ReturnedTo lret off) - } - } - ------------------------------------------------------------------------ -- Ticks ------------------------------------------------------------------------ ===================================== compiler/GHC/StgToCmm/Layout.hs ===================================== @@ -11,6 +11,7 @@ module GHC.StgToCmm.Layout ( mkArgDescr, emitCall, emitReturn, adjustHpBackwards, + emitEnter, emitClosureProcAndInfoTable, emitClosureAndInfoTable, @@ -693,3 +694,81 @@ emitClosureAndInfoTable platform info_tbl conv args body ; let entry_lbl = toEntryLbl platform (cit_lbl info_tbl) ; emitProcWithConvention conv (Just info_tbl) entry_lbl args blks } + +emitEnter :: CmmExpr -> FCode ReturnKind +emitEnter fun = do + { platform <- getPlatform + ; profile <- getProfile + ; adjustHpBackwards + ; sequel <- getSequel + ; updfr_off <- getUpdFrameOff + ; align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig + ; case sequel of + -- For a return, we have the option of generating a tag-test or + -- not. If the value is tagged, we can return directly, which + -- is quicker than entering the value. This is a code + -- size/speed trade-off: when optimising for speed rather than + -- size we could generate the tag test. + -- + -- Right now, we do what the old codegen did, and omit the tag + -- test, just generating an enter. + Return -> do + { let entry = entryCode platform + $ closureInfoPtr platform align_check + $ CmmReg (nodeReg platform) + ; emit $ mkJump profile NativeNodeCall entry + [cmmUntag platform fun] updfr_off + ; return AssignedDirectly + } + + -- The result will be scrutinised in the sequel. This is where + -- we generate a tag-test to avoid entering the closure if + -- possible. + -- + -- The generated code will be something like this: + -- + -- R1 = fun -- copyout + -- if (fun & 7 != 0) goto Lret else goto Lcall + -- Lcall: + -- call [fun] returns to Lret + -- Lret: + -- fun' = R1 -- copyin + -- ... + -- + -- Note in particular that the label Lret is used as a + -- destination by both the tag-test and the call. This is + -- because Lret will necessarily be a proc-point, and we want to + -- ensure that we generate only one proc-point for this + -- sequence. + -- + -- Furthermore, we tell the caller that we generated a native + -- return continuation by returning (ReturnedTo Lret off), so + -- that the continuation can be reused by the heap-check failure + -- code in the enclosing case expression. + -- + AssignTo res_regs _ -> do + { lret <- newBlockId + ; lcall <- newBlockId + ; updfr_off <- getUpdFrameOff + ; align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig + ; let (off, _, copyin) = copyInOflow profile NativeReturn (Young lret) res_regs [] + ; let area = Young lret + ; let (outArgs, regs, copyout) = copyOutOflow profile NativeNodeCall Call area + [fun] updfr_off [] + -- refer to fun via nodeReg after the copyout, to avoid having + -- both live simultaneously; this sometimes enables fun to be + -- inlined in the RHS of the R1 assignment. + ; let node = CmmReg $ nodeReg platform + entry = entryCode platform (closureInfoPtr platform align_check node) + the_call = toCall entry (Just lret) updfr_off off outArgs regs + ; tscope <- getTickScope + ; emit $ + copyout <*> + mkCbranch (cmmIsTagged platform node) + lret lcall Nothing <*> + outOfLine lcall (the_call,tscope) <*> + mkLabel lret tscope <*> + copyin + ; return (ReturnedTo lret off) + } + } ===================================== compiler/GHC/StgToCmm/Prim.hs ===================================== @@ -31,6 +31,7 @@ import GHC.StgToCmm.Prof ( costCentreFrom ) import GHC.Types.Basic import GHC.Types.Literal.Floating +import GHC.Types.RepType (kindPrimRep_maybe) import GHC.Cmm.BlockId import GHC.Cmm.Graph import GHC.Stg.Syntax @@ -858,9 +859,11 @@ emitPrimOp cfg primop = WriteByteArrayOp_Word8AsWord64 -> \args -> inlinePrimop $ \res -> doWriteByteArrayOp Nothing b8 res args - -- TODO: make these inline - LazyOp -> \args -> externalPrimop primop args - UnlazyOp -> \args -> externalPrimop primop args + ToLazyOp -> \args -> externalPrimop primop args + FromLazyOp -> \[addr] -> inlinePrimop $ \[res] -> do + platform <- getPlatform + _ <- withSequel (AssignTo [res] False) (emitEnter addr) + emitAssign (CmmLocal res) (cmmUntag platform (CmmReg (CmmLocal res))) -- Copying and setting byte arrays CopyByteArrayOp -> \[src,src_off,dst,dst_off,n] -> inlinePrimop $ \[] -> @@ -1859,7 +1862,6 @@ emitPrimOp cfg primop = where profile = stgToCmmProfile cfg platform = stgToCmmPlatform cfg - result_info = getPrimOpResultInfo primop opNop :: [CmmExpr] -> PrimopCmmEmit opNop args = inlinePrimop $ \[res] -> emitAssign (CmmLocal res) arg @@ -1913,15 +1915,10 @@ emitPrimOp cfg primop = inlinePrimopWithReturnType f = PrimopCmmEmit { primopCmmInline = True , primopCmmCode = \res_ty -> do - regs <- case result_info of - ReturnsVoid -> pure [] - ReturnsPrim rep - -> do reg <- newTemp (primRepCmmType platform rep) - pure [reg] - - ReturnsTuple - -> do (regs, _hints) <- newUnboxedTupleRegs res_ty - pure regs + regs <- + case kindPrimRep_maybe (getPrimOpResultKind primop) of + Nothing -> panic "Primop result kind has no runtime representation!" + Just reps -> mapM (newTemp . primRepCmmType platform) reps f res_ty regs emitReturn (map (CmmReg . CmmLocal) regs) } ===================================== rts/PrimOps.cmm ===================================== @@ -121,12 +121,6 @@ stg_newByteArrayzh ( W_ n ) return (p); } -stg_fromLazzyzh ( P_ p ) -{ - (P_ unlifted) = call stg_ap_0_fast(p); - return (UNTAG(unlifted)); -} - stg_toLazzyzh ( P_ p ) { if (GET_INFO(p) == stg_ARR_WORDS_info) { View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/18dd2fbc280789bbb86d0bf0fea3127b... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/18dd2fbc280789bbb86d0bf0fea3127b... You're receiving this email because of your account on gitlab.haskell.org.