[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: Fix FMA instruction on LLVM

Marge Bot (@marge-bot) gitlab at gitlab.haskell.org
Wed Jan 24 23:37:50 UTC 2024



Marge Bot pushed to branch wip/marge_bot_batch_merge_job 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

- - - - -
69abc786 by Andrei Borzenkov at 2024-01-24T14:05:09-05:00
Add changelog entry for renaming tuples from (,,...,,) to Tuple<n> (24291)

- - - - -
590a883b by Cheng Shao at 2024-01-24T18:37:33-05:00
compiler: remove unused GHC.Linker module

The GHC.Linker module is empty and unused, other than as a hack for
the make build system. We can remove it now that make is long gone;
the note is moved to GHC.Linker.Loader instead.

- - - - -
33b9eb0a by Hécate Moonlight at 2024-01-24T18:37:39-05:00
Clarification for newtype constructors when using `coerce`

- - - - -


18 changed files:

- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/CmmToLlvm/CodeGen.hs
- − compiler/GHC/Linker.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Llvm/Ppr.hs
- compiler/GHC/Llvm/Syntax.hs
- compiler/ghc.cabal.in
- docs/users_guide/9.8.1-notes.rst
- libraries/base/changelog.md
- libraries/ghc-prim/changelog.md
- + 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/Builtin/primops.txt.pp
=====================================
@@ -3955,10 +3955,25 @@ pseudoop   "coerce"
      more complicated settings, e.g. converting a list of newtypes to a list of
      concrete types.
 
+     When used in conversions involving a newtype wrapper,
+     make sure the newtype constructor is in scope.
+
      This function is representation-polymorphic, but the
      'RuntimeRep' type argument is marked as 'Inferred', meaning
      that it is not available for visible type application. This means
      the typechecker will accept @'coerce' \@'Int' \@Age 42 at .
+
+     === __Examples__
+
+     >>> newtype TTL = TTL Int deriving (Eq, Ord, Show)
+     >>> newtype Age = Age Int deriving (Eq, Ord, Show)
+     >>> coerce (Age 42) :: TTL
+     TTL 42
+     >>> coerce (+ (1 :: Int)) (Age 42) :: TTL
+     TTL 43
+     >>> coerce (map (+ (1 :: Int))) [Age 42, Age 24] :: [TTL]
+     [TTL 43,TTL 25]
+
    }
 
 ------------------------------------------------------------------------


=====================================
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/Linker.hs deleted
=====================================
@@ -1,36 +0,0 @@
-module GHC.Linker
-   (
-   )
-where
-
-import GHC.Prelude ()
-   -- We need this dummy dependency for the make build system. Otherwise it
-   -- tries to load GHC.Types which may not be built yet.
-
--- Note [Linkers and loaders]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~
---
--- Linkers are used to produce linked objects (.so, executables); loaders are
--- used to link in memory (e.g., in GHCi) with the already loaded libraries
--- (ghc-lib, rts, etc.).
---
--- Linking can usually be done with an external linker program ("ld"), but
--- loading is more tricky:
---
---    * Fully dynamic:
---       when GHC is built as a set of dynamic libraries (ghc-lib, rts, etc.)
---       and the modules to load are also compiled for dynamic linking, a
---       solution is to fully rely on external tools:
---
---       1) link a .so with the external linker
---       2) load the .so with POSIX's "dlopen"
---
---    * When GHC is built as a static program or when libraries we want to load
---    aren't compiled for dynamic linking, GHC uses its own loader ("runtime
---    linker"). The runtime linker is part of the rts (rts/Linker.c).
---
--- Note that within GHC's codebase we often use the word "linker" to refer to
--- the static object loader in the runtime system.
---
--- Loading can be delegated to an external interpreter ("iserv") when
--- -fexternal-interpreter is used.


=====================================
compiler/GHC/Linker/Loader.hs
=====================================
@@ -109,6 +109,34 @@ import System.Win32.Info (getSystemDirectory)
 
 import GHC.Utils.Exception
 
+-- Note [Linkers and loaders]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- Linkers are used to produce linked objects (.so, executables); loaders are
+-- used to link in memory (e.g., in GHCi) with the already loaded libraries
+-- (ghc-lib, rts, etc.).
+--
+-- Linking can usually be done with an external linker program ("ld"), but
+-- loading is more tricky:
+--
+--    * Fully dynamic:
+--       when GHC is built as a set of dynamic libraries (ghc-lib, rts, etc.)
+--       and the modules to load are also compiled for dynamic linking, a
+--       solution is to fully rely on external tools:
+--
+--       1) link a .so with the external linker
+--       2) load the .so with POSIX's "dlopen"
+--
+--    * When GHC is built as a static program or when libraries we want to load
+--    aren't compiled for dynamic linking, GHC uses its own loader ("runtime
+--    linker"). The runtime linker is part of the rts (rts/Linker.c).
+--
+-- Note that within GHC's codebase we often use the word "linker" to refer to
+-- the static object loader in the runtime system.
+--
+-- Loading can be delegated to an external interpreter ("iserv") when
+-- -fexternal-interpreter is used.
+
 uninitialised :: a
 uninitialised = panic "Loader not initialised"
 


=====================================
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.
   -}


=====================================
compiler/ghc.cabal.in
=====================================
@@ -580,7 +580,6 @@ Library
         GHC.JS.JStg.Syntax
         GHC.JS.JStg.Monad
         GHC.JS.Transform
-        GHC.Linker
         GHC.Linker.Config
         GHC.Linker.Deps
         GHC.Linker.Dynamic


=====================================
docs/users_guide/9.8.1-notes.rst
=====================================
@@ -39,6 +39,26 @@ Language
 
     type instance forall j . F1 Int = Any :: j -> j
 
+- GHC proposal `#475 <https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0475-tuple-syntax.rst>`_
+  has been partially implemented. Namely, tuple data types, which were previously represented using a brackets-with-commas
+  syntax form ((), (,), (,,), and so on) have been renamed to common names of the form ``Unit``, ``Tuple2``, ``Tuple3``,
+  and so on, where the number after ``Tuple`` indicates its arity: ::
+
+    data Unit = ()
+
+    data Tuple2 a b = (a,b)
+    data Tuple3 a b c = (a, b, c)
+    -- and so on, up to Tuple64
+
+  For consistency, we also introduce type aliases: ::
+
+    type Tuple0 = Unit
+    type Tuple1 = Solo
+
+  The renamed tuple data types and the new type aliases can be found in the ``GHC.Tuple`` module. This renaming
+  does not break existing code that directly uses tuple data types, but it does affect tools and libraries
+  that have access to the data type names, such as ``Generic`` and Template Haskell.
+
 Compiler
 ~~~~~~~~
 


=====================================
libraries/base/changelog.md
=====================================
@@ -73,6 +73,7 @@
   * Make `Semigroup`'s `stimes` specializable. ([CLC proposal #8](https://github.com/haskell/core-libraries-committee/issues/8))
   * Implement `copyBytes`, `fillBytes`, `moveBytes` and `stimes` for `Data.Array.Byte.ByteArray` using primops ([CLC proposal #188](https://github.com/haskell/core-libraries-committee/issues/188))
   * Add rewrite rules for conversion between `Int64` / `Word64` and `Float` / `Double` on 64-bit architectures ([CLC proposal #203](https://github.com/haskell/core-libraries-committee/issues/203)).
+  * `Generic` instances for tuples now expose `Unit`, `Tuple2`, `Tuple3`, ..., `Tuple64` as the actual names for tuple type constructors ([GHC proposal #475](https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0475-tuple-syntax.rst)).
 
 ## 4.18.0.0 *March 2023*
   * Shipped with GHC 9.6.1


=====================================
libraries/ghc-prim/changelog.md
=====================================
@@ -113,6 +113,10 @@
 
 - `Unit`, `Tuple0`, `Tuple1`, `Tuple2`, `Tuple3` and so on (up to `Tuple64`)
   are now exported from `GHC.Tuple.Prim` and reexported from `GHC.Tuple`.
+  GHC now uses these as the actual names for tuple data types. As a result,
+  the "brackets with commas" syntax (e.g. `()`, `(,)`, etc.) now becomes just
+  an alias to these names. This change may affect tools and libraries that
+  rely on type names, such as `Generic` and Template Haskell.
 
 ## 0.10.0
 


=====================================
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/-/compare/dd905e9864f11dea26f68e620752a4f292e29bfd...33b9eb0a851ec37d31a7ba717f7b33c28156fd72

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/dd905e9864f11dea26f68e620752a4f292e29bfd...33b9eb0a851ec37d31a7ba717f7b33c28156fd72
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/80d1144b/attachment-0001.html>


More information about the ghc-commits mailing list