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

Commits:

14 changed files:

Changes:

  • compiler/GHC/Builtin/Names.hs
    ... ... @@ -476,7 +476,6 @@ basicKnownKeyNames
    476 476
    477 477 
             -- Generics
    478 478 
             , genClassName, gen1ClassName
    479 
    -        , datatypeClassName, constructorClassName, selectorClassName
    480 479
    481 480 
             -- Monad comprehensions
    482 481 
             , guardMName
    ... ... @@ -517,12 +516,9 @@ basicKnownKeyNames
    517 516
    518 517 
     genericTyConNames :: [Name]
    519 518 
     genericTyConNames = [
    520 
    -    v1TyConName, u1TyConName, par1TyConName, rec1TyConName,
    521 
    -    k1TyConName, m1TyConName, sumTyConName, prodTyConName,
    522 
    -    compTyConName, rTyConName, dTyConName,
    523 
    -    cTyConName, sTyConName, rec0TyConName,
    524 
    -    d1TyConName, c1TyConName, s1TyConName,
    525 
    -    repTyConName, rep1TyConName, uRecTyConName,
    519 
    +    v1TyConName, u1TyConName, par1TyConName, rec1TyConName, sumTyConName,
    520 
    +    prodTyConName, compTyConName, rec0TyConName, d1TyConName, c1TyConName,
    521 
    +    s1TyConName, repTyConName, rep1TyConName,
    526 522 
         uAddrTyConName, uCharTyConName, uDoubleTyConName,
    527 523 
         uFloatTyConName, uIntTyConName, uWordTyConName,
    528 524 
         prefixIDataConName, infixIDataConName, leftAssociativeDataConName,
    ... ... @@ -939,11 +935,8 @@ voidTyConName = tcQual gHC_INTERNAL_BASE (fsLit "Void") voidTyConKey
    939 935
    940 936 
     -- Generics (types)
    941 937 
     v1TyConName, u1TyConName, par1TyConName, rec1TyConName,
    942 
    -  k1TyConName, m1TyConName, sumTyConName, prodTyConName,
    943 
    -  compTyConName, rTyConName, dTyConName,
    944 
    -  cTyConName, sTyConName, rec0TyConName,
    945 
    -  d1TyConName, c1TyConName, s1TyConName,
    946 
    -  repTyConName, rep1TyConName, uRecTyConName,
    938 
    +  sumTyConName, prodTyConName, compTyConName, rec0TyConName, d1TyConName,
    939 
    +  c1TyConName, s1TyConName, repTyConName, rep1TyConName,
    947 940 
       uAddrTyConName, uCharTyConName, uDoubleTyConName,
    948 941 
       uFloatTyConName, uIntTyConName, uWordTyConName,
    949 942 
       prefixIDataConName, infixIDataConName, leftAssociativeDataConName,
    ... ... @@ -958,18 +951,11 @@ v1TyConName = tcQual gHC_INTERNAL_GENERICS (fsLit "V1") v1TyConKey
    958 951 
     u1TyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "U1") u1TyConKey
    959 952 
     par1TyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "Par1") par1TyConKey
    960 953 
     rec1TyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "Rec1") rec1TyConKey
    961 
    -k1TyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "K1") k1TyConKey
    962 
    -m1TyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "M1") m1TyConKey
    963 954
    964 955 
     sumTyConName    = tcQual gHC_INTERNAL_GENERICS (fsLit ":+:") sumTyConKey
    965 956 
     prodTyConName   = tcQual gHC_INTERNAL_GENERICS (fsLit ":*:") prodTyConKey
    966 957 
     compTyConName   = tcQual gHC_INTERNAL_GENERICS (fsLit ":.:") compTyConKey
    967 958
    968 
    -rTyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "R") rTyConKey
    969 
    -dTyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "D") dTyConKey
    970 
    -cTyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "C") cTyConKey
    971 
    -sTyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "S") sTyConKey
    972 
    -
    973 959 
     rec0TyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "Rec0") rec0TyConKey
    974 960 
     d1TyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "D1") d1TyConKey
    975 961 
     c1TyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "C1") c1TyConKey
    ... ... @@ -978,7 +964,6 @@ s1TyConName = tcQual gHC_INTERNAL_GENERICS (fsLit "S1") s1TyConKey
    978 964 
     repTyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "Rep")  repTyConKey
    979 965 
     rep1TyConName = tcQual gHC_INTERNAL_GENERICS (fsLit "Rep1") rep1TyConKey
    980 966
    981 
    -uRecTyConName      = tcQual gHC_INTERNAL_GENERICS (fsLit "URec") uRecTyConKey
    982 967 
     uAddrTyConName     = tcQual gHC_INTERNAL_GENERICS (fsLit "UAddr") uAddrTyConKey
    983 968 
     uCharTyConName     = tcQual gHC_INTERNAL_GENERICS (fsLit "UChar") uCharTyConKey
    984 969 
     uDoubleTyConName   = tcQual gHC_INTERNAL_GENERICS (fsLit "UDouble") uDoubleTyConKey
    ... ... @@ -1494,15 +1479,10 @@ readClassName :: Name
    1494 1479 
     readClassName   = clsQual gHC_INTERNAL_READ (fsLit "Read")      readClassKey
    1495 1480
    1496 1481 
     -- Classes Generic and Generic1, Datatype, Constructor and Selector
    1497 
    -genClassName, gen1ClassName, datatypeClassName, constructorClassName,
    1498 
    -  selectorClassName :: Name
    1482 
    +genClassName, gen1ClassName :: Name
    1499 1483 
     genClassName  = clsQual gHC_INTERNAL_GENERICS (fsLit "Generic")  genClassKey
    1500 1484 
     gen1ClassName = clsQual gHC_INTERNAL_GENERICS (fsLit "Generic1") gen1ClassKey
    1501 1485
    1502 
    -datatypeClassName    = clsQual gHC_INTERNAL_GENERICS (fsLit "Datatype")    datatypeClassKey
    1503 
    -constructorClassName = clsQual gHC_INTERNAL_GENERICS (fsLit "Constructor") constructorClassKey
    1504 
    -selectorClassName    = clsQual gHC_INTERNAL_GENERICS (fsLit "Selector")    selectorClassKey
    1505 
    -
    1506 1486 
     genericClassNames :: [Name]
    1507 1487 
     genericClassNames = [genClassName, gen1ClassName]
    1508 1488
    ... ... @@ -1753,15 +1733,10 @@ applicativeClassKey = mkPreludeClassUnique 34
    1753 1733 
     foldableClassKey        = mkPreludeClassUnique 35
    1754 1734 
     traversableClassKey     = mkPreludeClassUnique 36
    1755 1735
    1756 
    -genClassKey, gen1ClassKey, datatypeClassKey, constructorClassKey,
    1757 
    -  selectorClassKey :: Unique
    1736 
    +genClassKey, gen1ClassKey :: Unique
    1758 1737 
     genClassKey   = mkPreludeClassUnique 37
    1759 1738 
     gen1ClassKey  = mkPreludeClassUnique 38
    1760 1739
    1761 
    -datatypeClassKey    = mkPreludeClassUnique 39
    1762 
    -constructorClassKey = mkPreludeClassUnique 40
    1763 
    -selectorClassKey    = mkPreludeClassUnique 41
    1764 
    -
    1765 1740 
     -- KnownNat: see Note [KnownNat & KnownSymbol and EvLit] in GHC.Tc.Instance.Class
    1766 1741 
     knownNatClassNameKey :: Unique
    1767 1742 
     knownNatClassNameKey = mkPreludeClassUnique 42
    ... ... @@ -1950,11 +1925,8 @@ typeLitSortTyConKey = mkPreludeTyConUnique 108
    1950 1925
    1951 1926 
     -- Generics (Unique keys)
    1952 1927 
     v1TyConKey, u1TyConKey, par1TyConKey, rec1TyConKey,
    1953 
    -  k1TyConKey, m1TyConKey, sumTyConKey, prodTyConKey,
    1954 
    -  compTyConKey, rTyConKey, dTyConKey,
    1955 
    -  cTyConKey, sTyConKey, rec0TyConKey,
    1956 
    -  d1TyConKey, c1TyConKey, s1TyConKey,
    1957 
    -  repTyConKey, rep1TyConKey, uRecTyConKey,
    1928 
    +  sumTyConKey, prodTyConKey, compTyConKey, rec0TyConKey,
    1929 
    +  d1TyConKey, c1TyConKey, s1TyConKey, repTyConKey, rep1TyConKey,
    1958 1930 
       uAddrTyConKey, uCharTyConKey, uDoubleTyConKey,
    1959 1931 
       uFloatTyConKey, uIntTyConKey, uWordTyConKey :: Unique
    1960 1932
    ... ... @@ -1962,18 +1934,11 @@ v1TyConKey = mkPreludeTyConUnique 135
    1962 1934 
     u1TyConKey    = mkPreludeTyConUnique 136
    1963 1935 
     par1TyConKey  = mkPreludeTyConUnique 137
    1964 1936 
     rec1TyConKey  = mkPreludeTyConUnique 138
    1965 
    -k1TyConKey    = mkPreludeTyConUnique 139
    1966 
    -m1TyConKey    = mkPreludeTyConUnique 140
    1967 1937
    1968 1938 
     sumTyConKey   = mkPreludeTyConUnique 141
    1969 1939 
     prodTyConKey  = mkPreludeTyConUnique 142
    1970 1940 
     compTyConKey  = mkPreludeTyConUnique 143
    1971 1941
    1972 
    -rTyConKey = mkPreludeTyConUnique 144
    1973 
    -dTyConKey = mkPreludeTyConUnique 146
    1974 
    -cTyConKey = mkPreludeTyConUnique 147
    1975 
    -sTyConKey = mkPreludeTyConUnique 148
    1976 
    -
    1977 1942 
     rec0TyConKey  = mkPreludeTyConUnique 149
    1978 1943 
     d1TyConKey    = mkPreludeTyConUnique 151
    1979 1944 
     c1TyConKey    = mkPreludeTyConUnique 152
    ... ... @@ -1982,7 +1947,6 @@ s1TyConKey = mkPreludeTyConUnique 153
    1982 1947 
     repTyConKey  = mkPreludeTyConUnique 155
    1983 1948 
     rep1TyConKey = mkPreludeTyConUnique 156
    1984 1949
    1985 
    -uRecTyConKey    = mkPreludeTyConUnique 157
    1986 1950 
     uAddrTyConKey   = mkPreludeTyConUnique 158
    1987 1951 
     uCharTyConKey   = mkPreludeTyConUnique 159
    1988 1952 
     uDoubleTyConKey = mkPreludeTyConUnique 160

  • compiler/GHC/HsToCore/Foreign/Wasm.hs
    ... ... @@ -224,6 +224,25 @@ especially since leaving all the boxing/unboxing business to C unifies
    224 224 
     the implementation of JSFFI imports and exports
    225 225 
     (rts_mkJSVal/rts_getJSVal).
    226 226
    227 
    +We don't support unboxed FFI types like Int# etc. But we do support
    228 
    +one kind of unlifted FFI type for JSFFI import arguments:
    229 
    +ByteArray#/MutableByteArray#. The semantics is the same in C: the
    230 
    +pointer to the ByteArray# payload is passed instead of the ByteArray#
    231 
    +closure itself. This allows efficient zero-copy data exchange between
    232 
    +Haskell and JavaScript using unpinned ByteArray#, and the following
    233 
    +conditions must be met:
    234 
    +
    235 
    +- The JSFFI import itself must be a sync import marked as unsafe
    236 
    +- The JavaScript code must not re-enter Haskell when a ByteArray# is
    237 
    +  passed as argument
    238 
    +
    239 
    +There's no magic in the handling of ByteArray#/MutableByteArray#
    240 
    +arguments. When generating C stub, we treat them like Ptr that points
    241 
    +to the payload, just without the rts_getPtr() unboxing call. After
    242 
    +lowering to C import, the backend takes care of adding the offset, see
    243 
    +add_shim in GHC.StgToCmm.Foreign and
    244 
    +Note [Unlifted boxed arguments to foreign calls].
    245 
    +
    227 246 
     Now, each sync import calls a generated C function with a unique
    228 247 
     symbol. The C function uses rts_get* to unbox the arguments, call into
    229 248 
     JavaScript, then boxes the result with rts_mk* and returns it to
    ... ... @@ -517,8 +536,9 @@ importCStub sync cfun_name arg_tys res_ty js_src = CStub c_doc [] []
    517 536 
         cfun_ret
    518 537 
           | res_ty `eqType` unitTy = cfun_call_import <> semi
    519 538 
           | otherwise = text "return" <+> cfun_call_import <> semi
    520 
    -    cfun_make_arg arg_ty arg_val =
    521 
    -      text ("rts_get" ++ ffiType arg_ty) <> parens arg_val
    539 
    +    cfun_make_arg arg_ty arg_val
    540 
    +      | isByteArrayPrimTy arg_ty = arg_val
    541 
    +      | otherwise = text ("rts_get" ++ ffiType arg_ty) <> parens arg_val
    522 542 
         cfun_make_ret ret_val
    523 543 
           | res_ty `eqType` unitTy = ret_val
    524 544 
           | otherwise =
    ... ... @@ -543,7 +563,11 @@ importCStub sync cfun_name arg_tys res_ty js_src = CStub c_doc [] []
    543 563 
           | res_ty `eqType` unitTy = text "void"
    544 564 
           | otherwise = text "HaskellObj"
    545 565 
         cfun_arg_list =
    546 
    -      [text "HaskellObj" <+> char 'a' <> int n | n <- [1 .. length arg_tys]]
    566 
    +      [ text (if isByteArrayPrimTy arg_ty then "HsPtr" else "HaskellObj")
    567 
    +          <+> char 'a'
    568 
    +          <> int n
    569 
    +      | (arg_ty, n) <- zip arg_tys [1 ..]
    570 
    +      ]
    547 571 
         cfun_args = case cfun_arg_list of
    548 572 
           [] -> text "void"
    549 573 
           _ -> hsep $ punctuate comma cfun_arg_list
    ... ... @@ -746,8 +770,18 @@ lookupGhcInternalTyCon m t = do
    746 770 
       n <- lookupOrig (mkGhcInternalModule m) (mkTcOcc t)
    747 771 
       dsLookupTyCon n
    748 772
    773 
    +isByteArrayPrimTy :: Type -> Bool
    774 
    +isByteArrayPrimTy ty
    775 
    +  | Just tc <- tyConAppTyCon_maybe ty,
    776 
    +    tc == byteArrayPrimTyCon || tc == mutableByteArrayPrimTyCon =
    777 
    +      True
    778 
    +  | otherwise =
    779 
    +      False
    780 
    +
    749 781 
     ffiType :: Type -> String
    750 
    -ffiType = occNameString . getOccName . fst . splitTyConApp
    782 
    +ffiType ty
    783 
    +  | isByteArrayPrimTy ty = "Ptr"
    784 
    +  | otherwise = occNameString $ getOccName $ tyConAppTyCon ty
    751 785
    752 786 
     commonCDecls :: SDoc
    753 787 
     commonCDecls =

  • compiler/GHC/Parser/String.hs
    ... ... @@ -19,6 +19,7 @@ import Data.Char (chr, ord)
    19 19 
     import qualified Data.Foldable1 as Foldable1
    20 20 
     import qualified Data.List.NonEmpty as NonEmpty
    21 21 
     import Data.Maybe (listToMaybe, mapMaybe)
    22 
    +import GHC.Data.OrdList (fromOL, nilOL, snocOL)
    22 23 
     import GHC.Data.StringBuffer (StringBuffer)
    23 24 
     import qualified GHC.Data.StringBuffer as StringBuffer
    24 25 
     import GHC.Parser.CharClass (
    ... ... @@ -167,16 +168,16 @@ collapseGaps = go
    167 168 
           [] -> panic "gap unexpectedly ended"
    168 169
    169 170 
     resolveEscapes :: HasChar c => [c] -> Either (c, LexErr) [c]
    170 
    -resolveEscapes = go dlistEmpty
    171 
    +resolveEscapes = go nilOL
    171 172 
       where
    172 173 
         go !acc = \case
    173 
    -      [] -> pure $ dlistToList acc
    174 
    +      [] -> pure $ fromOL acc
    174 175 
           Char '\\' : Char '&' : cs -> go acc cs
    175 176 
           backslash@(Char '\\') : cs ->
    176 177 
             case resolveEscapeChar cs of
    177 
    -          Right (esc, cs') -> go (acc `dlistSnoc` setChar esc backslash) cs'
    178 
    +          Right (esc, cs') -> go (acc `snocOL` setChar esc backslash) cs'
    178 179 
               Left (c, e) -> Left (c, e)
    179 
    -      c : cs -> go (acc `dlistSnoc` c) cs
    180 
    +      c : cs -> go (acc `snocOL` c) cs
    180 181
    181 182 
     -- -----------------------------------------------------------------------------
    182 183 
     -- Escape characters
    ... ... @@ -420,17 +421,3 @@ It's more precisely defined with the following algorithm:
    420 421 
         * Lines with only whitespace characters
    421 422 
     3. Calculate the longest prefix of whitespace shared by all lines in the remaining list
    422 423 
     -}
    423 
    -
    424 
    --- -----------------------------------------------------------------------------
    425 
    --- DList
    426 
    -
    427 
    -newtype DList a = DList ([a] -> [a])
    428 
    -
    429 
    -dlistEmpty :: DList a
    430 
    -dlistEmpty = DList id
    431 
    -
    432 
    -dlistToList :: DList a -> [a]
    433 
    -dlistToList (DList f) = f []
    434 
    -
    435 
    -dlistSnoc :: DList a -> a -> DList a
    436 
    -dlistSnoc (DList f) x = DList (f . (x :))

  • compiler/GHC/StgToCmm/InfoTableProv.hs
    ... ... @@ -11,6 +11,7 @@ import GHC.IO (unsafePerformIO)
    11 11 
     #endif
    12 12
    13 13 
     import Data.Char
    14 
    +import Data.Foldable
    14 15 
     import GHC.Prelude
    15 16 
     import GHC.Platform
    16 17 
     import GHC.Types.SrcLoc (pprUserRealSpan, srcSpanFile)
    ... ... @@ -18,6 +19,7 @@ import GHC.Types.Unique.DSM
    18 19 
     import GHC.Unit.Module
    19 20 
     import GHC.Utils.Outputable
    20 21 
     import GHC.Data.FastString (fastStringToShortText, unpackFS, LexicalFastString(..))
    22 
    +import GHC.Data.OrdList (OrdList, nilOL, snocOL)
    21 23
    22 24 
     import GHC.Cmm
    23 25 
     import GHC.Cmm.CLabel
    ... ... @@ -286,7 +288,7 @@ data CgInfoProvEnt = CgInfoProvEnt
    286 288 
                                    , ipeSrcSpan :: !StrTabOffset
    287 289 
                                    }
    288 290
    289 
    -data StringTable = StringTable { stStrings :: DList ShortText
    291 
    +data StringTable = StringTable { stStrings :: !(OrdList ShortText)
    290 292 
                                    , stLength :: !Int
    291 293 
                                    , stLookup :: !(M.Map ShortText StrTabOffset)
    292 294 
                                    }
    ... ... @@ -295,7 +297,7 @@ type StrTabOffset = Word32
    295 297
    296 298 
     emptyStringTable :: StringTable
    297 299 
     emptyStringTable =
    298 
    -    StringTable { stStrings = emptyDList
    300 
    +    StringTable { stStrings = nilOL
    299 301 
                     , stLength = 0
    300 302 
                     , stLookup = M.empty
    301 303 
                     }
    ... ... @@ -303,7 +305,7 @@ emptyStringTable =
    303 305 
     getStringTableStrings :: StringTable -> BS.ByteString
    304 306 
     getStringTableStrings st =
    305 307 
         BSL.toStrict $ BSB.toLazyByteString
    306 
    -    $ foldMap f $ dlistToList (stStrings st)
    308 
    +    $ foldMap' f $ stStrings st
    307 309 
       where
    308 310 
         f x = BSB.shortByteString (ST.contents x) `mappend` BSB.word8 0
    309 311
    ... ... @@ -312,7 +314,7 @@ lookupStringTable str = state $ \st ->
    312 314 
         case M.lookup str (stLookup st) of
    313 315 
           Just off -> (off, st)
    314 316 
           Nothing ->
    315 
    -          let !st' = st { stStrings = stStrings st `snoc` str
    317 
    +          let !st' = st { stStrings = stStrings st `snocOL` str
    316 318 
                             , stLength  = stLength st + ST.byteLength str + 1
    317 319 
                             , stLookup  = M.insert str res (stLookup st)
    318 320 
                             }
    ... ... @@ -359,14 +361,3 @@ foreign import ccall unsafe "ZSTD_compressBound"
    359 361
    360 362 
     defaultCompressionLevel :: Int
    361 363 
     defaultCompressionLevel = 3
    362 
    -
    363 
    -newtype DList a = DList ([a] -> [a])
    364 
    -
    365 
    -emptyDList :: DList a
    366 
    -emptyDList = DList id
    367 
    -
    368 
    -snoc :: DList a -> a -> DList a
    369 
    -snoc (DList f) x = DList (f . (x:))
    370 
    -
    371 
    -dlistToList :: DList a -> [a]
    372 
    -dlistToList (DList f) = f []

  • docs/users_guide/wasm.rst
    ... ... @@ -265,7 +265,7 @@ backend’s JavaScript FFI, which we’ll now abbreviate as JSFFI.
    265 265 
     Marshalable types and ``JSVal``
    266 266 
     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    267 267
    268 
    -JSFFI supports all boxed marshalable foreign types in C FFI:
    268 
    +JSFFI supports all lifted marshalable foreign types in C FFI:
    269 269
    270 270 
     -  ``Bool``
    271 271 
     -  ``Char``
    ... ... @@ -298,8 +298,14 @@ types in JSFFI. Some caveats to keep in mind:
    298 298 
        results in type errors, so keep this in mind. As for ``Int`` /
    299 299 
        ``Word``, they are 32-bit since the GHC wasm backend is based on
    300 300 
        ``wasm32`` .
    301 
    --  JSFFI doesn’t support unboxed foreign types like ``Int#``,
    302 
    -   ``ByteArray#``, etc, even when ``UnliftedFFITypes`` is enabled.
    301 
    +-  JSFFI doesn’t support unboxed foreign types like ``Int#``, even
    302 
    +   when ``UnliftedFFITypes`` is enabled. The only supported unlifted
    303 
    +   types are ``ByteArray#`` and ``MutableByteArray#``, they may only
    304 
    +   be used as JSFFI import argument types, with the same semantics in
    305 
    +   C FFI: the pointer to the payload is passed to JavaScript. Be
    306 
    +   careful and avoid calling back into Haskell in such cases,
    307 
    +   otherwise GC may occur and the pointer may be invalidated if it's
    308 
    +   unpinned!
    303 309
    304 310 
     In addition to the above types, JSFFI supports the ``JSVal`` type and
    305 311 
     its ``newtype``\ s as argument/result types. ``JSVal`` is defined in

  • hadrian/src/Flavour.hs
    ... ... @@ -169,6 +169,7 @@ enableDebugInfo :: Flavour -> Flavour
    169 169 
     enableDebugInfo = addArgs $ notStage0 ? mconcat
    170 170 
         [ builder (Ghc CompileHs) ? pure ["-g3"]
    171 171 
         , builder (Ghc CompileCWithGhc) ? pure ["-optc-g3"]
    172 
    +    , builder (Ghc CompileCppWithGhc) ? pure ["-optcxx-g3"]
    172 173 
         , builder (Cc CompileC) ? arg "-g3"
    173 174 
         , builder (Cabal Setup) ? arg "--disable-library-stripping"
    174 175 
         , builder (Cabal Setup) ? arg "--disable-executable-stripping"

  • hadrian/src/Settings/Packages.hs
    ... ... @@ -351,7 +351,7 @@ rtsPackageArgs = package rts ? do
    351 351 
               , Debug     `wayUnit` way          ? pure [ "-DDEBUG"
    352 352 
                                                         , "-fno-omit-frame-pointer"
    353 353 
                                                         , "-g3"
    354 
    -                                                    , "-O0" ]
    354 
    +                                                    , "-Og" ]
    355 355 
               -- Set the namespace for the rts fs functions
    356 356 
               , arg $ "-DFS_NAMESPACE=rts"
    357 357

  • rts/linker/InitFini.c
    ... ... @@ -75,7 +75,7 @@ static void sortInitFiniList(struct InitFiniList **slist, enum SortOrder order)
    75 75 
             while (*last != NULL && (*last)->next != NULL) {
    76 76 
                 struct InitFiniList *s0 = *last;
    77 77 
                 struct InitFiniList *s1 = s0->next;
    78 
    -            bool flip;
    78 
    +            bool flip = false;
    79 79 
                 switch (order) {
    80 80 
                     case INCREASING: flip = s0->priority > s1->priority; break;
    81 81 
                     case DECREASING: flip = s0->priority < s1->priority; break;

  • rts/sm/Sanity.c
    ... ... @@ -692,7 +692,7 @@ checkCompactObjects(bdescr *bd)
    692 692 
             ASSERT((W_)str == (W_)block + sizeof(StgCompactNFDataBlock));
    693 693
    694 694 
             StgWord totalW = 0;
    695 
    -        StgCompactNFDataBlock *last;
    695 
    +        StgCompactNFDataBlock *last = block;
    696 696 
             for ( ; block ; block = block->next) {
    697 697 
                 last = block;
    698 698 
                 ASSERT(block->owner == str);

  • testsuite/tests/jsffi/all.T
    ... ... @@ -25,4 +25,6 @@ test('jsffion', [], compile_and_run, ['-optl-Wl,--export=main'])
    25 25
    26 26 
     test('jsffisleep', [], compile_and_run, ['-optl-Wl,--export=testWouldBlock,--export=testLazySleep,--export=testThreadDelay,--export=testInterruptingSleep'])
    27 27
    28 
    +test('bytearrayarg', [], compile_and_run, ['-optl-Wl,--export=main'])
    29 
    +
    28 30 
     test('textconv', [], compile_and_run, ['-optl-Wl,--export=main'])

  • testsuite/tests/jsffi/bytearrayarg.hs
    1 
    +{-# LANGUAGE MagicHash #-}
    2 
    +{-# LANGUAGE UnboxedTuples #-}
    3 
    +{-# LANGUAGE UnliftedFFITypes #-}
    4 
    +
    5 
    +module Test where
    6 
    +
    7 
    +import GHC.Exts
    8 
    +import GHC.IO
    9 
    +import GHC.Word (Word8(W8#))
    10 
    +
    11 
    +foreign import javascript unsafe "(() => { const u8 = new Uint8Array(__exports.memory.buffer, $1, 4); return (u8[0] === 0x12 && u8[1] === 0x34 && u8[2] === 0x56 && u8[3] === 0x78) ? 1 : 0; })()"
    12 
    +  js_check_mba :: MutableByteArray# RealWorld -> IO Int
    13 
    +
    14 
    +foreign import javascript unsafe "(() => { const u8 = new Uint8Array(__exports.memory.buffer, $1, 4); return (u8[0] === 0x12 && u8[1] === 0x34 && u8[2] === 0x56 && u8[3] === 0x78) ? 1 : 0; })()"
    15 
    +  js_check_ba :: ByteArray# -> IO Int
    16 
    +
    17 
    +foreign export javascript "main"
    18 
    +  main :: IO ()
    19 
    +
    20 
    +main :: IO ()
    21 
    +main =
    22 
    +  IO $ \s0 ->
    23 
    +    case newPinnedByteArray# 4# s0 of
    24 
    +      (# s1, mba# #) ->
    25 
    +        case (0x12 :: Word8) of { W8# b0# ->
    26 
    +        case (0x34 :: Word8) of { W8# b1# ->
    27 
    +        case (0x56 :: Word8) of { W8# b2# ->
    28 
    +        case (0x78 :: Word8) of { W8# b3# ->
    29 
    +          let s2 = writeWord8Array# mba# 0# b0# s1
    30 
    +              s3 = writeWord8Array# mba# 1# b1# s2
    31 
    +              s4 = writeWord8Array# mba# 2# b2# s3
    32 
    +              s5 = writeWord8Array# mba# 3# b3# s4
    33 
    +           in case unIO (js_check_mba mba#) s5 of
    34 
    +                (# s6, ok_mba #) -> case unsafeFreezeByteArray# mba# s6 of
    35 
    +                  (# s7, ba# #) -> case unIO (js_check_ba ba#) s7 of
    36 
    +                    (# s8, ok_ba #) -> case unIO (print ok_mba) s8 of
    37 
    +                      (# s9, _ #) -> case unIO (print ok_ba) s9 of
    38 
    +                        (# s10, _ #) -> (# s10, () #)
    39 
    +        }}}}

  • testsuite/tests/jsffi/bytearrayarg.mjs
    1 
    +export default async (__exports) => {
    2 
    +  await __exports.main();
    3 
    +  process.exit();
    4 
    +}

  • testsuite/tests/jsffi/bytearrayarg.stdout
    1 
    +1
    2 
    +1

  • testsuite/tests/perf/should_run/all.T
    ... ... @@ -420,6 +420,7 @@ test('T17949', [collect_stats('bytes allocated', 1), only_ways(['normal'])], com
    420 420 
     test('ByteCodeAsm',
    421 421 
                    [ extra_run_opts('"' + config.libdir + '"')
    422 422 
                    , js_broken(22261)
    423 
    +               , when(arch('wasm32'), run_timeout_multiplier(10))
    423 424 
                    , collect_stats('bytes allocated', 10),
    424 425 
                    ],
    425 426 
                    compile_and_run,

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help