[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: configure: Don't check for an unsupported version of LLVM
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Wed Nov 16 13:09:37 UTC 2022
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
94549f8f by ARATA Mizuki at 2022-11-15T21:36:03-05:00
configure: Don't check for an unsupported version of LLVM
The upper bound is not inclusive.
Fixes #22449
- - - - -
02d3511b by Bodigrim at 2022-11-15T21:36:41-05:00
Fix capitalization in haddock for TestEquality
- - - - -
08bf2881 by Cheng Shao at 2022-11-16T09:16:29+00:00
base: make Foreign.Marshal.Pool use RTS internal arena for allocation
`Foreign.Marshal.Pool` used to call `malloc` once for each allocation
request. Each `Pool` maintained a list of allocated pointers, and
traverses the list to `free` each one of those pointers. The extra O(n)
overhead is apparently bad for a `Pool` that serves a lot of small
allocation requests.
This patch uses the RTS internal arena to implement `Pool`, with these
benefits:
- Gets rid of the extra O(n) overhead.
- The RTS arena is simply a bump allocator backed by the block
allocator, each allocation request is likely faster than a libc
`malloc` call.
Closes #14762 #18338.
- - - - -
430d9263 by Krzysztof Gogolewski at 2022-11-16T08:09:22-05:00
Misc cleanup
* Replace catMaybes . map f with mapMaybe f
* Use concatFS to concatenate multiple FastStrings
* Fix documentation of -exclude-module
* Cleanup getIgnoreCount in GHCi.UI
- - - - -
28 changed files:
- compiler/GHC/CmmToAsm.hs
- compiler/GHC/CmmToAsm/BlockLayout.hs
- compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs
- compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs
- compiler/GHC/CmmToAsm/Reg/Graph/SpillCost.hs
- compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs
- compiler/GHC/Data/Graph/Color.hs
- compiler/GHC/Data/Graph/Ops.hs
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/GenerateCgIPEStub.hs
- compiler/GHC/Llvm/Ppr.hs
- compiler/GHC/Parser.y
- compiler/GHC/Tc/Gen/Bind.hs
- compiler/GHC/Types/CostCentre.hs
- compiler/GHC/Types/Name/Occurrence.hs
- compiler/GHC/Types/RepType.hs
- compiler/GHC/Utils/Json.hs
- compiler/GHC/Utils/Lexeme.hs
- compiler/GHC/Wasm/ControlFlow/FromCmm.hs
- docs/users_guide/expected-undocumented-flags.txt
- docs/users_guide/separate_compilation.rst
- ghc/GHCi/UI.hs
- hadrian/src/Hadrian/Haskell/Cabal/Parse.hs
- libraries/base/Data/Type/Equality.hs
- libraries/base/Foreign/Marshal/Pool.hs
- libraries/base/changelog.md
- m4/find_llvm_prog.m4
- rts/Arena.h
Changes:
=====================================
compiler/GHC/CmmToAsm.hs
=====================================
@@ -807,7 +807,7 @@ generateJumpTables
generateJumpTables ncgImpl xs = concatMap f xs
where f p@(CmmProc _ _ _ (ListGraph xs)) = p : concatMap g xs
f p = [p]
- g (BasicBlock _ xs) = catMaybes (map (generateJumpTableForInstr ncgImpl) xs)
+ g (BasicBlock _ xs) = mapMaybe (generateJumpTableForInstr ncgImpl) xs
-- -----------------------------------------------------------------------------
-- Shortcut branches
=====================================
compiler/GHC/CmmToAsm/BlockLayout.hs
=====================================
@@ -657,7 +657,7 @@ sequenceChain _info _weights [] = []
sequenceChain _info _weights [x] = [x]
sequenceChain info weights blocks@((BasicBlock entry _):_) =
let directEdges :: [CfgEdge]
- directEdges = sortBy (flip compare) $ catMaybes . map relevantWeight $ (infoEdgeList weights)
+ directEdges = sortBy (flip compare) $ mapMaybe relevantWeight (infoEdgeList weights)
where
-- Apply modifiers to turn edge frequencies into useable weights
-- for computing code layout.
=====================================
compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs
=====================================
@@ -147,8 +147,7 @@ regSpill_top platform regSlotMap cmm
$ mapLookup blockId slotMap
moreSlotsLive = IntSet.fromList
- $ catMaybes
- $ map (lookupUFM regSlotMap)
+ $ mapMaybe (lookupUFM regSlotMap)
$ nonDetEltsUniqSet regsLive
-- See Note [Unique Determinism and code generation]
=====================================
compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs
=====================================
@@ -390,8 +390,7 @@ cleanBackward' liveSlotsOnEntry reloadedBy noReloads acc (li : instrs)
= do
let slotsReloadedByTargets
= IntSet.unions
- $ catMaybes
- $ map (flip mapLookup liveSlotsOnEntry)
+ $ mapMaybe (flip mapLookup liveSlotsOnEntry)
$ targets
let noReloads'
=====================================
compiler/GHC/CmmToAsm/Reg/Graph/SpillCost.hs
=====================================
@@ -130,8 +130,8 @@ slurpSpillCostInfo platform cfg cmm
-- Increment counts for what regs were read/written from.
let (RU read written) = regUsageOfInstr platform instr
- mapM_ (incUses scale) $ catMaybes $ map takeVirtualReg $ nub read
- mapM_ (incDefs scale) $ catMaybes $ map takeVirtualReg $ nub written
+ mapM_ (incUses scale) $ mapMaybe takeVirtualReg $ nub read
+ mapM_ (incDefs scale) $ mapMaybe takeVirtualReg $ nub written
-- Compute liveness for entry to next instruction.
let liveDieRead_virt = takeVirtuals (liveDieRead live)
=====================================
compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs
=====================================
@@ -31,6 +31,8 @@ import GHC.Types.Unique
import GHC.Types.Unique.FM
import GHC.Types.Unique.Set
+import GHC.Utils.Outputable
+
-- | For a jump instruction at the end of a block, generate fixup code so its
-- vregs are in the correct regs for its destination.
--
@@ -375,6 +377,5 @@ makeMove delta vreg src dst
-- we don't handle memory to memory moves.
-- they shouldn't happen because we don't share
-- stack slots between vregs.
- panic ("makeMove " ++ show vreg ++ " (" ++ show src ++ ") ("
- ++ show dst ++ ")"
- ++ " we don't handle mem->mem moves.")
+ pprPanic "makeMove: we don't handle mem->mem moves"
+ (ppr vreg <+> parens (ppr src) <+> parens (ppr dst))
=====================================
compiler/GHC/Data/Graph/Color.hs
=====================================
@@ -328,8 +328,7 @@ selectColor colors graph u
-- See Note [Unique Determinism and code generation]
colors_conflict = mkUniqSet
- $ catMaybes
- $ map nodeColor nsConflicts
+ $ mapMaybe nodeColor nsConflicts
-- the prefs of our neighbors
colors_neighbor_prefs
=====================================
compiler/GHC/Data/Graph/Ops.hs
=====================================
@@ -633,7 +633,7 @@ checkNode graph node
$ nonDetEltsUniqSet $ nodeConflicts node
-- See Note [Unique Determinism and code generation]
- , neighbourColors <- catMaybes $ map nodeColor neighbors
+ , neighbourColors <- mapMaybe nodeColor neighbors
, elem color neighbourColors
= False
=====================================
compiler/GHC/Driver/Backpack.hs
=====================================
@@ -939,4 +939,4 @@ hsModuleToModSummary home_keys pn hsc_src modname
newUnitId :: UnitId -> Maybe FastString -> UnitId
newUnitId uid mhash = case mhash of
Nothing -> uid
- Just hash -> UnitId (unitIdFS uid `appendFS` mkFastString "+" `appendFS` hash)
+ Just hash -> UnitId (concatFS [unitIdFS uid, fsLit "+", hash])
=====================================
compiler/GHC/Driver/GenerateCgIPEStub.hs
=====================================
@@ -3,7 +3,7 @@
module GHC.Driver.GenerateCgIPEStub (generateCgIPEStub) where
import qualified Data.Map.Strict as Map
-import Data.Maybe (catMaybes, listToMaybe)
+import Data.Maybe (mapMaybe, listToMaybe)
import GHC.Cmm
import GHC.Cmm.CLabel (CLabel)
import GHC.Cmm.Dataflow (Block, C, O)
@@ -210,7 +210,7 @@ generateCgIPEStub hsc_env this_mod denv s = do
collectNothing _ cmmGroupSRTs = pure ([], cmmGroupSRTs)
collectInfoTables :: CmmGroupSRTs -> [(Label, CmmInfoTable)]
- collectInfoTables cmmGroup = concat $ catMaybes $ map extractInfoTables cmmGroup
+ collectInfoTables cmmGroup = concat $ mapMaybe extractInfoTables cmmGroup
extractInfoTables :: GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph -> Maybe [(Label, CmmInfoTable)]
extractInfoTables (CmmProc h _ _ _) = Just $ mapToList (info_tbls h)
@@ -249,8 +249,7 @@ generateCgIPEStub hsc_env this_mod denv s = do
lastTickInBlock block =
listToMaybe $
- catMaybes $
- map maybeTick $ (reverse . blockToList) block
+ mapMaybe maybeTick $ (reverse . blockToList) block
maybeTick :: CmmNode O O -> Maybe IpeSourceLocation
maybeTick (CmmTick (SourceNote span name)) = Just (span, name)
=====================================
compiler/GHC/Llvm/Ppr.hs
=====================================
@@ -517,8 +517,8 @@ ppName opts v = case v of
ppPlainName :: LlvmCgConfig -> LlvmVar -> SDoc
ppPlainName opts v = case v of
(LMGlobalVar x _ _ _ _ _) -> ftext x
- (LMLocalVar x LMLabel ) -> text (show x)
- (LMLocalVar x _ ) -> text ('l' : show x)
+ (LMLocalVar x LMLabel ) -> pprUniqueAlways x
+ (LMLocalVar x _ ) -> char 'l' <> pprUniqueAlways x
(LMNLocalVar x _ ) -> ftext x
(LMLitVar x ) -> ppLit opts x
=====================================
compiler/GHC/Parser.y
=====================================
@@ -825,7 +825,7 @@ HYPHEN :: { [AddEpAnn] }
litpkgname :: { Located FastString }
: litpkgname_segment { $1 }
-- a bit of a hack, means p - b is parsed same as p-b, enough for now.
- | litpkgname_segment HYPHEN litpkgname { sLL $1 $> $ appendFS (unLoc $1) (consFS '-' (unLoc $3)) }
+ | litpkgname_segment HYPHEN litpkgname { sLL $1 $> $ concatFS [unLoc $1, fsLit "-", (unLoc $3)] }
mayberns :: { Maybe [LRenaming] }
: {- empty -} { Nothing }
=====================================
compiler/GHC/Tc/Gen/Bind.hs
=====================================
@@ -675,7 +675,7 @@ funBindTicks loc fun_id mod sigs
= sl_fs $ unLoc cc_str
| otherwise
= getOccFS (Var.varName fun_id)
- cc_name = moduleNameFS (moduleName mod) `appendFS` consFS '.' cc_str
+ cc_name = concatFS [moduleNameFS (moduleName mod), fsLit ".", cc_str]
= do
flavour <- DeclCC <$> getCCIndexTcM cc_name
let cc = mkUserCC cc_name mod loc flavour
=====================================
compiler/GHC/Types/CostCentre.hs
=====================================
@@ -161,9 +161,9 @@ mkAutoCC id mod
-- Unique.
-- See bug #249, tests prof001, prof002, also #2411
str | isExternalName name = occNameFS (getOccName id)
- | otherwise = occNameFS (getOccName id)
- `appendFS`
- mkFastString ('_' : show (getUnique name))
+ | otherwise = concatFS [occNameFS (getOccName id),
+ fsLit "_",
+ mkFastString (show (getUnique name))]
mkAllCafsCC :: Module -> SrcSpan -> CostCentre
mkAllCafsCC m loc = AllCafsCC { cc_mod = m, cc_loc = loc }
=====================================
compiler/GHC/Types/Name/Occurrence.hs
=====================================
@@ -519,9 +519,9 @@ parenSymOcc occ doc | isSymOcc occ = parens doc
startsWithUnderscore :: OccName -> Bool
-- ^ Haskell 98 encourages compilers to suppress warnings about unused
-- names in a pattern if they start with @_@: this implements that test
-startsWithUnderscore occ = case unconsFS (occNameFS occ) of
- Just ('_', _) -> True
- _ -> False
+startsWithUnderscore occ = case unpackFS (occNameFS occ) of
+ '_':_ -> True
+ _ -> False
{-
************************************************************************
@@ -860,13 +860,13 @@ tidyOccName env occ@(OccName occ_sp fs)
base1 = mkFastString (base ++ "1")
find !k !n
- = case lookupUFM env new_fs of
- Just {} -> find (k+1 :: Int) (n+k)
+ = case elemUFM new_fs env of
+ True -> find (k+1 :: Int) (n+k)
-- By using n+k, the n argument to find goes
-- 1, add 1, add 2, add 3, etc which
-- moves at quadratic speed through a dense patch
- Nothing -> (new_env, OccName occ_sp new_fs)
+ False -> (new_env, OccName occ_sp new_fs)
where
new_fs = mkFastString (base ++ show n)
new_env = addToUFM (addToUFM env new_fs 1) base1 (n+1)
=====================================
compiler/GHC/Types/RepType.hs
=====================================
@@ -302,11 +302,10 @@ instance Outputable SlotTy where
ppr (VecSlot n e) = text "VecSlot" <+> ppr n <+> ppr e
typeSlotTy :: UnaryType -> Maybe SlotTy
-typeSlotTy ty
- | isZeroBitTy ty
- = Nothing
- | otherwise
- = Just (primRepSlot (typePrimRep1 ty))
+typeSlotTy ty = case typePrimRep ty of
+ [] -> Nothing
+ [rep] -> Just (primRepSlot rep)
+ reps -> pprPanic "typeSlotTy" (ppr ty $$ ppr reps)
primRepSlot :: PrimRep -> SlotTy
primRepSlot VoidRep = pprPanic "primRepSlot" (text "No slot for VoidRep")
=====================================
compiler/GHC/Utils/Json.hs
=====================================
@@ -24,7 +24,7 @@ renderJSON :: JsonDoc -> SDoc
renderJSON d =
case d of
JSNull -> text "null"
- JSBool b -> text $ if b then "true" else "false"
+ JSBool b -> if b then text "true" else text "false"
JSInt n -> ppr n
JSString s -> doubleQuotes $ text $ escapeJsonString s
JSArray as -> brackets $ pprList renderJSON as
=====================================
compiler/GHC/Utils/Lexeme.hs
=====================================
@@ -67,17 +67,17 @@ isLexId cs = isLexConId cs || isLexVarId cs
isLexSym cs = isLexConSym cs || isLexVarSym cs
-------------
-isLexConId cs = case unconsFS cs of -- Prefix type or data constructors
- Nothing -> False -- e.g. "Foo", "[]", "(,)"
- Just (c, _) -> cs == fsLit "[]" || startsConId c
+isLexConId cs = case unpackFS cs of -- Prefix type or data constructors
+ [] -> False -- e.g. "Foo", "[]", "(,)"
+ c:_ -> cs == fsLit "[]" || startsConId c
-isLexVarId cs = case unconsFS cs of -- Ordinary prefix identifiers
- Nothing -> False -- e.g. "x", "_x"
- Just (c, _) -> startsVarId c
+isLexVarId cs = case unpackFS cs of -- Ordinary prefix identifiers
+ [] -> False -- e.g. "x", "_x"
+ c:_ -> startsVarId c
-isLexConSym cs = case unconsFS cs of -- Infix type or data constructors
- Nothing -> False -- e.g. ":-:", ":", "->"
- Just (c, _) -> cs == fsLit "->" || startsConSym c
+isLexConSym cs = case unpackFS cs of -- Infix type or data constructors
+ [] -> False -- e.g. ":-:", ":", "->"
+ c:_ -> cs == fsLit "->" || startsConSym c
isLexVarSym fs -- Infix identifiers e.g. "+"
| fs == (fsLit "~R#") = True
=====================================
compiler/GHC/Wasm/ControlFlow/FromCmm.hs
=====================================
@@ -29,7 +29,6 @@ import GHC.Utils.Misc
import GHC.Utils.Panic
import GHC.Utils.Outputable ( Outputable, text, (<+>), ppr
, pprWithCommas
- , showSDocUnsafe
)
import GHC.Wasm.ControlFlow
@@ -338,7 +337,7 @@ instance Outputable ContainingSyntax where
findLabelIn :: HasDebugCallStack => Label -> LabelMap a -> a
findLabelIn lbl = mapFindWithDefault failed lbl
where failed =
- panic $ "label " ++ showSDocUnsafe (ppr lbl) ++ " not found in control-flow graph"
+ pprPanic "label not found in control-flow graph" (ppr lbl)
infixl 4 <$~>
=====================================
docs/users_guide/expected-undocumented-flags.txt
=====================================
@@ -26,7 +26,6 @@
-dsource-stats
-dstg-stats
-dsuppress-stg-exts
--exclude-module
-fallow-incoherent-instances
-fallow-overlapping-instances
-fallow-undecidable-instances
=====================================
docs/users_guide/separate_compilation.rst
=====================================
@@ -1483,7 +1483,7 @@ generation are:
on ``.hi``, ``.a_hs`` on ``.a_hi``, and ``.b_hs`` on ``.b_hi``.
If you do not use this flag then the empty suffix is used.
-.. ghc-flag:: --exclude-module=⟨file⟩
+.. ghc-flag:: -exclude-module=⟨file⟩
:shortdesc: Regard ``⟨file⟩`` as "stable"; i.e., exclude it from having
dependencies on it.
:type: dynamic
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -3864,7 +3864,7 @@ continueCmd argLine = withSandboxOnly ":continue" $
where
contSwitch :: [String] -> Either SDoc (Maybe Int)
contSwitch [ ] = Right Nothing
- contSwitch [x] = getIgnoreCount x
+ contSwitch [x] = Just <$> getIgnoreCount x
contSwitch _ = Left $
text "After ':continue' only one ignore count is allowed"
@@ -3992,30 +3992,24 @@ ignoreCmd argLine = withSandboxOnly ":ignore" $ do
result <- ignoreSwitch (words argLine)
case result of
Left sdoc -> printForUser sdoc
- Right (loc, mbCount) -> do
+ Right (loc, count) -> do
let breakInfo = GHC.BreakInfo (breakModule loc) (breakTick loc)
- count = fromMaybe 0 mbCount
setupBreakpoint breakInfo count
-ignoreSwitch :: GhciMonad m => [String] -> m (Either SDoc (BreakLocation, Maybe Int))
+ignoreSwitch :: GhciMonad m => [String] -> m (Either SDoc (BreakLocation, Int))
ignoreSwitch [break, count] = do
sdoc_loc <- getBreakLoc break
pure $ (,) <$> sdoc_loc <*> getIgnoreCount count
ignoreSwitch _ = pure $ Left $ text "Syntax: :ignore <breaknum> <count>"
-getIgnoreCount :: String -> Either SDoc (Maybe Int)
+getIgnoreCount :: String -> Either SDoc Int
getIgnoreCount str =
- let checkJust :: Maybe Int -> Either SDoc (Maybe Int)
- checkJust mbCnt
- | (isJust mbCnt) = Right mbCnt
- | otherwise = Left $ sdocIgnore <+> text "is not numeric"
- checkPositive :: Maybe Int -> Either SDoc (Maybe Int)
- checkPositive mbCnt
- | isJust mbCnt && fromJust mbCnt >= 0 = Right mbCnt
- | otherwise = Left $ sdocIgnore <+> text "must be >= 0"
- mbCnt :: Maybe Int = readMaybe str
- sdocIgnore = (text "Ignore count") <+> quotes (text str)
- in Right mbCnt >>= checkJust >>= checkPositive
+ case readMaybe str of
+ Nothing -> Left $ sdocIgnore <+> "is not numeric"
+ Just cnt | cnt < 0 -> Left $ sdocIgnore <+> "must be >= 0"
+ | otherwise -> Right cnt
+ where
+ sdocIgnore = text "Ignore count" <+> quotes (text str)
setupBreakpoint :: GhciMonad m => GHC.BreakInfo -> Int -> m()
setupBreakpoint loc count = do
=====================================
hadrian/src/Hadrian/Haskell/Cabal/Parse.hs
=====================================
@@ -89,7 +89,7 @@ parsePackageData pkg = do
allDeps = concat (libDeps : exeDeps)
sorted = sort [ C.unPackageName p | C.Dependency p _ _ <- allDeps ]
deps = nubOrd sorted \\ [name]
- depPkgs = catMaybes $ map findPackageByName deps
+ depPkgs = mapMaybe findPackageByName deps
return $ PackageData name version
(C.fromShortText (C.synopsis pd))
(C.fromShortText (C.description pd))
=====================================
libraries/base/Data/Type/Equality.hs
=====================================
@@ -152,14 +152,14 @@ deriving instance a ~~ b => Bounded (a :~~: b)
-- The result should be @Just Refl@ if and only if the types applied to @f@ are
-- equal:
--
--- @TestEquality (x :: f a) (y :: f b) = Just Refl ⟺ a = b@
+-- @testEquality (x :: f a) (y :: f b) = Just Refl ⟺ a = b@
--
-- Typically, only singleton types should inhabit this class. In that case type
-- argument equality coincides with term equality:
--
--- @TestEquality (x :: f a) (y :: f b) = Just Refl ⟺ a = b ⟺ x = y@
+-- @testEquality (x :: f a) (y :: f b) = Just Refl ⟺ a = b ⟺ x = y@
--
--- @isJust (TestEquality x y) = x == y@
+-- @isJust (testEquality x y) = x == y@
--
-- Singleton types are not required, however, and so the latter two would-be
-- laws are not in fact valid in general.
=====================================
libraries/base/Foreign/Marshal/Pool.hs
=====================================
@@ -46,19 +46,18 @@ module Foreign.Marshal.Pool (
pooledNewArray0
) where
-import GHC.Base ( Int, Monad(..), (.), liftM, not )
+import GHC.Base ( Int, Monad(..) )
import GHC.Err ( undefined )
import GHC.Exception ( throw )
import GHC.IO ( IO, mask, catchAny )
-import GHC.IORef ( IORef, newIORef, readIORef, writeIORef )
-import GHC.List ( elem, length )
+import GHC.List ( length )
import GHC.Num ( Num(..) )
+import GHC.Real ( fromIntegral )
-import Data.OldList ( delete )
-import Foreign.Marshal.Alloc ( mallocBytes, reallocBytes, free )
+import Foreign.C.Types ( CSize(..) )
import Foreign.Marshal.Array ( pokeArray, pokeArray0 )
-import Foreign.Marshal.Error ( throwIf )
-import Foreign.Ptr ( Ptr, castPtr )
+import Foreign.Marshal.Utils ( moveBytes )
+import Foreign.Ptr ( Ptr )
import Foreign.Storable ( Storable(sizeOf, poke) )
--------------------------------------------------------------------------------
@@ -68,20 +67,18 @@ import Foreign.Storable ( Storable(sizeOf, poke) )
-- | A memory pool.
-newtype Pool = Pool (IORef [Ptr ()])
+newtype Pool = Pool (Ptr ())
-- | Allocate a fresh memory pool.
newPool :: IO Pool
-newPool = liftM Pool (newIORef [])
+newPool = c_newArena
-- | Deallocate a memory pool and everything which has been allocated in the
-- pool itself.
freePool :: Pool -> IO ()
-freePool (Pool pool) = readIORef pool >>= freeAll
- where freeAll [] = return ()
- freeAll (p:ps) = free p >> freeAll ps
+freePool = c_arenaFree
-- | Execute an action with a fresh memory pool, which gets automatically
-- deallocated (including its contents) after the action has finished.
@@ -108,11 +105,7 @@ pooledMalloc pool = pooledMallocBytes pool (sizeOf (undefined :: a))
-- | Allocate the given number of bytes of storage in the pool.
pooledMallocBytes :: Pool -> Int -> IO (Ptr a)
-pooledMallocBytes (Pool pool) size = do
- ptr <- mallocBytes size
- ptrs <- readIORef pool
- writeIORef pool (ptr:ptrs)
- return (castPtr ptr)
+pooledMallocBytes pool size = c_arenaAlloc pool (fromIntegral size)
-- | Adjust the storage area for an element in the pool to the given size of
-- the required type.
@@ -120,16 +113,15 @@ pooledMallocBytes (Pool pool) size = do
pooledRealloc :: forall a . Storable a => Pool -> Ptr a -> IO (Ptr a)
pooledRealloc pool ptr = pooledReallocBytes pool ptr (sizeOf (undefined :: a))
--- | Adjust the storage area for an element in the pool to the given size.
+-- | Adjust the storage area for an element in the pool to the given size. Note
+-- that the previously allocated space is still retained in the same 'Pool' and
+-- will only be freed when the entire 'Pool' is freed.
pooledReallocBytes :: Pool -> Ptr a -> Int -> IO (Ptr a)
-pooledReallocBytes (Pool pool) ptr size = do
- let cPtr = castPtr ptr
- _ <- throwIf (not . (cPtr `elem`)) (\_ -> "pointer not in pool") (readIORef pool)
- newPtr <- reallocBytes cPtr size
- ptrs <- readIORef pool
- writeIORef pool (newPtr : delete cPtr ptrs)
- return (castPtr newPtr)
+pooledReallocBytes pool ptr size = do
+ newPtr <- pooledMallocBytes pool size
+ moveBytes newPtr ptr size
+ return newPtr
-- | Allocate storage for the given number of elements of a storable type in the
-- pool.
@@ -185,3 +177,9 @@ pooledNewArray0 pool marker vals = do
ptr <- pooledMallocArray0 pool (length vals)
pokeArray0 marker ptr vals
return ptr
+
+foreign import ccall unsafe "newArena" c_newArena :: IO Pool
+
+foreign import ccall unsafe "arenaAlloc" c_arenaAlloc :: Pool -> CSize -> IO (Ptr a)
+
+foreign import ccall unsafe "arenaFree" c_arenaFree :: Pool -> IO ()
=====================================
libraries/base/changelog.md
=====================================
@@ -31,8 +31,8 @@
as well as [the migration guide](https://github.com/haskell/core-libraries-committee/blob/main/guides/export-lifta2-prelude.md)
* Update to [Unicode 15.0.0](https://www.unicode.org/versions/Unicode15.0.0/).
* Add standard Unicode case predicates `isUpperCase` and `isLowerCase` to
- `GHC.Unicode` and `Data.Char`. These predicates use the standard Unicode
- case properties and are more intuitive than `isUpper` and `isLower`. See
+ `GHC.Unicode` and `Data.Char`. These predicates use the standard Unicode
+ case properties and are more intuitive than `isUpper` and `isLower`. See
[CLC proposal #90](https://github.com/haskell/core-libraries-committee/issues/90).
* Add `Eq` and `Ord` instances for `Generically1`.
* Relax instances for Functor combinators; put superclass on Class1 and Class2
@@ -50,6 +50,10 @@
* The `Enum` instance of `Down a` now enumerates values in the opposite
order as the `Enum a` instance, per
[CLC proposal #51](https://github.com/haskell/core-libraries-committee/issues/51).
+ * `Foreign.Marshal.Pool` now uses the RTS internal arena instead of libc
+ `malloc` for allocation. It avoids the O(n) overhead of maintaining a list
+ of individually allocated pointers as well as freeing each one of them when
+ freeing a `Pool`. (#14762) (#18338)
## 4.17.0.0 *August 2022*
=====================================
m4/find_llvm_prog.m4
=====================================
@@ -11,7 +11,7 @@
#
AC_DEFUN([FIND_LLVM_PROG],[
# Test for program with and without version name.
- PROG_VERSION_CANDIDATES=$(for llvmVersion in `seq $4 -1 $3`; do echo "$2-$llvmVersion $2-$llvmVersion.0 $2$llvmVersion"; done)
+ PROG_VERSION_CANDIDATES=$(for llvmVersion in `seq $(($4-1)) -1 $3`; do echo "$2-$llvmVersion $2-$llvmVersion.0 $2$llvmVersion"; done)
AC_CHECK_TOOLS([$1], [$PROG_VERSION_CANDIDATES $2], [])
AS_IF([test x"$$1" != x],[
PROG_VERSION=`$$1 --version | awk '/.*version [[0-9\.]]+/{for(i=1;i<=NF;i++){ if(\$i ~ /^[[0-9\.]]+$/){print \$i}}}'`
=====================================
rts/Arena.h
=====================================
@@ -10,13 +10,13 @@
typedef struct _Arena Arena;
// Start a new arena
-RTS_PRIVATE Arena * newArena ( void );
+Arena * newArena ( void );
// Allocate memory in an arena
-RTS_PRIVATE void * arenaAlloc ( Arena *, size_t );
+void * arenaAlloc ( Arena *, size_t );
// Free an entire arena
-RTS_PRIVATE void arenaFree ( Arena * );
+void arenaFree ( Arena * );
// For internal use only:
RTS_PRIVATE unsigned long arenaBlocks( void );
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1388e38149b7098791fef82feef54aeaecd637fe...430d9263f1cf95b40affc5e2cbe6952a33507e39
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1388e38149b7098791fef82feef54aeaecd637fe...430d9263f1cf95b40affc5e2cbe6952a33507e39
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/20221116/6cb5287e/attachment-0001.html>
More information about the ghc-commits
mailing list