Commit 20b6bd5b authored by Ben Gamari's avatar Ben Gamari 🐢

Merge branch 'wip/ghc-8.8-merges' into ghc-8.8

parents 0f1266b1 9ce7a945
......@@ -30,7 +30,7 @@ find an overview here:
Next, clone the repository and all the associated libraries:
```
$ git clone --recursive git://git.haskell.org/ghc.git
$ git clone --recursive git@gitlab.haskell.org:ghc/ghc.git
```
On Windows, you need an extra repository containing some build tools.
......
......@@ -26,7 +26,7 @@ There are two ways to get a source tree:
2. *Check out the source code from git*
$ git clone --recursive git://git.haskell.org/ghc.git
$ git clone --recursive git@gitlab.haskell.org:ghc/ghc.git
Note: cloning GHC from Github requires a special setup. See [Getting a GHC
repository from Github][7].
......
......@@ -16,6 +16,11 @@ parser.add_argument('--validate', action='store_true', help='Run in validate mod
parser.add_argument('--hadrian', action='store_true', help='Do not assume the make base build system')
args = parser.parse_args()
# Packages whose libraries aren't in the submodule root
EXCEPTIONS = {
'libraries/containers/': 'libraries/containers/containers/'
}
def print_err(s):
print(dedent(s), file=sys.stderr)
......@@ -50,7 +55,7 @@ def check_for_url_rewrites():
Or start over, and clone the GHC repository from the haskell server:
git clone --recursive git://git.haskell.org/ghc.git
git clone --recursive git@gitlab.haskell.org:ghc/ghc.git
For more information, see:
* https://ghc.haskell.org/trac/ghc/wiki/Newcomers or
......@@ -78,7 +83,7 @@ def check_boot_packages():
# but in an lndir tree we avoid making .git directories,
# so it doesn't exist. We therefore require that every repo
# has a LICENSE file instead.
license_path = os.path.join(dir_, 'LICENSE')
license_path = os.path.join(EXCEPTIONS.get(dir_+'/', dir_), 'LICENSE')
if not os.path.isfile(license_path):
die("""\
Error: %s doesn't exist
......@@ -91,9 +96,12 @@ def boot_pkgs():
for package in glob.glob("libraries/*/"):
packages_file = os.path.join(package, 'ghc-packages')
print(package)
if os.path.isfile(packages_file):
for subpkg in open(packages_file, 'r'):
library_dirs.append(os.path.join(package, subpkg.strip()))
elif package in EXCEPTIONS:
library_dirs.append(EXCEPTIONS[package])
else:
library_dirs.append(package)
......
......@@ -511,9 +511,17 @@ hasNoBinding :: Id -> Bool
-- Data constructor workers used to be things of this kind, but
-- they aren't any more. Instead, we inject a binding for
-- them at the CorePrep stage.
--
-- 'PrimOpId's also used to be of this kind. See Note [Primop wrappers] in PrimOp.hs.
-- for the history of this.
--
-- Note that CorePrep currently eta expands things no-binding things and this
-- can cause quite subtle bugs. See Note [Eta expansion of hasNoBinding things
-- in CorePrep] in CorePrep for details.
--
-- EXCEPT: unboxed tuples, which definitely have no binding
hasNoBinding id = case Var.idDetails id of
PrimOpId _ -> True -- See Note [Primop wrappers]
PrimOpId _ -> False -- See Note [Primop wrappers] in PrimOp.hs
FCallId _ -> True
DataConWorkId dc -> isUnboxedTupleCon dc || isUnboxedSumCon dc
_ -> isCompulsoryUnfolding (idUnfolding id)
......@@ -557,19 +565,6 @@ The easiest way to do this is for hasNoBinding to return True of all things
that have compulsory unfolding. A very Ids with a compulsory unfolding also
have a binding, but it does not harm to say they don't here, and its a very
simple way to fix Trac #14561.
Note [Primop wrappers]
~~~~~~~~~~~~~~~~~~~~~~
Currently hasNoBinding claims that PrimOpIds don't have a curried
function definition. But actually they do, in GHC.PrimopWrappers,
which is auto-generated from prelude/primops.txt.pp. So actually, hasNoBinding
could return 'False' for PrimOpIds.
But we'd need to add something in CoreToStg to swizzle any unsaturated
applications of GHC.Prim.plusInt# to GHC.PrimopWrappers.plusInt#.
Nota Bene: GHC.PrimopWrappers is needed *regardless*, because it's
used by GHCi, which does not implement primops direct at all.
-}
isDeadBinder :: Id -> Bool
......
......@@ -19,7 +19,7 @@ module PatSyn (
patSynInstArgTys, patSynInstResTy, patSynFieldLabels,
patSynFieldType,
tidyPatSynIds, pprPatSynType
updatePatSynIds, pprPatSynType
) where
#include "HsVersions.h"
......@@ -417,8 +417,8 @@ patSynMatcher = psMatcher
patSynBuilder :: PatSyn -> Maybe (Id, Bool)
patSynBuilder = psBuilder
tidyPatSynIds :: (Id -> Id) -> PatSyn -> PatSyn
tidyPatSynIds tidy_fn ps@(MkPatSyn { psMatcher = matcher, psBuilder = builder })
updatePatSynIds :: (Id -> Id) -> PatSyn -> PatSyn
updatePatSynIds tidy_fn ps@(MkPatSyn { psMatcher = matcher, psBuilder = builder })
= ps { psMatcher = tidy_pr matcher, psBuilder = fmap tidy_pr builder }
where
tidy_pr (id, dummy) = (tidy_fn id, dummy)
......
......@@ -46,7 +46,7 @@ module Unique (
-- now all the built-in Uniques (and functions to make them)
-- [the Oh-So-Wonderful Haskell module system wins again...]
mkAlphaTyVarUnique,
mkPrimOpIdUnique,
mkPrimOpIdUnique, mkPrimOpWrapperUnique,
mkPreludeMiscIdUnique, mkPreludeDataConUnique,
mkPreludeTyConUnique, mkPreludeClassUnique,
mkCoVarUnique,
......@@ -368,6 +368,8 @@ mkPreludeClassUnique :: Int -> Unique
mkPreludeTyConUnique :: Int -> Unique
mkPreludeDataConUnique :: Arity -> Unique
mkPrimOpIdUnique :: Int -> Unique
-- See Note [Primop wrappers] in PrimOp.hs.
mkPrimOpWrapperUnique :: Int -> Unique
mkPreludeMiscIdUnique :: Int -> Unique
mkCoVarUnique :: Int -> Unique
......@@ -405,7 +407,8 @@ dataConWorkerUnique u = incrUnique u
dataConTyRepNameUnique u = stepUnique u 2
--------------------------------------------------
mkPrimOpIdUnique op = mkUnique '9' op
mkPrimOpIdUnique op = mkUnique '9' (2*op)
mkPrimOpWrapperUnique op = mkUnique '9' (2*op+1)
mkPreludeMiscIdUnique i = mkUnique '0' i
-- The "tyvar uniques" print specially nicely: a, b, c, etc.
......
......@@ -589,6 +589,7 @@ data CallishMachOp
| MO_SubIntC Width
| MO_U_Mul2 Width
| MO_ReadBarrier
| MO_WriteBarrier
| MO_Touch -- Keep variables live (when using interior pointers)
......
......@@ -998,6 +998,7 @@ machOps = listToUFM $
callishMachOps :: UniqFM ([CmmExpr] -> (CallishMachOp, [CmmExpr]))
callishMachOps = listToUFM $
map (\(x, y) -> (mkFastString x, y)) [
( "read_barrier", (,) MO_ReadBarrier ),
( "write_barrier", (,) MO_WriteBarrier ),
( "memcpy", memcpyLikeTweakArgs MO_Memcpy ),
( "memset", memcpyLikeTweakArgs MO_Memset ),
......
......@@ -806,6 +806,7 @@ pprCallishMachOp_for_C mop
MO_F32_Exp -> text "expf"
MO_F32_Sqrt -> text "sqrtf"
MO_F32_Fabs -> text "fabsf"
MO_ReadBarrier -> text "load_load_barrier"
MO_WriteBarrier -> text "write_barrier"
MO_Memcpy _ -> text "memcpy"
MO_Memset _ -> text "memset"
......
......@@ -630,6 +630,7 @@ emitBlackHoleCode node = do
when eager_blackholing $ do
emitStore (cmmOffsetW dflags node (fixedHdrSizeW dflags)) currentTSOExpr
-- See Note [Heap memory barriers] in SMP.h.
emitPrimCall [] MO_WriteBarrier []
emitStore node (CmmReg (CmmGlobal EagerBlackholeInfo))
......
......@@ -72,7 +72,7 @@ import qualified Data.Set as S
The goal of this pass is to prepare for code generation.
1. Saturate constructor and primop applications.
1. Saturate constructor applications.
2. Convert to A-normal form; that is, function arguments
are always variables.
......@@ -1064,8 +1064,21 @@ because that has different strictness. Hence the use of 'allLazy'.
-- Building the saturated syntax
-- ---------------------------------------------------------------------------
maybeSaturate deals with saturating primops and constructors
The type is the type of the entire application
Note [Eta expansion of hasNoBinding things in CorePrep]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
maybeSaturate deals with eta expanding to saturate things that can't deal with
unsaturated applications (identified by 'hasNoBinding', currently just
foreign calls and unboxed tuple/sum constructors).
Note that eta expansion in CorePrep is very fragile due to the "prediction" of
CAFfyness made by TidyPgm (see Note [CAFfyness inconsistencies due to eta
expansion in CorePrep] in TidyPgm for details. We previously saturated primop
applications here as well but due to this fragility (see #16846) we now deal
with this another way, as described in Note [Primop wrappers] in PrimOp.
It's quite likely that eta expansion of constructor applications will
eventually break in a similar way to how primops did. We really should
eliminate this case as well.
-}
maybeSaturate :: Id -> CpeApp -> Int -> UniqSM CpeRhs
......
......@@ -9,7 +9,7 @@ The code for *top-level* bindings is in TidyPgm.
{-# LANGUAGE CPP #-}
module CoreTidy (
tidyExpr, tidyVarOcc, tidyRule, tidyRules, tidyUnfolding
tidyExpr, tidyRule, tidyRules, tidyUnfolding
) where
#include "HsVersions.h"
......
......@@ -39,6 +39,7 @@ import FastString
import DataCon
import PatSyn
import HscTypes (CompleteMatch(..))
import BasicTypes (Boxity(..))
import DsMonad
import TcSimplify (tcCheckSatisfiability)
......@@ -1072,12 +1073,17 @@ translatePat fam_insts pat = case pat of
TuplePat tys ps boxity -> do
tidy_ps <- translatePatVec fam_insts (map unLoc ps)
let tuple_con = RealDataCon (tupleDataCon boxity (length ps))
return [vanillaConPattern tuple_con tys (concat tidy_ps)]
tys' = case boxity of
Boxed -> tys
-- See Note [Unboxed tuple RuntimeRep vars] in TyCon
Unboxed -> map getRuntimeRep tys ++ tys
return [vanillaConPattern tuple_con tys' (concat tidy_ps)]
SumPat ty p alt arity -> do
tidy_p <- translatePat fam_insts (unLoc p)
let sum_con = RealDataCon (sumDataCon alt arity)
return [vanillaConPattern sum_con ty tidy_p]
-- See Note [Unboxed tuple RuntimeRep vars] in TyCon
return [vanillaConPattern sum_con (map getRuntimeRep ty ++ ty) tidy_p]
-- --------------------------------------------------------------------------
-- Not supposed to happen
......@@ -2543,7 +2549,7 @@ warnPmIters dflags (DsMatchContext kind loc)
msg is = fsep [ text "Pattern match checker exceeded"
, parens (ppr is), text "iterations in", ctxt <> dot
, text "(Use -fmax-pmcheck-iterations=n"
, text "to set the maximun number of iterations to n)" ]
, text "to set the maximum number of iterations to n)" ]
flag_i = wopt Opt_WarnOverlappingPatterns dflags
flag_u = exhaustive dflags kind
......
......@@ -508,6 +508,7 @@ Library
TcTyClsDecls
TcTyDecls
TcTypeable
TcTypeableValidity
TcType
TcEvidence
TcEvTerm
......
......@@ -156,7 +156,11 @@ assembleOneBCO hsc_env pbco = do
return ubco'
assembleBCO :: DynFlags -> ProtoBCO Name -> IO UnlinkedBCO
assembleBCO dflags (ProtoBCO nm instrs bitmap bsize arity _origin _malloced) = do
assembleBCO dflags (ProtoBCO { protoBCOName = nm
, protoBCOInstrs = instrs
, protoBCOBitmap = bitmap
, protoBCOBitmapSize = bsize
, protoBCOArity = arity }) = do
-- pass 1: collect up the offsets of the local labels.
let asm = mapM_ (assembleI dflags) instrs
......
......@@ -26,6 +26,7 @@ import Platform
import Name
import MkId
import Id
import Var ( updateVarType )
import ForeignCall
import HscTypes
import CoreUtils
......@@ -61,7 +62,6 @@ import Data.Char
import UniqSupply
import Module
import Control.Arrow ( second )
import Control.Exception
import Data.Array
......@@ -90,7 +90,7 @@ byteCodeGen hsc_env this_mod binds tycs mb_modBreaks
(const ()) $ do
-- Split top-level binds into strings and others.
-- See Note [generating code for top-level string literal bindings].
let (strings, flatBinds) = partitionEithers $ do
let (strings, flatBinds) = partitionEithers $ do -- list monad
(bndr, rhs) <- flattenBinds binds
return $ case exprIsTickedString_maybe rhs of
Just str -> Left (bndr, str)
......@@ -181,29 +181,13 @@ coreExprToBCOs hsc_env this_mod expr
where dflags = hsc_dflags hsc_env
-- The regular freeVars function gives more information than is useful to
-- us here. simpleFreeVars does the impedance matching.
-- us here. We need only the free variables, not everything in an FVAnn.
-- Historical note: At one point FVAnn was more sophisticated than just
-- a set. Now it isn't. So this function is much simpler. Keeping it around
-- so that if someone changes FVAnn, they will get a nice type error right
-- here.
simpleFreeVars :: CoreExpr -> AnnExpr Id DVarSet
simpleFreeVars = go . freeVars
where
go :: AnnExpr Id FVAnn -> AnnExpr Id DVarSet
go (ann, e) = (freeVarsOfAnn ann, go' e)
go' :: AnnExpr' Id FVAnn -> AnnExpr' Id DVarSet
go' (AnnVar id) = AnnVar id
go' (AnnLit lit) = AnnLit lit
go' (AnnLam bndr body) = AnnLam bndr (go body)
go' (AnnApp fun arg) = AnnApp (go fun) (go arg)
go' (AnnCase scrut bndr ty alts) = AnnCase (go scrut) bndr ty (map go_alt alts)
go' (AnnLet bind body) = AnnLet (go_bind bind) (go body)
go' (AnnCast expr (ann, co)) = AnnCast (go expr) (freeVarsOfAnn ann, co)
go' (AnnTick tick body) = AnnTick tick (go body)
go' (AnnType ty) = AnnType ty
go' (AnnCoercion co) = AnnCoercion co
go_alt (con, args, expr) = (con, args, go expr)
go_bind (AnnNonRec bndr rhs) = AnnNonRec bndr (go rhs)
go_bind (AnnRec pairs) = AnnRec (map (second go) pairs)
simpleFreeVars = freeVars
-- -----------------------------------------------------------------------------
-- Compilation schema for the bytecode generator
......@@ -256,6 +240,7 @@ mkProtoBCO
-> name
-> BCInstrList
-> Either [AnnAlt Id DVarSet] (AnnExpr Id DVarSet)
-- ^ original expression; for debugging only
-> Int
-> Word16
-> [StgWord]
......@@ -368,6 +353,9 @@ schemeR fvs (nm, rhs)
-}
= schemeR_wrk fvs nm rhs (collect rhs)
-- If an expression is a lambda (after apply bcView), return the
-- list of arguments to the lambda (in R-to-L order) and the
-- underlying expression
collect :: AnnExpr Id DVarSet -> ([Var], AnnExpr' Id DVarSet)
collect (_, e) = go [] e
where
......@@ -382,8 +370,8 @@ collect (_, e) = go [] e
schemeR_wrk
:: [Id]
-> Id
-> AnnExpr Id DVarSet
-> ([Var], AnnExpr' Var DVarSet)
-> AnnExpr Id DVarSet -- expression e, for debugging only
-> ([Var], AnnExpr' Var DVarSet) -- result of collect on e
-> BcM (ProtoBCO Name)
schemeR_wrk fvs nm original_body (args, body)
= do
......@@ -508,8 +496,16 @@ schemeE d s p e@(AnnLit lit) = returnUnboxedAtom d s p e (typeArgRep (litera
schemeE d s p e@(AnnCoercion {}) = returnUnboxedAtom d s p e V
schemeE d s p e@(AnnVar v)
-- See Note [Levity-polymorphic join points], step 3.
| isLPJoinPoint v = schemeT d s p $
AnnApp (bogus_fvs, AnnVar (protectLPJoinPointId v))
(bogus_fvs, AnnVar voidPrimId)
-- schemeT will call splitApp, dropping the fvs.
| isUnliftedType (idType v) = returnUnboxedAtom d s p e (bcIdArgRep v)
| otherwise = schemeT d s p e
where
bogus_fvs = pprPanic "schemeE bogus_fvs" (ppr v)
schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body))
| (AnnVar v, args_r_to_l) <- splitApp rhs,
......@@ -534,19 +530,22 @@ schemeE d s p (AnnLet binds (_,body)) = do
fvss = map (fvsToEnv p' . fst) rhss
-- See Note [Levity-polymorphic join points], step 2.
(xs',rhss') = zipWithAndUnzip protectLPJoinPointBind xs rhss
-- Sizes of free vars
size_w = trunc16W . idSizeW dflags
sizes = map (\rhs_fvs -> sum (map size_w rhs_fvs)) fvss
-- the arity of each rhs
arities = map (genericLength . fst . collect) rhss
arities = map (genericLength . fst . collect) rhss'
-- This p', d' defn is safe because all the items being pushed
-- are ptrs, so all have size 1 word. d' and p' reflect the stack
-- after the closures have been allocated in the heap (but not
-- filled in), and pointers to them parked on the stack.
offsets = mkStackOffsets d (genericReplicate n_binds (wordSize dflags))
p' = Map.insertList (zipE xs offsets) p
p' = Map.insertList (zipE xs' offsets) p
d' = d + wordsToBytes dflags n_binds
zipE = zipEqual "schemeE"
......@@ -587,7 +586,7 @@ schemeE d s p (AnnLet binds (_,body)) = do
compile_binds =
[ compile_bind d' fvs x rhs size arity (trunc16W n)
| (fvs, x, rhs, size, arity, n) <-
zip6 fvss xs rhss sizes arities [n_binds, n_binds-1 .. 1]
zip6 fvss xs' rhss' sizes arities [n_binds, n_binds-1 .. 1]
]
body_code <- schemeE d' s p' body
thunk_codes <- sequence compile_binds
......@@ -681,6 +680,30 @@ schemeE _ _ _ expr
= pprPanic "ByteCodeGen.schemeE: unhandled case"
(pprCoreExpr (deAnnotate' expr))
-- Is this Id a levity-polymorphic join point?
-- See Note [Levity-polymorphic join points], step 1
isLPJoinPoint :: Id -> Bool
isLPJoinPoint x = isJoinId x &&
isNothing (isLiftedType_maybe (idType x))
-- If necessary, modify this Id and body to protect levity-polymorphic join points.
-- See Note [Levity-polymorphic join points], step 2.
protectLPJoinPointBind :: Id -> AnnExpr Id DVarSet -> (Id, AnnExpr Id DVarSet)
protectLPJoinPointBind x rhs@(fvs, _)
| isLPJoinPoint x
= (protectLPJoinPointId x, (fvs, AnnLam voidArgId rhs))
| otherwise
= (x, rhs)
-- Update an Id's type to take a Void# argument.
-- Precondition: the Id is a levity-polymorphic join point.
-- See Note [Levity-polymorphic join points]
protectLPJoinPointId :: Id -> Id
protectLPJoinPointId x
= ASSERT( isLPJoinPoint x )
updateVarType (voidPrimTy `mkFunTy`) x
{-
Ticked Expressions
------------------
......@@ -689,6 +712,41 @@ schemeE _ _ _ expr
the code. When we find such a thing, we pull out the useful information,
and then compile the code as if it was just the expression E.
Note [Levity-polymorphic join points]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
A join point variable is essentially a goto-label: it is, for example,
never used as an argument to another function, and it is called only
in tail position. See Note [Join points] and Note [Invariants on join points],
both in CoreSyn. Because join points do not compile to true, red-blooded
variables (with, e.g., registers allocated to them), they are allowed
to be levity-polymorphic. (See invariant #6 in Note [Invariants on join points]
in CoreSyn.)
However, in this byte-code generator, join points *are* treated just as
ordinary variables. There is no check whether a binding is for a join point
or not; they are all treated uniformly. (Perhaps there is a missed optimization
opportunity here, but that is beyond the scope of my (Richard E's) Thursday.)
We thus must have *some* strategy for dealing with levity-polymorphic join
points (LPJPs), because we cannot have a levity-polymorphic variable.
(Not having such a strategy led to #16509, which panicked in the isUnliftedType
check in the AnnVar case of schemeE.) Here is the strategy:
1. Detect LPJPs. This is done in isLPJoinPoint.
2. When binding an LPJP, add a `\ (_ :: Void#) ->` to its RHS, and modify the
type to tack on a `Void# ->`. (Void# is written voidPrimTy within GHC.)
Note that functions are never levity-polymorphic, so this transformation
changes an LPJP to a non-levity-polymorphic join point. This is done
in protectLPJoinPointBind, called from the AnnLet case of schemeE.
3. At an occurrence of an LPJP, add an application to void# (called voidPrimId),
being careful to note the new type of the LPJP. This is done in the AnnVar
case of schemeE, with help from protectLPJoinPointId.
It's a bit hacky, but it works well in practice and is local. I suspect the
Right Fix is to take advantage of join points as goto-labels.
-}
-- Compile code to do a tail call. Specifically, push the fn,
......
......@@ -45,7 +45,7 @@ data ProtoBCO a
protoBCOBitmap :: [StgWord],
protoBCOBitmapSize :: Word16,
protoBCOArity :: Int,
-- what the BCO came from
-- what the BCO came from, for debugging only
protoBCOExpr :: Either [AnnAlt Id DVarSet] (AnnExpr Id DVarSet),
-- malloc'd pointers
protoBCOFFIs :: [FFIInfo]
......@@ -179,7 +179,13 @@ data BCInstr
-- Printing bytecode instructions
instance Outputable a => Outputable (ProtoBCO a) where
ppr (ProtoBCO name instrs bitmap bsize arity origin ffis)
ppr (ProtoBCO { protoBCOName = name
, protoBCOInstrs = instrs
, protoBCOBitmap = bitmap
, protoBCOBitmapSize = bsize
, protoBCOArity = arity
, protoBCOExpr = origin
, protoBCOFFIs = ffis })
= (text "ProtoBCO" <+> ppr name <> char '#' <> int arity
<+> text (show ffis) <> colon)
$$ nest 3 (case origin of
......
......@@ -389,8 +389,10 @@ linkCmdLineLibs' hsc_env pls =
all_paths_env <- addEnvPaths "LD_LIBRARY_PATH" all_paths
pathCache <- mapM (addLibrarySearchPath hsc_env) all_paths_env
let merged_specs = mergeStaticObjects cmdline_lib_specs
pls1 <- foldM (preloadLib hsc_env lib_paths framework_paths) pls
cmdline_lib_specs
merged_specs
maybePutStr dflags "final link ... "
ok <- resolveObjs hsc_env
......@@ -402,6 +404,19 @@ linkCmdLineLibs' hsc_env pls =
return pls1
-- | Merge runs of consecutive of 'Objects'. This allows for resolution of