[Git][ghc/ghc][master] Fix FMA instruction on LLVM
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Wed Jan 24 19:05:07 UTC 2024
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
a40f4ab2 by sheaf at 2024-01-24T14:04:33-05:00
Fix FMA instruction on LLVM
We were emitting the wrong instructions for fused multiply-add
operations on LLVM:
- the instruction name is "llvm.fma.f32" or "llvm.fma.f64", not "fmadd"
- LLVM does not support other instructions such as "fmsub"; instead
we implement these by flipping signs of some arguments
- the instruction is an LLVM intrinsic, which requires handling it
like a normal function call instead of a machine instruction
Fixes #24223
- - - - -
11 changed files:
- compiler/GHC/CmmToLlvm/CodeGen.hs
- compiler/GHC/Llvm/Ppr.hs
- compiler/GHC/Llvm/Syntax.hs
- + testsuite/tests/primops/Ben.dump-ds
- + testsuite/tests/primops/Ben.dump-ds-preopt
- + testsuite/tests/primops/Ben.dump-stg-final
- + testsuite/tests/primops/Ben.hs
- + testsuite/tests/primops/should_run/UnliftedWeakPtr.dump-ds
- + testsuite/tests/primops/should_run/UnliftedWeakPtr.dump-ds-preopt
- + testsuite/tests/primops/should_run/UnliftedWeakPtr.dump-stg-final
- testsuite/tests/primops/should_run/all.T
Changes:
=====================================
compiler/GHC/CmmToLlvm/CodeGen.hs
=====================================
@@ -12,6 +12,7 @@ import GHC.Platform
import GHC.Platform.Regs ( activeStgRegs )
import GHC.Llvm
+import GHC.Llvm.Types
import GHC.CmmToLlvm.Base
import GHC.CmmToLlvm.Config
import GHC.CmmToLlvm.Regs
@@ -1765,31 +1766,49 @@ genMachOp_slow opt op [x, y] = case op of
pprPanic "isSMulOK: Not bit type! " $
lparen <> ppr word <> rparen
- panicOp = panic $ "LLVM.CodeGen.genMachOp_slow: unary op encountered"
+ panicOp = panic $ "LLVM.CodeGen.genMachOp_slow: non-binary op encountered"
++ "with two arguments! (" ++ show op ++ ")"
-genMachOp_slow _opt op [x, y, z] = case op of
- MO_FMA var _ -> triLlvmOp getVarType (FMAOp var)
- _ -> panicOp
- where
- triLlvmOp ty op = do
- platform <- getPlatform
- runExprData $ do
- vx <- exprToVarW x
- vy <- exprToVarW y
- vz <- exprToVarW z
-
- if | getVarType vx == getVarType vy
- , getVarType vx == getVarType vz
- -> doExprW (ty vx) $ op vx vy vz
- | otherwise
- -> pprPanic "triLlvmOp types" (pdoc platform x $$ pdoc platform y $$ pdoc platform z)
- panicOp = panic $ "LLVM.CodeGen.genMachOp_slow: non-ternary op encountered"
- ++ "with three arguments! (" ++ show op ++ ")"
+genMachOp_slow _opt op [x, y, z] = do
+ platform <- getPlatform
+ let
+ neg x = CmmMachOp (MO_F_Neg (cmmExprWidth platform x)) [x]
+ panicOp = panic $ "LLVM.CodeGen.genMachOp_slow: non-ternary op encountered"
+ ++ "with three arguments! (" ++ show op ++ ")"
+ case op of
+ MO_FMA var _ ->
+ case var of
+ -- LLVM only has the fmadd variant.
+ FMAdd -> genFmaOp x y z
+ -- Other fused multiply-add operations are implemented in terms of fmadd
+ -- This is sound: it does not lose any precision.
+ FMSub -> genFmaOp x y (neg z)
+ FNMAdd -> genFmaOp (neg x) y z
+ FNMSub -> genFmaOp (neg x) y (neg z)
+ _ -> panicOp
-- More than three expressions, invalid!
genMachOp_slow _ _ _ = panic "genMachOp_slow: More than 3 expressions in MachOp!"
+-- | Generate code for a fused multiply-add operation.
+genFmaOp :: CmmExpr -> CmmExpr -> CmmExpr -> LlvmM ExprData
+genFmaOp x y z = runExprData $ do
+ vx <- exprToVarW x
+ vy <- exprToVarW y
+ vz <- exprToVarW z
+ let tx = getVarType vx
+ ty = getVarType vy
+ tz = getVarType vz
+ Panic.massertPpr
+ (tx == ty && tx == tz)
+ (vcat [ text "fma: mismatched arg types"
+ , ppLlvmType tx, ppLlvmType ty, ppLlvmType tz ])
+ let fname = case tx of
+ LMFloat -> fsLit "llvm.fma.f32"
+ LMDouble -> fsLit "llvm.fma.f64"
+ _ -> pprPanic "fma: type not LMFloat or LMDouble" (ppLlvmType tx)
+ fptr <- liftExprData $ getInstrinct fname ty [tx, ty, tz]
+ doExprW tx $ Call StdCall fptr [vx, vy, vz] [ReadNone, NoUnwind]
-- | Handle CmmLoad expression.
genLoad :: Atomic -> CmmExpr -> CmmType -> AlignmentSpec -> LlvmM ExprData
=====================================
compiler/GHC/Llvm/Ppr.hs
=====================================
@@ -27,7 +27,7 @@ module GHC.Llvm.Ppr (
ppLit,
ppTypeLit,
ppName,
- ppPlainName
+ ppPlainName,
) where
@@ -40,7 +40,6 @@ import GHC.Llvm.Types
import Data.List ( intersperse )
import GHC.Utils.Outputable
-import GHC.Cmm.MachOp ( FMASign(..), pprFMASign )
import GHC.CmmToLlvm.Config
import GHC.Utils.Panic
import GHC.Types.Unique
@@ -289,7 +288,6 @@ ppLlvmExpression opts expr
AtomicRMW aop tgt src ordering -> ppAtomicRMW opts aop tgt src ordering
CmpXChg addr old new s_ord f_ord -> ppCmpXChg opts addr old new s_ord f_ord
Phi tp predecessors -> ppPhi opts tp predecessors
- FMAOp op x y z -> pprFMAOp opts op x y z
Asm asm c ty v se sk -> ppAsm opts asm c ty v se sk
MExpr meta expr -> ppMetaAnnotExpr opts meta expr
{-# SPECIALIZE ppLlvmExpression :: LlvmCgConfig -> LlvmExpression -> SDoc #-}
@@ -377,13 +375,6 @@ ppCmpOp opts op left right =
{-# SPECIALIZE ppCmpOp :: LlvmCgConfig -> LlvmCmpOp -> LlvmVar -> LlvmVar -> SDoc #-}
{-# SPECIALIZE ppCmpOp :: LlvmCgConfig -> LlvmCmpOp -> LlvmVar -> LlvmVar -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-pprFMAOp :: IsLine doc => LlvmCgConfig -> FMASign -> LlvmVar -> LlvmVar -> LlvmVar -> doc
-pprFMAOp opts signs x y z =
- pprFMASign signs <+> ppLlvmType (getVarType x)
- <+> ppName opts x <> comma
- <+> ppName opts y <> comma
- <+> ppName opts z
-
ppAssignment :: IsLine doc => LlvmCgConfig -> LlvmVar -> doc -> doc
ppAssignment opts var expr = ppName opts var <+> equals <+> expr
{-# SPECIALIZE ppAssignment :: LlvmCgConfig -> LlvmVar -> SDoc -> SDoc #-}
=====================================
compiler/GHC/Llvm/Syntax.hs
=====================================
@@ -10,7 +10,6 @@ import GHC.Llvm.MetaData
import GHC.Llvm.Types
import GHC.Types.Unique
-import GHC.Cmm.MachOp ( FMASign(..) )
-- | Block labels
type LlvmBlockId = Unique
@@ -339,8 +338,6 @@ data LlvmExpression
-}
| Asm LMString LMString LlvmType [LlvmVar] Bool Bool
- | FMAOp FMASign LlvmVar LlvmVar LlvmVar
-
{- |
A LLVM expression with metadata attached to it.
-}
=====================================
testsuite/tests/primops/Ben.dump-ds
=====================================
@@ -0,0 +1,31 @@
+
+==================== Desugar (after optimization) ====================
+2023-09-19 16:22:12.539709 UTC
+
+Result size of Desugar (after optimization)
+ = {terms: 12, types: 41, coercions: 21, joins: 0/0}
+
+-- RHS size: {terms: 11, types: 30, coercions: 21, joins: 0/0}
+foo :: forall {s} a. a -> State# s -> (# Int#, State# s #)
+[LclIdX,
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=True)}]
+foo
+ = \ (@s_al6) (@a_al7) (x_akF :: a_al7) (s0_akG :: State# s_al6) ->
+ keepAlive#
+ @(TupleRep [IntRep, ZeroBitRep])
+ @Lifted
+ @a_al7
+ @s_al6
+ @(# Int#, State# s_al6 #)
+ ((CO: <TupleRep [IntRep, ZeroBitRep]>_N)
+ `cast` (Sub (Sym (AxSmallRep# (<TupleRep [IntRep, ZeroBitRep]>_N)))
+ :: (TupleRep [IntRep, ZeroBitRep]
+ GHC.Prim.~# TupleRep [IntRep, ZeroBitRep])
+ ~R# GHC.Prim.SmallRep# (TupleRep [IntRep, ZeroBitRep])))
+ x_akF
+ s0_akG
+ (\ (s1_akH [OS=OneShot] :: State# s_al6) -> (# 42#, s1_akH #))
+
+
=====================================
testsuite/tests/primops/Ben.dump-ds-preopt
=====================================
@@ -0,0 +1,36 @@
+
+==================== Desugar (before optimization) ====================
+2023-09-19 16:22:12.5377082 UTC
+
+Result size of Desugar (before optimization)
+ = {terms: 14, types: 51, coercions: 21, joins: 0/1}
+
+Rec {
+-- RHS size: {terms: 13, types: 40, coercions: 21, joins: 0/1}
+foo :: forall {s} a. a -> State# s -> (# Int#, State# s #)
+[LclIdX]
+foo
+ = \ (@s_al6) (@a_al7) ->
+ let {
+ irred_ale :: GHC.Prim.SmallRep# (TupleRep [IntRep, ZeroBitRep])
+ [LclId]
+ irred_ale
+ = (CO: <TupleRep [IntRep, ZeroBitRep]>_N)
+ `cast` (Sub (Sym (AxSmallRep# (<TupleRep [IntRep, ZeroBitRep]>_N)))
+ :: (TupleRep [IntRep, ZeroBitRep]
+ GHC.Prim.~# TupleRep [IntRep, ZeroBitRep])
+ ~R# GHC.Prim.SmallRep# (TupleRep [IntRep, ZeroBitRep])) } in
+ \ (x_akF :: a_al7) (s0_akG :: State# s_al6) ->
+ keepAlive#
+ @(TupleRep [IntRep, ZeroBitRep])
+ @Lifted
+ @a_al7
+ @s_al6
+ @(# Int#, State# s_al6 #)
+ irred_ale
+ x_akF
+ s0_akG
+ (\ (s1_akH :: State# s_al6) -> (# 42#, s1_akH #))
+end Rec }
+
+
=====================================
testsuite/tests/primops/Ben.dump-stg-final
=====================================
@@ -0,0 +1,17 @@
+
+==================== Final STG: ====================
+2023-09-19 16:22:12.5502122 UTC
+
+Ben.foo1
+ :: forall s.
+ GHC.Prim.State# s -> (# GHC.Prim.Int#, GHC.Prim.State# s #)
+[GblId, Arity=1, Str=<L>, Cpr=1, Unf=OtherCon []] =
+ {} \r [void_0E] Solo# [42#];
+
+Ben.foo
+ :: forall {s} a.
+ a -> GHC.Prim.State# s -> (# GHC.Prim.Int#, GHC.Prim.State# s #)
+[GblId, Arity=2, Str=<L><L>, Unf=OtherCon []] =
+ {} \r [x_sFm void_0E]
+ keepAlive# [GHC.Prim.coercionToken# x_sFm GHC.Prim.void# Ben.foo1];
+
=====================================
testsuite/tests/primops/Ben.hs
=====================================
@@ -0,0 +1,17 @@
+
+{-# LANGUAGE DataKinds, PolyKinds #-}
+{-# LANGUAGE MagicHash, UnboxedTuples #-}
+{-# LANGUAGE TypeFamilies #-}
+
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
+
+module Ben where
+
+import Data.Kind
+import GHC.Exts
+import GHC.IO
+
+foo :: forall {s} a. a -> State# s -> (# Int#, State# s #)
+foo x s0 = keepAlive# x s0 (\s1 -> (# 42#, s1 #))
+ --keepAlive#
=====================================
testsuite/tests/primops/should_run/UnliftedWeakPtr.dump-ds
=====================================
@@ -0,0 +1,191 @@
+
+==================== Desugar (after optimization) ====================
+2023-09-19 16:23:01.4184099 UTC
+
+Result size of Desugar (after optimization)
+ = {terms: 150, types: 341, coercions: 25, joins: 0/0}
+
+-- RHS size: {terms: 12, types: 16, coercions: 0, joins: 0/0}
+finalise
+ :: MVar# RealWorld String
+ -> State# RealWorld -> (# State# RealWorld, () #)
+[LclIdX,
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [0 0] 74 10}]
+finalise
+ = \ (mvar_aKR :: MVar# RealWorld String)
+ (s0_aKS :: State# RealWorld) ->
+ case putMVar#
+ @Lifted
+ @RealWorld
+ @String
+ mvar_aKR
+ (unpackCString# "finalised!"#)
+ s0_aKS
+ of s1_aKT
+ { __DEFAULT ->
+ (# s1_aKT, GHC.Tuple.Prim.() #)
+ }
+
+-- RHS size: {terms: 2, types: 1, coercions: 0, joins: 0/0}
+$dShow_aUH :: Show [Char]
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=False, ConLike=True, WorkFree=False, Expandable=True,
+ Guidance=IF_ARGS [] 20 0}]
+$dShow_aUH = GHC.Show.$fShowList @Char GHC.Show.$fShowChar
+
+-- RHS size: {terms: 2, types: 2, coercions: 0, joins: 0/0}
+$dShow_aUy :: Show [String]
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=False, ConLike=True, WorkFree=False, Expandable=True,
+ Guidance=IF_ARGS [] 20 0}]
+$dShow_aUy = GHC.Show.$fShowList @[Char] $dShow_aUH
+
+-- RHS size: {terms: 50, types: 102, coercions: 0, joins: 0/0}
+inner
+ :: MVar# RealWorld String
+ -> MutVar# RealWorld Bool
+ -> State# RealWorld
+ -> (# State# RealWorld, Res #)
+[LclIdX,
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [0 0 0] 232 10}]
+inner
+ = \ (mvar_aKH :: MVar# RealWorld String)
+ (u_aKI :: MutVar# RealWorld Bool)
+ (s0_aKJ :: State# RealWorld) ->
+ case newByteArray# @RealWorld 42# s0_aKJ of ds_dVZ { __DEFAULT ->
+ case ds_dVZ of { (# s1_aKK, ba#_aKL #) ->
+ case mkWeak#
+ @Unlifted
+ @Unlifted
+ @(MutVar# RealWorld Bool)
+ @(MutableByteArray# RealWorld)
+ @()
+ u_aKI
+ ba#_aKL
+ (finalise mvar_aKH)
+ s1_aKK
+ of ds_dW1
+ { __DEFAULT ->
+ case ds_dW1 of { (# s2_aKM, wk_aKN #) ->
+ case deRefWeak#
+ @Unlifted @(MutableByteArray# RealWorld) wk_aKN s2_aKM
+ of ds_dW3
+ { __DEFAULT ->
+ case ds_dW3 of { (# s3_aKO, i_aKP, ba'#_aKQ #) ->
+ (# s3_aKO,
+ Main.Res
+ wk_aKN
+ (build
+ @String
+ (\ (@a_dW9)
+ (c_dWa [OS=OneShot] :: String -> a_dW9 -> a_dW9)
+ (n_dWb [OS=OneShot] :: a_dW9) ->
+ c_dWa
+ (show @Int GHC.Show.$fShowInt (GHC.Types.I# i_aKP))
+ (c_dWa
+ (show
+ @Int
+ GHC.Show.$fShowInt
+ (GHC.Types.I# (sizeofMutableByteArray# @RealWorld ba'#_aKQ)))
+ n_dWb))) #)
+ }
+ }
+ }
+ }
+ }
+ }
+
+-- RHS size: {terms: 76, types: 181, coercions: 25, joins: 0/0}
+main :: IO ()
+[LclIdX,
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=False, ConLike=False, WorkFree=False, Expandable=False,
+ Guidance=IF_ARGS [] 366 0}]
+main
+ = >>=
+ @IO
+ GHC.Base.$fMonadIO
+ @[String]
+ @()
+ ((\ (s0_aAn :: State# RealWorld) ->
+ case newMVar# @Lifted @RealWorld @String s0_aAn of ds_dWd
+ { __DEFAULT ->
+ case ds_dWd of { (# s1_aAo, mvar_aAp #) ->
+ case newMutVar# @Lifted @Bool @RealWorld GHC.Types.False s1_aAo
+ of ds_dWf
+ { __DEFAULT ->
+ case ds_dWf of { (# s2_aAq, val_var_aAr #) ->
+ case keepAlive#
+ @(TupleRep [ZeroBitRep, LiftedRep])
+ @Unlifted
+ @(MutVar# RealWorld Bool)
+ @RealWorld
+ @(# State# RealWorld, Res #)
+ ((CO: <TupleRep [ZeroBitRep, LiftedRep]>_N)
+ `cast` (Sub (Sym (AxSmallRep# (<TupleRep
+ [ZeroBitRep, LiftedRep]>_N)))
+ :: (TupleRep [ZeroBitRep, LiftedRep]
+ GHC.Prim.~# TupleRep [ZeroBitRep, LiftedRep])
+ ~R# GHC.Prim.SmallRep# (TupleRep [ZeroBitRep, LiftedRep])))
+ val_var_aAr
+ s2_aAq
+ (inner mvar_aAp val_var_aAr)
+ of ds_dWh
+ { __DEFAULT ->
+ case ds_dWh of { (# s3_aAs, ds_dWy #) ->
+ case ds_dWy of { Res wk_aAt strs_aAu ->
+ case unIO @() performGC s3_aAs of ds_dWk { __DEFAULT ->
+ case ds_dWk of { (# s4_aAw, _ [Occ=Dead] #) ->
+ case deRefWeak#
+ @Unlifted @(MutableByteArray# RealWorld) wk_aAt s4_aAw
+ of ds_dWn
+ { __DEFAULT ->
+ case ds_dWn of { (# s5_aAx, j_aAy, _ [Occ=Dead] #) ->
+ case takeMVar# @Lifted @RealWorld @String mvar_aAp s5_aAx of ds_dWq
+ { __DEFAULT ->
+ case ds_dWq of { (# s6_aAz, r_aAA #) ->
+ (# s6_aAz,
+ ++
+ @String
+ strs_aAu
+ (build
+ @String
+ (\ (@a_dWt)
+ (c_dWu [OS=OneShot] :: String -> a_dWt -> a_dWt)
+ (n_dWv [OS=OneShot] :: a_dWt) ->
+ c_dWu
+ (show @Int GHC.Show.$fShowInt (GHC.Types.I# j_aAy))
+ (c_dWu r_aAA n_dWv))) #)
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ })
+ `cast` (Sym (GHC.Types.N:IO[0] <[String]>_R)
+ :: (State# RealWorld -> (# State# RealWorld, [String] #))
+ ~R# IO [String]))
+ (\ (res_aHG :: [String]) -> print @[String] $dShow_aUy res_aHG)
+
+-- RHS size: {terms: 2, types: 1, coercions: 0, joins: 0/0}
+:Main.main :: IO ()
+[LclIdX,
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 20 60}]
+:Main.main = GHC.TopHandler.runMainIO @() main
+
+
=====================================
testsuite/tests/primops/should_run/UnliftedWeakPtr.dump-ds-preopt
=====================================
@@ -0,0 +1,212 @@
+
+==================== Desugar (before optimization) ====================
+2023-09-19 16:23:01.4144104 UTC
+
+Result size of Desugar (before optimization)
+ = {terms: 176, types: 382, coercions: 21, joins: 0/0}
+
+Rec {
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+$dShow_aUr :: Show Int
+[LclId]
+$dShow_aUr = $dShow_aT6
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+$dShow_aTc :: Show Int
+[LclId]
+$dShow_aTc = $dShow_aT6
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+$dShow_aT6 :: Show Int
+[LclId]
+$dShow_aT6 = GHC.Show.$fShowInt
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+$dMonad_aTr :: Monad IO
+[LclId]
+$dMonad_aTr = GHC.Base.$fMonadIO
+
+-- RHS size: {terms: 0, types: 0, coercions: 21, joins: 0/0}
+irred_aTT :: GHC.Prim.SmallRep# (TupleRep [ZeroBitRep, LiftedRep])
+[LclId]
+irred_aTT
+ = (CO: <TupleRep [ZeroBitRep, LiftedRep]>_N)
+ `cast` (Sub (Sym (AxSmallRep# (<TupleRep
+ [ZeroBitRep, LiftedRep]>_N)))
+ :: (TupleRep [ZeroBitRep, LiftedRep]
+ GHC.Prim.~# TupleRep [ZeroBitRep, LiftedRep])
+ ~R# GHC.Prim.SmallRep# (TupleRep [ZeroBitRep, LiftedRep]))
+
+-- RHS size: {terms: 2, types: 2, coercions: 0, joins: 0/0}
+$dShow_aUy :: Show [String]
+[LclId]
+$dShow_aUy = GHC.Show.$fShowList @[Char] $dShow_aUH
+
+-- RHS size: {terms: 2, types: 1, coercions: 0, joins: 0/0}
+$dShow_aUH :: Show [Char]
+[LclId]
+$dShow_aUH = GHC.Show.$fShowList @Char $dShow_aUI
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+$dShow_aUI :: Show Char
+[LclId]
+$dShow_aUI = GHC.Show.$fShowChar
+
+-- RHS size: {terms: 12, types: 16, coercions: 0, joins: 0/0}
+finalise
+ :: MVar# RealWorld String
+ -> State# RealWorld -> (# State# RealWorld, () #)
+[LclIdX]
+finalise
+ = \ (mvar_aKR :: MVar# RealWorld String)
+ (s0_aKS :: State# RealWorld) ->
+ case putMVar#
+ @Lifted
+ @RealWorld
+ @String
+ mvar_aKR
+ (unpackCString# "finalised!"#)
+ s0_aKS
+ of s1_aKT
+ { __DEFAULT ->
+ (# s1_aKT, GHC.Tuple.Prim.() #)
+ }
+
+-- RHS size: {terms: 58, types: 110, coercions: 0, joins: 0/0}
+inner
+ :: MVar# RealWorld String
+ -> MutVar# RealWorld Bool
+ -> State# RealWorld
+ -> (# State# RealWorld, Res #)
+[LclIdX]
+inner
+ = \ (mvar_aKH :: MVar# RealWorld String)
+ (u_aKI :: MutVar# RealWorld Bool)
+ (s0_aKJ :: State# RealWorld) ->
+ case newByteArray# @RealWorld 42# s0_aKJ of ds_dVZ { __DEFAULT ->
+ case ds_dVZ of wild_00 { (# s1_aKK, ba#_aKL #) ->
+ case mkWeak#
+ @Unlifted
+ @Unlifted
+ @(MutVar# RealWorld Bool)
+ @(MutableByteArray# RealWorld)
+ @()
+ u_aKI
+ ba#_aKL
+ (finalise mvar_aKH)
+ s1_aKK
+ of ds_dW1
+ { __DEFAULT ->
+ case ds_dW1 of wild_00 { (# s2_aKM, wk_aKN #) ->
+ case deRefWeak#
+ @Unlifted @(MutableByteArray# RealWorld) wk_aKN s2_aKM
+ of ds_dW3
+ { __DEFAULT ->
+ case ds_dW3 of wild_00 { (# s3_aKO, i_aKP, ba'#_aKQ #) ->
+ (# s3_aKO,
+ (\ (ds_dW5 :: Weak# (MutableByteArray# RealWorld))
+ (ds_dW6 :: [String]) ->
+ Main.Res ds_dW5 ds_dW6)
+ wk_aKN
+ (build
+ @String
+ (\ (@a_dW9) (c_dWa :: String -> a_dW9 -> a_dW9) (n_dWb :: a_dW9) ->
+ c_dWa
+ (show
+ @Int
+ $dShow_aT6
+ ((\ (ds_dW7 :: Int#) -> GHC.Types.I# ds_dW7) i_aKP))
+ (c_dWa
+ (show
+ @Int
+ $dShow_aTc
+ ((\ (ds_dW8 :: Int#) -> GHC.Types.I# ds_dW8)
+ (sizeofMutableByteArray# @RealWorld ba'#_aKQ)))
+ n_dWb))) #)
+ }
+ }
+ }
+ }
+ }
+ }
+
+-- RHS size: {terms: 83, types: 194, coercions: 0, joins: 0/0}
+main :: IO ()
+[LclIdX]
+main
+ = >>=
+ @IO
+ $dMonad_aTr
+ @[String]
+ @()
+ ((\ (@a_aAl)
+ (ds_dWc :: State# RealWorld -> (# State# RealWorld, a_aAl #)) ->
+ GHC.Types.IO @a_aAl ds_dWc)
+ @[String]
+ (\ (s0_aAn :: State# RealWorld) ->
+ case newMVar# @Lifted @RealWorld @String s0_aAn of ds_dWd
+ { __DEFAULT ->
+ case ds_dWd of wild_00 { (# s1_aAo, mvar_aAp #) ->
+ case newMutVar# @Lifted @Bool @RealWorld GHC.Types.False s1_aAo
+ of ds_dWf
+ { __DEFAULT ->
+ case ds_dWf of wild_00 { (# s2_aAq, val_var_aAr #) ->
+ case keepAlive#
+ @(TupleRep [ZeroBitRep, LiftedRep])
+ @Unlifted
+ @(MutVar# RealWorld Bool)
+ @RealWorld
+ @(# State# RealWorld, Res #)
+ irred_aTT
+ val_var_aAr
+ s2_aAq
+ (inner mvar_aAp val_var_aAr)
+ of ds_dWh
+ { __DEFAULT ->
+ case ds_dWh of wild_00 { (# s3_aAs, ds_dWy #) ->
+ case ds_dWy of wild_00 { Res wk_aAt strs_aAu ->
+ case unIO @() performGC s3_aAs of ds_dWk { __DEFAULT ->
+ case ds_dWk of wild_00 { (# s4_aAw, ds_dWx #) ->
+ case deRefWeak#
+ @Unlifted @(MutableByteArray# RealWorld) wk_aAt s4_aAw
+ of ds_dWn
+ { __DEFAULT ->
+ case ds_dWn of wild_00 { (# s5_aAx, j_aAy, ds_dWw #) ->
+ case takeMVar# @Lifted @RealWorld @String mvar_aAp s5_aAx of ds_dWq
+ { __DEFAULT ->
+ case ds_dWq of wild_00 { (# s6_aAz, r_aAA #) ->
+ (# s6_aAz,
+ ++
+ @String
+ strs_aAu
+ (build
+ @String
+ (\ (@a_dWt) (c_dWu :: String -> a_dWt -> a_dWt) (n_dWv :: a_dWt) ->
+ c_dWu
+ (show
+ @Int
+ $dShow_aUr
+ ((\ (ds_dWs :: Int#) -> GHC.Types.I# ds_dWs) j_aAy))
+ (c_dWu r_aAA n_dWv))) #)
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }))
+ (\ (res_aHG :: [String]) -> print @[String] $dShow_aUy res_aHG)
+
+-- RHS size: {terms: 2, types: 1, coercions: 0, joins: 0/0}
+:Main.main :: IO ()
+[LclIdX]
+:Main.main = GHC.TopHandler.runMainIO @() main
+end Rec }
+
+
=====================================
testsuite/tests/primops/should_run/UnliftedWeakPtr.dump-stg-final
=====================================
@@ -0,0 +1,175 @@
+
+==================== Final STG: ====================
+2023-09-19 16:23:01.5732892 UTC
+
+Main.finalise2 :: GHC.Prim.Addr#
+[GblId, Unf=OtherCon []] =
+ "finalised!"#;
+
+Main.finalise1 :: [GHC.Types.Char]
+[GblId] =
+ {} \u [] GHC.CString.unpackCString# Main.finalise2;
+
+Main.finalise
+ :: GHC.Prim.MVar# GHC.Prim.RealWorld GHC.Base.String
+ -> GHC.Prim.State# GHC.Prim.RealWorld
+ -> (# GHC.Prim.State# GHC.Prim.RealWorld, () #)
+[GblId, Arity=2, Str=<L><L>, Cpr=1(, 1), Unf=OtherCon []] =
+ {} \r [mvar_s1xt void_0E]
+ case
+ putMVar# [mvar_s1xt Main.finalise1 GHC.Prim.void#]
+ of
+ s1_s1xv [Occ=Once1]
+ {
+ (##) -> Solo# [GHC.Tuple.Prim.()];
+ };
+
+Main.inner [InlPrag=[2]]
+ :: GHC.Prim.MVar# GHC.Prim.RealWorld GHC.Base.String
+ -> GHC.Prim.MutVar# GHC.Prim.RealWorld GHC.Types.Bool
+ -> GHC.Prim.State# GHC.Prim.RealWorld
+ -> (# GHC.Prim.State# GHC.Prim.RealWorld, Main.Res #)
+[GblId, Arity=3, Str=<L><L><L>, Cpr=1(, 1), Unf=OtherCon []] =
+ {} \r [mvar_s1xw u_s1xx void_0E]
+ case newByteArray# [42# GHC.Prim.void#] of {
+ Solo# ipv1_s1xB [Occ=Once1] ->
+ let {
+ sat_s1xE [Occ=Once1]
+ :: GHC.Prim.State# GHC.Prim.RealWorld
+ -> (# GHC.Prim.State# GHC.Prim.RealWorld, () #)
+ [LclId] =
+ {mvar_s1xw} \r [void_XF]
+ case
+ putMVar# [mvar_s1xw Main.finalise1 GHC.Prim.void#]
+ of
+ s2_s1xD [Occ=Once1]
+ {
+ (##) -> Solo# [GHC.Tuple.Prim.()];
+ };
+ } in
+ case mkWeak# [u_s1xx ipv1_s1xB sat_s1xE GHC.Prim.void#] of {
+ Solo# ipv3_s1xH ->
+ case deRefWeak# [ipv3_s1xH GHC.Prim.void#] of {
+ (#,#) ipv5_s1xK [Occ=Once1] ipv6_s1xL [Occ=Once1] ->
+ let {
+ sat_s1xO [Occ=Once1] :: GHC.Base.String
+ [LclId] =
+ {ipv6_s1xL} \u []
+ case sizeofMutableByteArray# [ipv6_s1xL] of sat_s1xN [Occ=Once1] {
+ __DEFAULT -> GHC.Show.itos sat_s1xN GHC.Types.[];
+ }; } in
+ let {
+ sat_s1xP [Occ=Once1] :: [GHC.Base.String]
+ [LclId] =
+ :! [sat_s1xO GHC.Types.[]]; } in
+ let {
+ sat_s1xM [Occ=Once1] :: GHC.Base.String
+ [LclId] =
+ {ipv5_s1xK} \u [] GHC.Show.itos ipv5_s1xK GHC.Types.[]; } in
+ let {
+ sat_s1xQ [Occ=Once1] :: [GHC.Base.String]
+ [LclId] =
+ :! [sat_s1xM sat_s1xP]; } in
+ let {
+ sat_s1xR [Occ=Once1] :: Main.Res
+ [LclId] =
+ Main.Res! [ipv3_s1xH sat_s1xQ];
+ } in Solo# [sat_s1xR];
+ };
+ };
+ };
+
+Main.main1
+ :: GHC.Prim.State# GHC.Prim.RealWorld
+ -> (# GHC.Prim.State# GHC.Prim.RealWorld, () #)
+[GblId, Arity=1, Str=<L>, Unf=OtherCon []] =
+ {} \r [void_0E]
+ case newMVar# [GHC.Prim.void#] of {
+ Solo# ipv1_s1xV ->
+ case newMutVar# [GHC.Types.False GHC.Prim.void#] of {
+ Solo# ipv3_s1xY ->
+ let {
+ sat_s1xZ [Occ=Once1]
+ :: GHC.Prim.State# GHC.Prim.RealWorld
+ -> (# GHC.Prim.State# GHC.Prim.RealWorld, Main.Res #)
+ [LclId] =
+ {ipv1_s1xV, ipv3_s1xY} \r [void_XF]
+ Main.inner ipv1_s1xV ipv3_s1xY GHC.Prim.void#;
+ } in
+ case
+ keepAlive# [GHC.Prim.coercionToken#
+ ipv3_s1xY
+ GHC.Prim.void#
+ sat_s1xZ]
+ of
+ {
+ Solo# ipv5_s1y2 [Occ=Once1!] ->
+ case ipv5_s1y2 of {
+ Main.Res wk_s1y4 [Occ=Once1] strs_s1y5 [Occ=Once1] ->
+ case
+ __ffi_static_ccall_safe base:performMajorGC :: [GHC.Prim.void#]
+ of
+ {
+ (##) ->
+ case deRefWeak# [wk_s1y4 GHC.Prim.void#] of {
+ (#,#) ipv7_s1yb [Occ=Once1] _ [Occ=Dead] ->
+ case takeMVar# [ipv1_s1xV GHC.Prim.void#] of {
+ Solo# ipv10_s1yf [Occ=Once1] ->
+ let {
+ sat_s1yk [Occ=Once1] :: GHC.Base.String
+ [LclId] =
+ {strs_s1y5, ipv7_s1yb, ipv10_s1yf} \u []
+ let {
+ sat_s1yh [Occ=Once1] :: [[GHC.Types.Char]]
+ [LclId] =
+ :! [ipv10_s1yf GHC.Types.[]]; } in
+ let {
+ sat_s1yg [Occ=Once1] :: GHC.Base.String
+ [LclId] =
+ {ipv7_s1yb} \u [] GHC.Show.itos ipv7_s1yb GHC.Types.[]; } in
+ let {
+ sat_s1yi [Occ=Once1] :: [[GHC.Types.Char]]
+ [LclId] =
+ :! [sat_s1yg sat_s1yh];
+ } in
+ case GHC.Base.++ strs_s1y5 sat_s1yi of sat_s1yj [Occ=Once1] {
+ __DEFAULT ->
+ GHC.Show.showList__
+ GHC.Show.$fShowCallStack_$cshowList1 sat_s1yj GHC.Types.[];
+ };
+ } in
+ GHC.IO.Handle.Text.hPutStr2
+ GHC.IO.StdHandles.stdout sat_s1yk GHC.Types.True GHC.Prim.void#;
+ };
+ };
+ };
+ };
+ };
+ };
+ };
+
+Main.main :: GHC.Types.IO ()
+[GblId, Arity=1, Str=<L>, Unf=OtherCon []] =
+ {} \r [void_0E] Main.main1 GHC.Prim.void#;
+
+Main.main2
+ :: GHC.Prim.State# GHC.Prim.RealWorld
+ -> (# GHC.Prim.State# GHC.Prim.RealWorld, () #)
+[GblId, Arity=1, Str=<L>, Unf=OtherCon []] =
+ {} \r [void_0E]
+ GHC.TopHandler.runMainIO1 Main.main1 GHC.Prim.void#;
+
+:Main.main :: GHC.Types.IO ()
+[GblId, Arity=1, Str=<L>, Unf=OtherCon []] =
+ {} \r [void_0E] Main.main2 GHC.Prim.void#;
+
+Main.Res [InlPrag=CONLIKE]
+ :: GHC.Prim.Weak# (GHC.Prim.MutableByteArray# GHC.Prim.RealWorld)
+ %1 -> [GHC.Base.String] %1 -> Main.Res
+[GblId[DataCon], Arity=2, Caf=NoCafRefs, Unf=OtherCon []] =
+ {} \r [eta_B0 eta_B1] Main.Res [eta_B0 eta_B1];
+
+Main.U [InlPrag=CONLIKE] :: GHC.Prim.Int# %1 -> Main.U
+[GblId[DataCon], Arity=1, Caf=NoCafRefs, Unf=OtherCon []] =
+ {} \r [eta_B0] Main.U [eta_B0];
+
=====================================
testsuite/tests/primops/should_run/all.T
=====================================
@@ -61,12 +61,16 @@ test('UnliftedWeakPtr', normal, compile_and_run, [''])
test('FMA_Primops'
, [ when(have_cpu_feature('fma'), extra_hc_opts('-mfma'))
, js_skip # JS backend doesn't have an FMA implementation
+ , when(arch('wasm32'), skip)
+ , when(have_llvm(), extra_ways(["optllvm"]))
]
, compile_and_run, [''])
test('FMA_ConstantFold'
- , [ js_skip # JS backend doesn't have an FMA implementation ]
+ , [ when(have_cpu_feature('fma'), extra_hc_opts('-mfma'))
+ , js_skip # JS backend doesn't have an FMA implementation
+ , when(arch('wasm32'), skip)
, expect_broken(21227)
- , omit_ghci # fails during compilation phase, remove after !10563
+ , when(have_llvm(), extra_ways(["optllvm"]))
]
, compile_and_run, ['-O'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a40f4ab21bcc088e63892cd5e85edbec20d3fc69
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a40f4ab21bcc088e63892cd5e85edbec20d3fc69
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240124/c3f7b15a/attachment-0001.html>
More information about the ghc-commits
mailing list