[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: rts: fix small argument passing on big-endian arch (fix #23387)

Marge Bot (@marge-bot) gitlab at gitlab.haskell.org
Thu Oct 19 20:30:06 UTC 2023



Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC


Commits:
31f95f01 by Sylvain Henry at 2023-10-19T16:29:51-04:00
rts: fix small argument passing on big-endian arch (fix #23387)

- - - - -
e23f5272 by Sylvain Henry at 2023-10-19T16:29:54-04:00
Interpreter: fix literal alignment on big-endian architectures (fix #19261)

Literals weren't correctly aligned on big-endian, despite what the
comment said.

- - - - -
8fc371ce by Sylvain Henry at 2023-10-19T16:29:57-04:00
Testsuite: recomp011 and recomp015 are fixed on powerpc

These tests have been fixed but not tested and re-enabled on big-endian
powerpc (see comments in #11260 and #11323)

- - - - -
cf285d80 by Sebastian Graf at 2023-10-19T16:29:58-04:00
CorePrep: Allow floating dictionary applications in -O0 into a Rec (#24102)
- - - - -


5 changed files:

- compiler/GHC/ByteCode/Asm.hs
- compiler/GHC/CoreToStg/Prep.hs
- rts/Interpreter.c
- testsuite/tests/driver/recomp011/all.T
- testsuite/tests/driver/recomp015/all.T


Changes:

=====================================
compiler/GHC/ByteCode/Asm.hs
=====================================
@@ -43,23 +43,19 @@ import GHC.Platform
 import GHC.Platform.Profile
 
 import Control.Monad
-import Control.Monad.ST ( runST )
 import Control.Monad.Trans.Class
 import Control.Monad.Trans.State.Strict
 
-import Data.Array.MArray
-
 import qualified Data.Array.Unboxed as Array
 import Data.Array.Base  ( UArray(..) )
 
-import Data.Array.Unsafe( castSTUArray )
-
 import Foreign hiding (shiftL, shiftR)
 import Data.Char        ( ord )
 import Data.List        ( genericLength )
 import Data.Map.Strict (Map)
 import Data.Maybe (fromMaybe)
 import qualified Data.Map.Strict as Map
+import GHC.Float (castFloatToWord32, castDoubleToWord64)
 
 -- -----------------------------------------------------------------------------
 -- Unlinked BCOs
@@ -416,7 +412,7 @@ assembleI platform i = case i of
                                                                 tuple_proto
                                  p <- ioptr (liftM BCOPtrBCO ul_bco)
                                  p_tup <- ioptr (liftM BCOPtrBCO ul_tuple_bco)
-                                 info <- int (fromIntegral $
+                                 info <- word (fromIntegral $
                                               mkNativeCallInfoSig platform call_info)
                                  emit bci_PUSH_ALTS_T
                                       [Op p, Op info, Op p_tup]
@@ -466,21 +462,21 @@ assembleI platform i = case i of
                                  emit bci_TESTLT_W [Op np, LabelOp l]
   TESTEQ_W  w l            -> do np <- word w
                                  emit bci_TESTEQ_W [Op np, LabelOp l]
-  TESTLT_I64  i l          -> do np <- int64 i
+  TESTLT_I64  i l          -> do np <- word64 (fromIntegral i)
                                  emit bci_TESTLT_I64 [Op np, LabelOp l]
-  TESTEQ_I64  i l          -> do np <- int64 i
+  TESTEQ_I64  i l          -> do np <- word64 (fromIntegral i)
                                  emit bci_TESTEQ_I64 [Op np, LabelOp l]
-  TESTLT_I32  i l          -> do np <- int (fromIntegral i)
+  TESTLT_I32  i l          -> do np <- word (fromIntegral i)
                                  emit bci_TESTLT_I32 [Op np, LabelOp l]
-  TESTEQ_I32 i l           -> do np <- int (fromIntegral i)
+  TESTEQ_I32 i l           -> do np <- word (fromIntegral i)
                                  emit bci_TESTEQ_I32 [Op np, LabelOp l]
-  TESTLT_I16  i l          -> do np <- int (fromIntegral i)
+  TESTLT_I16  i l          -> do np <- word (fromIntegral i)
                                  emit bci_TESTLT_I16 [Op np, LabelOp l]
-  TESTEQ_I16 i l           -> do np <- int (fromIntegral i)
+  TESTEQ_I16 i l           -> do np <- word (fromIntegral i)
                                  emit bci_TESTEQ_I16 [Op np, LabelOp l]
-  TESTLT_I8  i l           -> do np <- int (fromIntegral i)
+  TESTLT_I8  i l           -> do np <- word (fromIntegral i)
                                  emit bci_TESTLT_I8 [Op np, LabelOp l]
-  TESTEQ_I8 i l            -> do np <- int (fromIntegral i)
+  TESTEQ_I8 i l            -> do np <- word (fromIntegral i)
                                  emit bci_TESTEQ_I8 [Op np, LabelOp l]
   TESTLT_W64  w l          -> do np <- word64 w
                                  emit bci_TESTLT_W64 [Op np, LabelOp l]
@@ -530,42 +526,80 @@ assembleI platform i = case i of
      -- On Windows, stdcall labels have a suffix indicating the no. of
      -- arg words, e.g. foo at 8.  testcase: ffi012(ghci)
     literal (LitLabel fs _ _) = litlabel fs
-    literal LitNullAddr       = int 0
+    literal LitNullAddr       = word 0
     literal (LitFloat r)      = float (fromRational r)
     literal (LitDouble r)     = double (fromRational r)
     literal (LitChar c)       = int (ord c)
     literal (LitString bs)    = lit [BCONPtrStr bs]
        -- LitString requires a zero-terminator when emitted
     literal (LitNumber nt i) = case nt of
-      LitNumInt     -> int (fromIntegral i)
-      LitNumWord    -> int (fromIntegral i)
-      LitNumInt8    -> int8 (fromIntegral i)
-      LitNumWord8   -> int8 (fromIntegral i)
-      LitNumInt16   -> int16 (fromIntegral i)
-      LitNumWord16  -> int16 (fromIntegral i)
-      LitNumInt32   -> int32 (fromIntegral i)
-      LitNumWord32  -> int32 (fromIntegral i)
-      LitNumInt64   -> int64 (fromIntegral i)
-      LitNumWord64  -> int64 (fromIntegral i)
+      LitNumInt     -> word (fromIntegral i)
+      LitNumWord    -> word (fromIntegral i)
+      LitNumInt8    -> word8 (fromIntegral i)
+      LitNumWord8   -> word8 (fromIntegral i)
+      LitNumInt16   -> word16 (fromIntegral i)
+      LitNumWord16  -> word16 (fromIntegral i)
+      LitNumInt32   -> word32 (fromIntegral i)
+      LitNumWord32  -> word32 (fromIntegral i)
+      LitNumInt64   -> word64 (fromIntegral i)
+      LitNumWord64  -> word64 (fromIntegral i)
       LitNumBigNat  -> panic "GHC.ByteCode.Asm.literal: LitNumBigNat"
 
     -- We can lower 'LitRubbish' to an arbitrary constant, but @NULL@ is most
     -- likely to elicit a crash (rather than corrupt memory) in case absence
     -- analysis messed up.
-    literal (LitRubbish {}) = int 0
+    literal (LitRubbish {}) = word 0
 
     litlabel fs = lit [BCONPtrLbl fs]
     addr (RemotePtr a) = words [fromIntegral a]
-    float = words . mkLitF platform
-    double = words . mkLitD platform
-    int = words . mkLitI
-    int8 = words . mkLitI64 platform
-    int16 = words . mkLitI64 platform
-    int32 = words . mkLitI64 platform
-    int64 = words . mkLitI64 platform
-    word64 = words . mkLitW64 platform
     words ws = lit (map BCONPtrWord ws)
     word w = words [w]
+    word_size  = platformWordSize platform
+    word_size_bits = platformWordSizeInBits platform
+
+    -- Make lists of host-sized words for literals, so that when the
+    -- words are placed in memory at increasing addresses, the
+    -- bit pattern is correct for the host's word size and endianness.
+    --
+    -- Note that we only support host endianness == target endianness for now,
+    -- even with the external interpreter. This would need to be fixed to
+    -- support host endianness /= target endianness
+    int :: Int -> Assembler Word
+    int  i = word (fromIntegral i)
+
+    float :: Float -> Assembler Word
+    float f = word32 (castFloatToWord32 f)
+
+    double :: Double -> Assembler Word
+    double d = word64 (castDoubleToWord64 d)
+
+    word64 :: Word64 -> Assembler Word
+    word64 ww = case word_size of
+       PW4 ->
+        let !wl = fromIntegral ww
+            !wh = fromIntegral (ww `unsafeShiftR` 32)
+        in case platformByteOrder platform of
+            LittleEndian -> words [wl,wh]
+            BigEndian    -> words [wh,wl]
+       PW8 -> word (fromIntegral ww)
+
+    word8 :: Word8 -> Assembler Word
+    word8  x = case platformByteOrder platform of
+      LittleEndian -> word (fromIntegral x)
+      BigEndian    -> word (fromIntegral x `unsafeShiftL` (word_size_bits - 8))
+
+    word16 :: Word16 -> Assembler Word
+    word16 x = case platformByteOrder platform of
+      LittleEndian -> word (fromIntegral x)
+      BigEndian    -> word (fromIntegral x `unsafeShiftL` (word_size_bits - 16))
+
+    word32 :: Word32 -> Assembler Word
+    word32 x = case platformByteOrder platform of
+      LittleEndian -> word (fromIntegral x)
+      BigEndian    -> case word_size of
+        PW4 -> word (fromIntegral x)
+        PW8 -> word (fromIntegral x `unsafeShiftL` 32)
+
 
 isLargeW :: Word -> Bool
 isLargeW n = n > 65535
@@ -648,74 +682,5 @@ mkNativeCallInfoLit :: Platform -> NativeCallInfo -> Literal
 mkNativeCallInfoLit platform call_info =
   mkLitWord platform . fromIntegral $ mkNativeCallInfoSig platform call_info
 
--- Make lists of host-sized words for literals, so that when the
--- words are placed in memory at increasing addresses, the
--- bit pattern is correct for the host's word size and endianness.
-mkLitI   ::             Int    -> [Word]
-mkLitF   :: Platform -> Float  -> [Word]
-mkLitD   :: Platform -> Double -> [Word]
-mkLitI64 :: Platform -> Int64  -> [Word]
-mkLitW64 :: Platform -> Word64 -> [Word]
-
-mkLitF platform f = case platformWordSize platform of
-  PW4 -> runST $ do
-        arr <- newArray_ ((0::Int),0)
-        writeArray arr 0 f
-        f_arr <- castSTUArray arr
-        w0 <- readArray f_arr 0
-        return [w0 :: Word]
-
-  PW8 -> runST $ do
-        arr <- newArray_ ((0::Int),1)
-        writeArray arr 0 f
-        -- on 64-bit architectures we read two (32-bit) Float cells when we read
-        -- a (64-bit) Word: so we write a dummy value in the second cell to
-        -- avoid an out-of-bound read.
-        writeArray arr 1 0.0
-        f_arr <- castSTUArray arr
-        w0 <- readArray f_arr 0
-        return [w0 :: Word]
-
-mkLitD platform d = case platformWordSize platform of
-   PW4 -> runST (do
-        arr <- newArray_ ((0::Int),1)
-        writeArray arr 0 d
-        d_arr <- castSTUArray arr
-        w0 <- readArray d_arr 0
-        w1 <- readArray d_arr 1
-        return [w0 :: Word, w1]
-     )
-   PW8 -> runST (do
-        arr <- newArray_ ((0::Int),0)
-        writeArray arr 0 d
-        d_arr <- castSTUArray arr
-        w0 <- readArray d_arr 0
-        return [w0 :: Word]
-     )
-
-mkLitI64 platform ii = case platformWordSize platform of
-   PW4 -> runST (do
-        arr <- newArray_ ((0::Int),1)
-        writeArray arr 0 ii
-        d_arr <- castSTUArray arr
-        w0 <- readArray d_arr 0
-        w1 <- readArray d_arr 1
-        return [w0 :: Word,w1]
-     )
-   PW8 -> [fromIntegral ii :: Word]
-
-mkLitW64 platform ww = case platformWordSize platform of
-   PW4 -> runST (do
-        arr <- newArray_ ((0::Word),1)
-        writeArray arr 0 ww
-        d_arr <- castSTUArray arr
-        w0 <- readArray d_arr 0
-        w1 <- readArray d_arr 1
-        return [w0 :: Word,w1]
-     )
-   PW8 -> [fromIntegral ww :: Word]
-
-mkLitI i = [fromIntegral i :: Word]
-
 iNTERP_STACK_CHECK_THRESH :: Int
 iNTERP_STACK_CHECK_THRESH = INTERP_STACK_CHECK_THRESH


=====================================
compiler/GHC/CoreToStg/Prep.hs
=====================================
@@ -643,13 +643,20 @@ cpeBind top_lvl env (Rec pairs)
   where
     (bndrs, rhss) = unzip pairs
 
-        -- Flatten all the floats, and the current
-        -- group into a single giant Rec
+    -- Flatten all the floats, and the current
+    -- group into a single giant Rec
     add_float (Float bind bound _) prs2
-      | bound /= CaseBound = case bind of
+      | bound /= CaseBound
+      || all (definitelyLiftedType . idType) (bindersOf bind)
+           -- The latter check is hit in -O0 (i.e., flavours quick, devel2)
+           -- for dictionary args which haven't been floated out yet, #24102.
+           -- They are preferably CaseBound, but since they are lifted we may
+           -- just as well put them in the Rec, in contrast to lifted bindings.
+      = case bind of
           NonRec x e -> (x,e) : prs2
           Rec prs1 -> prs1 ++ prs2
-    add_float f                       _    = pprPanic "cpeBind" (ppr f)
+    add_float f _ = pprPanic "cpeBind" (ppr f)
+
 
 ---------------
 cpePair :: TopLevelFlag -> RecFlag -> Demand -> Bool


=====================================
rts/Interpreter.c
=====================================
@@ -1275,21 +1275,21 @@ run_BCO:
 
         case bci_PUSH8_W: {
             W_ off = BCO_GET_LARGE_ARG;
-            *(StgWord*)(Sp_minusW(1)) = *(StgWord8*)(Sp_plusB(off));
+            *(StgWord8*)(Sp_minusW(1)) = *(StgWord8*)(Sp_plusB(off));
             Sp_subW(1);
             goto nextInsn;
         }
 
         case bci_PUSH16_W: {
             W_ off = BCO_GET_LARGE_ARG;
-            *(StgWord*)(Sp_minusW(1)) = *(StgWord16*)(Sp_plusB(off));
+            *(StgWord16*)(Sp_minusW(1)) = *(StgWord16*)(Sp_plusB(off));
             Sp_subW(1);
             goto nextInsn;
         }
 
         case bci_PUSH32_W: {
             W_ off = BCO_GET_LARGE_ARG;
-            *(StgWord*)(Sp_minusW(1)) = *(StgWord32*)(Sp_plusB(off));
+            *(StgWord32*)(Sp_minusW(1)) = *(StgWord32*)(Sp_plusB(off));
             Sp_subW(1);
             goto nextInsn;
         }


=====================================
testsuite/tests/driver/recomp011/all.T
=====================================
@@ -2,7 +2,6 @@
 
 test('recomp011',
      [ extra_files(['Main.hs'])
-     , when(arch('powerpc64'), expect_broken(11260))
      , js_broken(22261)
      ],
      makefile_test, [])


=====================================
testsuite/tests/driver/recomp015/all.T
=====================================
@@ -5,7 +5,7 @@ test('recomp015',
        # See ticket:11022#comment:7
        unless(opsys('linux') or opsys('solaris2') or opsys('openbsd'), skip),
        when(arch('arm'), skip),
-       js_skip, # JS backend doesn't support .s assembly files
-       when(arch('powerpc64'), expect_broken(11323))],
+       js_skip # JS backend doesn't support .s assembly files
+     ],
      makefile_test, [])
 



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fbae18d9569c914d2fdd2825c39e7bdf7e8e42bd...cf285d806a45bf7057d31469c950959c7e3d6ead

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fbae18d9569c914d2fdd2825c39e7bdf7e8e42bd...cf285d806a45bf7057d31469c950959c7e3d6ead
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/20231019/012ce6c0/attachment-0001.html>


More information about the ghc-commits mailing list