[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: Generate LLVM min/max bound policy via Hadrian
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Thu Feb 8 12:41:07 UTC 2024
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
c37931b3 by John Ericson at 2024-02-08T06:39:05-05:00
Generate LLVM min/max bound policy via Hadrian
Per #23966, I want the top-level configure to only generate
configuration data for Hadrian, not do any "real" tasks on its own.
This is part of that effort --- one less file generated by it.
(It is still done with a `.in` file, so in a future world non-Hadrian
also can easily create this file.)
Split modules:
- GHC.CmmToLlvm.Config
- GHC.CmmToLlvm.Version
- GHC.CmmToLlvm.Version.Bounds
- GHC.CmmToLlvm.Version.Type
This also means we can get rid of the silly `unused.h` introduced in
!6803 / 7dfcab2f4bcb7206174ea48857df1883d05e97a2 as temporary kludge.
Part of #23966
- - - - -
9f987235 by Apoorv Ingle at 2024-02-08T06:39:42-05:00
Enable mdo statements to use HsExpansions
Fixes: #24411
Added test T24411 for regression
- - - - -
dffe3b3f by Josh Meredith at 2024-02-08T07:40:47-05:00
JavaScript codegen: Use GHC's tag inference where JS backend-specific evaluation inference was previously used (#24309)
- - - - -
398e9612 by Zubin Duggal at 2024-02-08T07:40:49-05:00
ci: Allow release-hackage-lint to fail
Otherwise it blocks the ghcup metadata pipeline from running.
- - - - -
0324774e by doyougnu at 2024-02-08T07:40:52-05:00
gitlab: js: add codeowners
Fixes:
- #24409
Follow on from:
- #21078 and MR !9133
- When we added the JS backend this was forgotten. This patch adds the
rightful codeowners.
- - - - -
30 changed files:
- .gitignore
- .gitlab-ci.yml
- CODEOWNERS
- compiler/GHC/CmmToLlvm.hs
- compiler/GHC/CmmToLlvm/Base.hs
- compiler/GHC/CmmToLlvm/Config.hs
- + compiler/GHC/CmmToLlvm/Version.hs
- + compiler/GHC/CmmToLlvm/Version/Bounds.hs.in
- + compiler/GHC/CmmToLlvm/Version/Type.hs
- compiler/GHC/JS/JStg/Syntax.hs
- compiler/GHC/Stg/InferTags/Rewrite.hs
- compiler/GHC/StgToJS/Apply.hs
- compiler/GHC/StgToJS/Expr.hs
- compiler/GHC/StgToJS/ExprCtx.hs
- compiler/GHC/StgToJS/Types.hs
- compiler/GHC/StgToJS/Utils.hs
- compiler/GHC/SysTools/Cpp.hs
- compiler/GHC/SysTools/Tasks.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Match.hs
- − compiler/ghc-llvm-version.h.in
- compiler/ghc.cabal.in
- configure.ac
- hadrian/src/Hadrian/Haskell/Cabal/Parse.hs
- hadrian/src/Rules/Generate.hs
- hadrian/src/Rules/Lint.hs
- hadrian/src/Rules/SourceDist.hs
- + testsuite/tests/typecheck/should_run/T24411.hs
- + testsuite/tests/typecheck/should_run/T24411.stdout
- testsuite/tests/typecheck/should_run/all.T
Changes:
=====================================
.gitignore
=====================================
@@ -113,7 +113,7 @@ _darcs/
/compiler/FunTypes.h
/compiler/MachRegs.h
/compiler/MachRegs
-/compiler/ghc-llvm-version.h
+/compiler/GHC/CmmToLlvm/Version/Bounds.hs
/compiler/ghc.cabal
/compiler/ghc.cabal.old
/distrib/configure.ac
@@ -185,8 +185,6 @@ _darcs/
/linter.log
/mk/are-validating.mk
/mk/build.mk
-/mk/unused.h
-/mk/unused.h.in
/mk/config.mk
/mk/config.mk.old
/mk/system-cxx-std-lib-1.0.conf
=====================================
.gitlab-ci.yml
=====================================
@@ -841,6 +841,10 @@ release-hackage-lint:
rules:
- if: '$RELEASE_JOB == "yes"'
extends: .hackage
+ # The ghcup metadata pipeline requires all prior jobs to
+ # pass. The hackage job can easily fail due to API changes
+ # or similar - so we allow it to fail.
+ allow_failure: true
variables:
# No slow-validate bindist on release pipeline
EXTRA_HC_OPTS: "-dlint"
=====================================
CODEOWNERS
=====================================
@@ -52,6 +52,8 @@
/compiler/GHC/Core/Opt/ @simonpj @sgraf
/compiler/GHC/ThToHs.hs @rae
/compiler/GHC/Wasm/ @nrnrnr
+/compiler/GHC/JS/ @luite @doyougnu @hsyl20 @JoshMeredith
+/compiler/GHC/StgToJS/ @luite @doyougnu @hsyl20 @JoshMeredith
[Core libraries]
/libraries/base/ @hvr
=====================================
compiler/GHC/CmmToLlvm.hs
=====================================
@@ -21,6 +21,7 @@ import GHC.CmmToLlvm.Data
import GHC.CmmToLlvm.Ppr
import GHC.CmmToLlvm.Regs
import GHC.CmmToLlvm.Mangler
+import GHC.CmmToLlvm.Version
import GHC.StgToCmm.CgUtils ( fixStgRegisters )
import GHC.Cmm
=====================================
compiler/GHC/CmmToLlvm/Base.hs
=====================================
@@ -41,6 +41,7 @@ import GHC.Utils.Panic
import GHC.Llvm
import GHC.CmmToLlvm.Regs
import GHC.CmmToLlvm.Config
+import GHC.CmmToLlvm.Version
import GHC.Cmm.CLabel
import GHC.Platform.Regs ( activeStgRegs, globalRegMaybe )
=====================================
compiler/GHC/CmmToLlvm/Config.hs
=====================================
@@ -1,34 +1,20 @@
-{-# LANGUAGE CPP #-}
-
-- | Llvm code generator configuration
module GHC.CmmToLlvm.Config
( LlvmCgConfig(..)
, LlvmConfig(..)
, LlvmTarget(..)
, initLlvmConfig
- -- * LLVM version
- , LlvmVersion(..)
- , supportedLlvmVersionLowerBound
- , supportedLlvmVersionUpperBound
- , parseLlvmVersion
- , llvmVersionSupported
- , llvmVersionStr
- , llvmVersionList
)
where
-#include "ghc-llvm-version.h"
-
import GHC.Prelude
import GHC.Platform
import GHC.Utils.Outputable
import GHC.Settings.Utils
import GHC.Utils.Panic
+import GHC.CmmToLlvm.Version.Type (LlvmVersion)
-import Data.Char (isDigit)
-import Data.List (intercalate)
-import qualified Data.List.NonEmpty as NE
import System.FilePath
data LlvmCgConfig = LlvmCgConfig
@@ -94,43 +80,3 @@ data LlvmConfig = LlvmConfig
{ llvmTargets :: [(String, LlvmTarget)]
, llvmPasses :: [(Int, String)]
}
-
-
----------------------------------------------------------
--- LLVM version
----------------------------------------------------------
-
-newtype LlvmVersion = LlvmVersion { llvmVersionNE :: NE.NonEmpty Int }
- deriving (Eq, Ord)
-
-parseLlvmVersion :: String -> Maybe LlvmVersion
-parseLlvmVersion =
- fmap LlvmVersion . NE.nonEmpty . go [] . dropWhile (not . isDigit)
- where
- go vs s
- | null ver_str
- = reverse vs
- | '.' : rest' <- rest
- = go (read ver_str : vs) rest'
- | otherwise
- = reverse (read ver_str : vs)
- where
- (ver_str, rest) = span isDigit s
-
--- | The (inclusive) lower bound on the LLVM Version that is currently supported.
-supportedLlvmVersionLowerBound :: LlvmVersion
-supportedLlvmVersionLowerBound = LlvmVersion (sUPPORTED_LLVM_VERSION_MIN NE.:| [])
-
--- | The (not-inclusive) upper bound bound on the LLVM Version that is currently supported.
-supportedLlvmVersionUpperBound :: LlvmVersion
-supportedLlvmVersionUpperBound = LlvmVersion (sUPPORTED_LLVM_VERSION_MAX NE.:| [])
-
-llvmVersionSupported :: LlvmVersion -> Bool
-llvmVersionSupported v =
- v >= supportedLlvmVersionLowerBound && v < supportedLlvmVersionUpperBound
-
-llvmVersionStr :: LlvmVersion -> String
-llvmVersionStr = intercalate "." . map show . llvmVersionList
-
-llvmVersionList :: LlvmVersion -> [Int]
-llvmVersionList = NE.toList . llvmVersionNE
=====================================
compiler/GHC/CmmToLlvm/Version.hs
=====================================
@@ -0,0 +1,43 @@
+module GHC.CmmToLlvm.Version
+ ( LlvmVersion(..)
+ , supportedLlvmVersionLowerBound
+ , supportedLlvmVersionUpperBound
+ , parseLlvmVersion
+ , llvmVersionSupported
+ , llvmVersionStr
+ , llvmVersionList
+ )
+where
+
+import GHC.Prelude
+
+import GHC.CmmToLlvm.Version.Type
+import GHC.CmmToLlvm.Version.Bounds
+
+import Data.Char (isDigit)
+import Data.List (intercalate)
+import qualified Data.List.NonEmpty as NE
+
+parseLlvmVersion :: String -> Maybe LlvmVersion
+parseLlvmVersion =
+ fmap LlvmVersion . NE.nonEmpty . go [] . dropWhile (not . isDigit)
+ where
+ go vs s
+ | null ver_str
+ = reverse vs
+ | '.' : rest' <- rest
+ = go (read ver_str : vs) rest'
+ | otherwise
+ = reverse (read ver_str : vs)
+ where
+ (ver_str, rest) = span isDigit s
+
+llvmVersionSupported :: LlvmVersion -> Bool
+llvmVersionSupported v =
+ v >= supportedLlvmVersionLowerBound && v < supportedLlvmVersionUpperBound
+
+llvmVersionStr :: LlvmVersion -> String
+llvmVersionStr = intercalate "." . map show . llvmVersionList
+
+llvmVersionList :: LlvmVersion -> [Int]
+llvmVersionList = NE.toList . llvmVersionNE
=====================================
compiler/GHC/CmmToLlvm/Version/Bounds.hs.in
=====================================
@@ -0,0 +1,19 @@
+module GHC.CmmToLlvm.Version.Bounds
+ ( supportedLlvmVersionLowerBound
+ , supportedLlvmVersionUpperBound
+ )
+where
+
+import GHC.Prelude ()
+
+import GHC.CmmToLlvm.Version.Type
+
+import qualified Data.List.NonEmpty as NE
+
+-- | The (inclusive) lower bound on the LLVM Version that is currently supported.
+supportedLlvmVersionLowerBound :: LlvmVersion
+supportedLlvmVersionLowerBound = LlvmVersion (@LlvmMinVersion@ NE.:| [])
+
+-- | The (not-inclusive) upper bound bound on the LLVM Version that is currently supported.
+supportedLlvmVersionUpperBound :: LlvmVersion
+supportedLlvmVersionUpperBound = LlvmVersion (@LlvmMaxVersion@ NE.:| [])
=====================================
compiler/GHC/CmmToLlvm/Version/Type.hs
=====================================
@@ -0,0 +1,11 @@
+module GHC.CmmToLlvm.Version.Type
+ ( LlvmVersion(..)
+ )
+where
+
+import GHC.Prelude
+
+import qualified Data.List.NonEmpty as NE
+
+newtype LlvmVersion = LlvmVersion { llvmVersionNE :: NE.NonEmpty Int }
+ deriving (Eq, Ord)
=====================================
compiler/GHC/JS/JStg/Syntax.hs
=====================================
@@ -70,6 +70,7 @@ module GHC.JS.JStg.Syntax
) where
import GHC.Prelude
+import GHC.Utils.Outputable
import GHC.JS.Ident
@@ -148,6 +149,16 @@ data JStgExpr
| ApplExpr JStgExpr [JStgExpr] -- ^ Application
deriving (Eq, Typeable, Generic)
+instance Outputable JStgExpr where
+ ppr x = case x of
+ ValExpr _ -> text ("ValExpr" :: String)
+ SelExpr x' _ -> text ("SelExpr" :: String) <+> ppr x'
+ IdxExpr x' y' -> text ("IdxExpr" :: String) <+> ppr (x', y')
+ InfixExpr _ x' y' -> text ("InfixExpr" :: String) <+> ppr (x', y')
+ UOpExpr _ x' -> text ("UOpExpr" :: String) <+> ppr x'
+ IfExpr p t e -> text ("IfExpr" :: String) <+> ppr (p, t, e)
+ ApplExpr x' xs -> text ("ApplExpr" :: String) <+> ppr (x', xs)
+
-- * Useful pattern synonyms to ease programming with the deeply embedded JS
-- AST. Each pattern wraps @UOp@ and @Op@ into a @JStgExpr at s to save typing and
-- for convienience. In addition we include a string wrapper for JS string
=====================================
compiler/GHC/Stg/InferTags/Rewrite.hs
=====================================
@@ -7,7 +7,7 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeFamilies #-}
-module GHC.Stg.InferTags.Rewrite (rewriteTopBinds)
+module GHC.Stg.InferTags.Rewrite (rewriteTopBinds, rewriteOpApp)
where
import GHC.Prelude
@@ -388,15 +388,15 @@ rewriteId v = do
if is_tagged then return $! setIdTagSig v (TagSig TagProper)
else return v
-rewriteExpr :: InferStgExpr -> RM TgStgExpr
-rewriteExpr (e at StgCase {}) = rewriteCase e
-rewriteExpr (e at StgLet {}) = rewriteLet e
-rewriteExpr (e at StgLetNoEscape {}) = rewriteLetNoEscape e
-rewriteExpr (StgTick t e) = StgTick t <$!> rewriteExpr e
-rewriteExpr e@(StgConApp {}) = rewriteConApp e
-rewriteExpr e@(StgOpApp {}) = rewriteOpApp e
-rewriteExpr e@(StgApp {}) = rewriteApp e
-rewriteExpr (StgLit lit) = return $! (StgLit lit)
+rewriteExpr :: GenStgExpr 'InferTaggedBinders -> RM (GenStgExpr 'CodeGen)
+rewriteExpr (e at StgCase {}) = rewriteCase e
+rewriteExpr (e at StgLet {}) = rewriteLet e
+rewriteExpr (e at StgLetNoEscape {}) = rewriteLetNoEscape e
+rewriteExpr (StgTick t e) = StgTick t <$!> rewriteExpr e
+rewriteExpr e@(StgConApp {}) = rewriteConApp e
+rewriteExpr e@(StgApp {}) = rewriteApp e
+rewriteExpr (StgLit lit) = return $! (StgLit lit)
+rewriteExpr (StgOpApp op args res_ty) = (StgOpApp op) <$!> rewriteArgs args <*> pure res_ty
rewriteCase :: InferStgExpr -> RM TgStgExpr
@@ -404,7 +404,7 @@ rewriteCase (StgCase scrut bndr alt_type alts) =
withBinder NotTopLevel bndr $
pure StgCase <*>
rewriteExpr scrut <*>
- pure (fst bndr) <*>
+ rewriteId (fst bndr) <*>
pure alt_type <*>
mapM rewriteAlt alts
=====================================
compiler/GHC/StgToJS/Apply.hs
=====================================
@@ -157,7 +157,7 @@ genApp ctx i args
| [] <- args
, [vt] <- idJSRep i
, isUnboxable vt
- , ctxIsEvaluated ctx i
+ , ctxIsEvaluated i
= do
let c = head (concatMap typex_expr $ ctxTarget ctx)
is <- varsForId i
@@ -171,7 +171,7 @@ genApp ctx i args
-- case of Id without args and known to be already evaluated: return fields
-- individually
| [] <- args
- , ctxIsEvaluated ctx i || isStrictType (idType i)
+ , ctxIsEvaluated i || isStrictType (idType i)
= do
a <- storeIdFields i (ctxTarget ctx)
-- optional runtime assert for detecting unexpected thunks (unevaluated)
@@ -199,7 +199,7 @@ genApp ctx i args
a' = case args of
[StgVarArg a'] -> a'
_ -> panic "genApp: unexpected arg"
- if isStrictId a' || ctxIsEvaluated ctx a'
+ if isStrictId a' || ctxIsEvaluated a'
then return (t |= ai, ExprInline Nothing)
else return (returnS (app "h$e" [ai]), ExprCont)
_ -> panic "genApp: invalid size"
=====================================
compiler/GHC/StgToJS/Expr.hs
=====================================
@@ -137,12 +137,12 @@ genBind ctx bndr =
j <- assign b r >>= \case
Just ja -> return ja
Nothing -> allocCls Nothing [(b,r)]
- return (j, addEvalRhs ctx [(b,r)])
+ return (j, ctx)
StgRec bs -> do
jas <- mapM (uncurry assign) bs -- fixme these might depend on parts initialized by allocCls
let m = if null jas then Nothing else Just (mconcat $ catMaybes jas)
j <- allocCls m . map snd . filter (isNothing . fst) $ zip jas bs
- return (j, addEvalRhs ctx bs)
+ return (j, ctx)
where
ctx' = ctxClearLneFrame ctx
@@ -168,7 +168,7 @@ genBind ctx bndr =
(tgt ||= ApplExpr (var ("h$c_sel_" <> mkFastString sel_tag)) [the_fvj])
_ -> panic "genBind.assign: invalid size"
assign b (StgRhsClosure _ext _ccs _upd [] expr _typ)
- | snd (isInlineExpr (ctxEvaluatedIds ctx) expr) = do
+ | isInlineExpr expr = do
d <- declVarsForId b
tgt <- varsForId b
let ctx' = ctx { ctxTarget = assocIdExprs b tgt }
@@ -177,12 +177,6 @@ genBind ctx bndr =
assign _b StgRhsCon{} = return Nothing
assign b r = genEntry ctx' b r >> return Nothing
- addEvalRhs c [] = c
- addEvalRhs c ((b,r):xs)
- | StgRhsCon{} <- r = addEvalRhs (ctxAssertEvaluated b c) xs
- | (StgRhsClosure _ _ ReEntrant _ _ _) <- r = addEvalRhs (ctxAssertEvaluated b c) xs
- | otherwise = addEvalRhs c xs
-
genBindLne :: HasDebugCallStack
=> ExprCtx
-> CgStgBinding
@@ -559,7 +553,7 @@ genCase :: HasDebugCallStack
-> LiveVars
-> G (JStgStat, ExprResult)
genCase ctx bnd e at alts l
- | snd (isInlineExpr (ctxEvaluatedIds ctx) e) = do
+ | isInlineExpr e = do
bndi <- identsForId bnd
let ctx' = ctxSetTop bnd
$ ctxSetTarget (assocIdExprs bnd (map toJExpr bndi))
@@ -570,7 +564,7 @@ genCase ctx bnd e at alts l
ExprCont -> pprPanic "genCase: expression was not inline"
(pprStgExpr panicStgPprOpts e)
- (aj, ar) <- genAlts (ctxAssertEvaluated bnd ctx) bnd at d alts
+ (aj, ar) <- genAlts ctx bnd at d alts
(saveCCS,restoreCCS) <- ifProfilingM $ do
ccsVar <- freshIdent
pure ( ccsVar ||= toJExpr jCurrentCCS
@@ -586,7 +580,7 @@ genCase ctx bnd e at alts l
, ar
)
| otherwise = do
- rj <- genRet (ctxAssertEvaluated bnd ctx) bnd at alts l
+ rj <- genRet ctx bnd at alts l
let ctx' = ctxSetTop bnd
$ ctxSetTarget (assocIdExprs bnd (map toJExpr [R1 ..]))
$ ctx
=====================================
compiler/GHC/StgToJS/ExprCtx.hs
=====================================
@@ -18,14 +18,12 @@
module GHC.StgToJS.ExprCtx
( ExprCtx
, initExprCtx
- , ctxAssertEvaluated
, ctxIsEvaluated
, ctxSetSrcSpan
, ctxSrcSpan
, ctxSetTop
, ctxTarget
, ctxSetTarget
- , ctxEvaluatedIds
-- * Let-no-escape
, ctxClearLneFrame
, ctxUpdateLneFrame
@@ -43,9 +41,12 @@ import GHC.Prelude
import GHC.StgToJS.Types
import GHC.Types.Unique.FM
-import GHC.Types.Unique.Set
import GHC.Types.Var
import GHC.Types.SrcLoc
+import GHC.Types.Id
+import GHC.Types.Id.Info
+
+import GHC.Stg.InferTags.TagSig
import GHC.Utils.Outputable
import GHC.Utils.Panic
@@ -61,10 +62,6 @@ data ExprCtx = ExprCtx
, ctxTarget :: [TypedExpr]
-- ^ Target variables for the evaluated expression
- , ctxEvaluatedIds :: UniqSet Id
- -- ^ Ids that we know to be evaluated (e.g. case binders when the expression
- -- to evaluate is in an alternative)
-
, ctxSrcSpan :: Maybe RealSrcSpan
-- ^ Source location
@@ -95,7 +92,6 @@ initExprCtx :: Id -> ExprCtx
initExprCtx i = ExprCtx
{ ctxTop = i
, ctxTarget = []
- , ctxEvaluatedIds = emptyUniqSet
, ctxLneFrameBs = emptyUFM
, ctxLneFrameVars = []
, ctxLneFrameSize = 0
@@ -110,10 +106,6 @@ ctxSetTarget t ctx = ctx { ctxTarget = t }
ctxSetTop :: Id -> ExprCtx -> ExprCtx
ctxSetTop i ctx = ctx { ctxTop = i }
--- | Add an Id to the known-evaluated set
-ctxAssertEvaluated :: Id -> ExprCtx -> ExprCtx
-ctxAssertEvaluated i ctx = ctx { ctxEvaluatedIds = addOneToUniqSet (ctxEvaluatedIds ctx) i }
-
-- | Set source location
ctxSetSrcSpan :: RealSrcSpan -> ExprCtx -> ExprCtx
ctxSetSrcSpan span ctx = ctx { ctxSrcSpan = Just span }
@@ -139,8 +131,39 @@ ctxClearLneFrame ctx =
}
-- | Predicate: do we know for sure that the given Id is evaluated?
-ctxIsEvaluated :: ExprCtx -> Id -> Bool
-ctxIsEvaluated ctx i = i `elementOfUniqSet` ctxEvaluatedIds ctx
+ctxIsEvaluated :: Id -> Bool
+ctxIsEvaluated i =
+ maybe False isTaggedSig (idTagSig_maybe i)
+ && go (idDetails i)
+ where
+ go JoinId{} = False
+ go _ = True
+
+
+ -- DFunId new_type -> not new_type
+ -- -- DFuns terminate, unless the dict is implemented
+ -- -- with a newtype in which case they may not
+
+ -- DataConWorkId {} -> True
+
+ -- ClassOpId {} -> False
+ -- -- suppose an argument, and we don't have one
+
+ -- PrimOpId op _ -> primop_ok op
+ -- -- probably already handled by StgOpApp
+
+ -- JoinId {} -> False
+ -- -- Don't speculate join points
+
+ -- TickBoxOpId {} -> False
+ -- -- Don't speculate box ticking
+
+ -- -- Tagged (evaluated) ids
+ -- _ | Just sig <- idTagSig_maybe i
+ -- , isTaggedSig sig
+ -- -> True
+
+ -- _ -> False
-- | Does the given Id correspond to a LNE binding
ctxIsLneBinding :: ExprCtx -> Id -> Bool
=====================================
compiler/GHC/StgToJS/Types.hs
=====================================
@@ -342,6 +342,9 @@ data TypedExpr = TypedExpr
, typex_expr :: [JStgExpr]
}
+instance Outputable TypedExpr where
+ ppr (TypedExpr typ x) = ppr (typ, x)
+
-- | A Primop result is either an inlining of some JS payload, or a primitive
-- call to a JS function defined in Shim files in base.
data PrimRes
=====================================
compiler/GHC/StgToJS/Utils.hs
=====================================
@@ -69,7 +69,6 @@ import GHC.Types.Var.Set
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.Unique.FM
-import GHC.Types.Unique.Set
import GHC.Types.ForeignCall
import GHC.Types.TyThing
import GHC.Types.Name
@@ -108,11 +107,16 @@ assignToExprCtx ctx es = assignToTypedExprs (ctxTarget ctx) es
assignCoerce1 :: [TypedExpr] -> [TypedExpr] -> JStgStat
assignCoerce1 [x] [y] = assignCoerce x y
assignCoerce1 [] [] = mempty
-assignCoerce1 _x _y = pprPanic "assignCoerce1"
+-- We silently ignore the case of an empty list on the first argument. It denotes
+-- "assign nothing to n empty slots on the right". Usually this case shouldn't come
+-- up, but rare cases where the earlier code can't correctly guess the size of type
+-- classes causes slots to be allocated when they aren't needed.
+assignCoerce1 [] _ = mempty
+assignCoerce1 x y = pprPanic "assignCoerce1"
(vcat [ text "lengths do not match"
-- FIXME: Outputable instance removed until JStg replaces JStat
- -- , ppr x
- -- , ppr y
+ , ppr x
+ , ppr y
])
-- | Assign p2 to p1 with optional coercion
@@ -417,61 +421,48 @@ stgLneLiveExpr rhs = dVarSetElems (liveVars $ stgRhsLive rhs)
-- stgLneLiveExpr StgRhsCon {} = []
-- | returns True if the expression is definitely inline
-isInlineExpr :: UniqSet Id -> CgStgExpr -> (UniqSet Id, Bool)
-isInlineExpr v = \case
+isInlineExpr :: CgStgExpr -> Bool
+isInlineExpr = \case
StgApp i args
- -> (emptyUniqSet, isInlineApp v i args)
+ -> isInlineApp i args
StgLit{}
- -> (emptyUniqSet, True)
+ -> True
StgConApp{}
- -> (emptyUniqSet, True)
+ -> True
StgOpApp (StgFCallOp f _) _ _
- -> (emptyUniqSet, isInlineForeignCall f)
+ -> isInlineForeignCall f
StgOpApp (StgPrimOp SeqOp) [StgVarArg e] t
- -> (emptyUniqSet, e `elementOfUniqSet` v || isStrictType t)
+ -> ctxIsEvaluated e || isStrictType t
StgOpApp (StgPrimOp op) _ _
- -> (emptyUniqSet, primOpIsReallyInline op)
+ -> primOpIsReallyInline op
StgOpApp (StgPrimCallOp _c) _ _
- -> (emptyUniqSet, True)
- StgCase e b _ alts
- ->let (_ve, ie) = isInlineExpr v e
- v' = addOneToUniqSet v b
- (vas, ias) = unzip $ map (isInlineExpr v') (fmap alt_rhs alts)
- vr = L.foldl1' intersectUniqSets vas
- in (vr, (ie || b `elementOfUniqSet` v) && and ias)
- StgLet _ b e
- -> isInlineExpr (inspectInlineBinding v b) e
- StgLetNoEscape _ _b e
- -> isInlineExpr v e
- StgTick _ e
- -> isInlineExpr v e
-
-inspectInlineBinding :: UniqSet Id -> CgStgBinding -> UniqSet Id
-inspectInlineBinding v = \case
- StgNonRec i r -> inspectInlineRhs v i r
- StgRec bs -> foldl' (\v' (i,r) -> inspectInlineRhs v' i r) v bs
-
-inspectInlineRhs :: UniqSet Id -> Id -> CgStgRhs -> UniqSet Id
-inspectInlineRhs v i = \case
- StgRhsCon{} -> addOneToUniqSet v i
- StgRhsClosure _ _ ReEntrant _ _ _ -> addOneToUniqSet v i
- _ -> v
+ -> True
+ StgCase e _ _ alts
+ ->let ie = isInlineExpr e
+ ias = map isInlineExpr (fmap alt_rhs alts)
+ in ie && and ias
+ StgLet _ _ e
+ -> isInlineExpr e
+ StgLetNoEscape _ _ e
+ -> isInlineExpr e
+ StgTick _ e
+ -> isInlineExpr e
isInlineForeignCall :: ForeignCall -> Bool
isInlineForeignCall (CCall (CCallSpec _ cconv safety)) =
not (playInterruptible safety) &&
not (cconv /= JavaScriptCallConv && playSafe safety)
-isInlineApp :: UniqSet Id -> Id -> [StgArg] -> Bool
-isInlineApp v i = \case
+isInlineApp :: Id -> [StgArg] -> Bool
+isInlineApp i = \case
_ | isJoinId i -> False
[] -> isUnboxedTupleType (idType i) ||
isStrictType (idType i) ||
- i `elementOfUniqSet` v
+ ctxIsEvaluated i
[StgVarArg a]
| DataConWrapId dc <- idDetails i
, isNewTyCon (dataConTyCon dc)
- , isStrictType (idType a) || a `elementOfUniqSet` v || isStrictId a
+ , isStrictType (idType a) || ctxIsEvaluated a || isStrictId a
-> True
_ -> False
=====================================
compiler/GHC/SysTools/Cpp.hs
=====================================
@@ -15,7 +15,7 @@ where
import GHC.Prelude
import GHC.Driver.Session
import GHC.Driver.Backend
-import GHC.CmmToLlvm.Config
+import GHC.CmmToLlvm.Version
import GHC.Platform
import GHC.Platform.ArchOS
=====================================
compiler/GHC/SysTools/Tasks.hs
=====================================
@@ -12,7 +12,7 @@ module GHC.SysTools.Tasks where
import GHC.Prelude
import GHC.ForeignSrcLang
-import GHC.CmmToLlvm.Config (LlvmVersion, llvmVersionStr, supportedLlvmVersionUpperBound, parseLlvmVersion, supportedLlvmVersionLowerBound)
+import GHC.CmmToLlvm.Version (LlvmVersion, llvmVersionStr, supportedLlvmVersionUpperBound, parseLlvmVersion, supportedLlvmVersionLowerBound)
import GHC.Settings
=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -791,6 +791,9 @@ addArgCtxt :: AppCtxt -> LHsExpr GhcRn
-- b. Or, we are typechecking the second argument which would be a generated lambda
-- so we set the location to be whatever the location in the context is
-- See Note [Expanding HsDo with XXExprGhcRn] in GHC.Tc.Gen.Do
+-- For future: we need a cleaner way of doing this bit of adding the right error context.
+-- There is a delicate dance of looking at source locations and reconstructing
+-- whether the piece of code is a `do`-expanded code or some other expanded code.
addArgCtxt ctxt (L arg_loc arg) thing_inside
= do { in_generated_code <- inGeneratedCode
; case ctxt of
=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -364,10 +364,9 @@ tcDoStmts doExpr@(DoExpr _) ss@(L l stmts) res_ty
; mkExpandedExprTc (HsDo noExtField doExpr ss) <$> tcExpr (unLoc expanded_expr) res_ty }
}
-tcDoStmts mDoExpr@(MDoExpr _) (L l stmts) res_ty
- = do { stmts' <- tcStmts (HsDoStmt mDoExpr) tcDoStmt stmts res_ty
- ; res_ty <- readExpType res_ty
- ; return (HsDo res_ty mDoExpr (L l stmts')) }
+tcDoStmts mDoExpr@(MDoExpr _) ss@(L _ stmts) res_ty
+ = do { expanded_expr <- expandDoStmts mDoExpr stmts -- Do expansion on the fly
+ ; mkExpandedExprTc (HsDo noExtField mDoExpr ss) <$> tcExpr (unLoc expanded_expr) res_ty }
tcDoStmts MonadComp (L l stmts) res_ty
= do { stmts' <- tcStmts (HsDoStmt MonadComp) tcMcStmt stmts res_ty
=====================================
compiler/ghc-llvm-version.h.in deleted
=====================================
@@ -1,10 +0,0 @@
-#if !defined(__GHC_LLVM_VERSION_H__)
-#define __GHC_LLVM_VERSION_H__
-
-/* The maximum supported LLVM version number */
-#undef sUPPORTED_LLVM_VERSION_MAX
-
-/* The minimum supported LLVM version number */
-#undef sUPPORTED_LLVM_VERSION_MIN
-
-#endif /* __GHC_LLVM_VERSION_H__ */
=====================================
compiler/ghc.cabal.in
=====================================
@@ -47,7 +47,6 @@ extra-source-files:
MachRegs/s390x.h
MachRegs/wasm32.h
MachRegs/x86.h
- ghc-llvm-version.h
custom-setup
@@ -92,7 +91,6 @@ Library
Bytecodes.h
ClosureTypes.h
FunTypes.h
- ghc-llvm-version.h
if flag(build-tool-depends)
build-tool-depends: alex:alex >= 3.2.6, happy:happy >= 1.20.0, genprimopcode:genprimopcode, deriveConstants:deriveConstants
@@ -319,6 +317,9 @@ Library
GHC.CmmToLlvm.Mangler
GHC.CmmToLlvm.Ppr
GHC.CmmToLlvm.Regs
+ GHC.CmmToLlvm.Version
+ GHC.CmmToLlvm.Version.Bounds
+ GHC.CmmToLlvm.Version.Type
GHC.Cmm.Dominators
GHC.Cmm.Reducibility
GHC.Cmm.Type
=====================================
configure.ac
=====================================
@@ -80,18 +80,6 @@ dnl #define SIZEOF_CHAR 0
dnl recently.
AC_PREREQ([2.69])
-# -------------------------------------------------------------------------
-# Prepare to generate the following header files
-#
-
-dnl so the next header, which is manually maintained, doesn't get
-dnl overwritten by an autogenerated header. Once we have no more
-dnl `AC_CONFIG_HEADER` calls (issue #23966) we can delete all mention
-dnl of `mk/unused.h`.
-AC_CONFIG_HEADER(mk/unused.h)
-# This one is manually maintained.
-AC_CONFIG_HEADER(compiler/ghc-llvm-version.h)
-
# No, semi-sadly, we don't do `--srcdir'...
if test x"$srcdir" != 'x.' ; then
echo "This configuration does not support the \`--srcdir' option.."
@@ -507,10 +495,6 @@ LlvmMinVersion=13 # inclusive
LlvmMaxVersion=16 # not inclusive
AC_SUBST([LlvmMinVersion])
AC_SUBST([LlvmMaxVersion])
-sUPPORTED_LLVM_VERSION_MIN=$(echo \($LlvmMinVersion\) | sed 's/\./,/')
-sUPPORTED_LLVM_VERSION_MAX=$(echo \($LlvmMaxVersion\) | sed 's/\./,/')
-AC_DEFINE_UNQUOTED([sUPPORTED_LLVM_VERSION_MIN], ${sUPPORTED_LLVM_VERSION_MIN}, [The minimum supported LLVM version number])
-AC_DEFINE_UNQUOTED([sUPPORTED_LLVM_VERSION_MAX], ${sUPPORTED_LLVM_VERSION_MAX}, [The maximum supported LLVM version number])
ConfiguredEmsdkVersion="${EmsdkVersion}"
AC_SUBST([ConfiguredEmsdkVersion])
=====================================
hadrian/src/Hadrian/Haskell/Cabal/Parse.hs
=====================================
@@ -125,6 +125,17 @@ biModules pd = go [ comp | comp@(bi,_,_,_) <-
go [x] = x
go _ = error "Cannot handle more than one buildinfo yet."
+-- Extra files needed prior to configuring.
+--
+-- These should be "static" source files: ones whose contents do not
+-- change based on the build configuration, and ones which are therefore
+-- also safe to include in sdists for package-level builds.
+--
+-- Put another way, while Hadrian knows these are generated, Cabal
+-- should just think they are regular source files.
+extraPreConfigureDeps :: [String]
+extraPreConfigureDeps = ["compiler/GHC/CmmToLlvm/Version/Bounds.hs"]
+
-- TODO: Track command line arguments and package configuration flags.
-- | Configure a package using the Cabal library by collecting all the command
-- line arguments (to be passed to the setup script) and package configuration
@@ -141,7 +152,7 @@ configurePackage context at Context {..} = do
-- We'll need those packages in our package database.
deps <- sequence [ pkgConfFile (context { package = pkg })
| pkg <- depPkgs, pkg `elem` stagePkgs ]
- need deps
+ need $ extraPreConfigureDeps ++ deps
-- Figure out what hooks we need.
let configureFile = replaceFileName (pkgCabalFile package) "configure"
=====================================
hadrian/src/Rules/Generate.hs
=====================================
@@ -71,9 +71,12 @@ rtsDependencies = do
compilerDependencies :: Expr [FilePath]
compilerDependencies = do
+ let fixed = ("compiler" -/-) <$>
+ [ "GHC/CmmToLlvm/Version/Bounds.hs"
+ ]
stage <- getStage
ghcPath <- expr $ buildPath (vanillaContext stage compiler)
- pure $ (ghcPath -/-) <$>
+ let buildSpecific = (ghcPath -/-) <$>
[ "primop-code-size.hs-incl"
, "primop-commutable.hs-incl"
, "primop-data-decl.hs-incl"
@@ -94,6 +97,7 @@ compilerDependencies = do
, "GHC/Platform/Constants.hs"
, "GHC/Settings/Config.hs"
]
+ pure $ fixed ++ buildSpecific
generatedDependencies :: Expr [FilePath]
generatedDependencies = do
@@ -332,6 +336,10 @@ templateRules = do
, interpolateSetting "LlvmMinVersion" LlvmMinVersion
, interpolateSetting "LlvmMaxVersion" LlvmMaxVersion
]
+ templateRule "compiler/GHC/CmmToLlvm/Version/Bounds.hs" $ mconcat
+ [ interpolateVar "LlvmMinVersion" $ replaceEq '.' ',' <$> setting LlvmMinVersion
+ , interpolateVar "LlvmMaxVersion" $ replaceEq '.' ',' <$> setting LlvmMaxVersion
+ ]
-- Generators
=====================================
hadrian/src/Rules/Lint.hs
=====================================
@@ -92,7 +92,8 @@ compiler = do
let compilerDir = "compiler"
let ghcautoconf = stage1RtsInc </> "ghcautoconf.h"
let ghcplatform = stage1RtsInc </> "ghcplatform.h"
- need $ mconcat [[ghcautoconf, ghcplatform], hsIncls stage1Compiler, [machDeps]]
+ let ghcLlvmVersion = compilerDir </> "GHC/CmmToLlvm/Version/Bounds.hs"
+ need $ mconcat [[ghcautoconf, ghcplatform, ghcLlvmVersion], hsIncls stage1Compiler, [machDeps]]
let includeDirs =
[ stage1RtsInc
, compilerDir
=====================================
hadrian/src/Rules/SourceDist.hs
=====================================
@@ -156,7 +156,6 @@ prepareTree dest = do
, pkgPath terminfo -/- "configure"
, "configure"
, "aclocal.m4"
- , "mk" -/- "unused.h.in"
]
copyAlexHappyFiles =
=====================================
testsuite/tests/typecheck/should_run/T24411.hs
=====================================
@@ -0,0 +1,18 @@
+{-# LANGUAGE ImpredicativeTypes, RecursiveDo #-}
+
+type Id = forall a. a -> a
+
+t :: IO Id
+t = return id
+
+p :: Id -> (Bool, Int)
+p f = (f True, f 3)
+
+foo1 = t >>= \x -> return (p x)
+
+foo2 = mdo { x <- t ; return (p x) }
+
+main = do x <- foo2
+ y <- foo1
+ putStrLn $ show x
+ putStrLn $ show y
=====================================
testsuite/tests/typecheck/should_run/T24411.stdout
=====================================
@@ -0,0 +1,2 @@
+(True,3)
+(True,3)
=====================================
testsuite/tests/typecheck/should_run/all.T
=====================================
@@ -176,3 +176,4 @@ test('T23761b', normal, compile_and_run, [''])
test('T18324', normal, compile_and_run, [''])
test('T15598', normal, compile_and_run, [''])
test('T22086', normal, compile_and_run, [''])
+test('T24411', normal, compile_and_run, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/cc83c2a95b9e62d53adbb4647c21310ec2ac523c...0324774ec36b61bc7ce31c91adee08b6b5992416
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/cc83c2a95b9e62d53adbb4647c21310ec2ac523c...0324774ec36b61bc7ce31c91adee08b6b5992416
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/20240208/ad650753/attachment-0001.html>
More information about the ghc-commits
mailing list