ghc-lib-parser 0.20190402 → 0.20190423

raw patch · 23 files changed

+627/−352 lines, 23 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• compiler/basicTypes/BasicTypes.hs +34/−2
• compiler/cmm/CmmType.hs +5/−8
• compiler/ghci/keepCAFsForGHCi.c +0/−15
• compiler/hsSyn/HsTypes.hs +11/−3
• compiler/hsSyn/HsUtils.hs +23/−16
• compiler/iface/IfaceSyn.hs +13/−8
• compiler/main/DriverPhases.hs +0/−1
• compiler/main/DynFlags.hs +39/−14
• compiler/main/HscTypes.hs +33/−10
• compiler/parser/RdrHsSyn.hs +131/−146
• compiler/simplCore/CoreMonad.hs +8/−8
• compiler/types/OptCoercion.hs +2/−2
• compiler/types/TyCon.hs +2/−2
• compiler/types/Type.hs +16/−1
• compiler/utils/Outputable.hs +4/−0
• compiler/utils/Util.hs +0/−1
• ghc-lib-parser.cabal +2/−3
• ghc-lib/generated/ghcversion.h +2/−1
• ghc-lib/stage0/compiler/build/Parser.hs +1/−1
• ghc-lib/stage1/compiler/build/Config.hs +5/−5
• ghc-lib/stage1/lib/settings +34/−35
• includes/CodeGen.Platform.hs +48/−54
• libraries/template-haskell/Language/Haskell/TH/Syntax.hs +214/−16

@@ -26,7 +26,7 @@          Arity, RepArity, JoinArity, -        Alignment,+        Alignment, mkAlignment, alignmentOf, alignmentBytes,          PromotionFlag(..), isPromoted,         FunctionOrData(..),@@ -116,6 +116,7 @@ import SrcLoc ( Located,unLoc ) import Data.Data hiding (Fixity, Prefix, Infix) import Data.Function (on)+import Data.Bits  {- ************************************************************************@@ -196,8 +197,39 @@ ************************************************************************ -} -type Alignment = Int -- align to next N-byte boundary (N must be a power of 2).+-- | A power-of-two alignment+newtype Alignment = Alignment { alignmentBytes :: Int } deriving (Eq, Ord) +-- Builds an alignment, throws on non power of 2 input. This is not+-- ideal, but convenient for internal use and better then silently+-- passing incorrect data.+mkAlignment :: Int -> Alignment+mkAlignment n+  | n == 1 = Alignment 1+  | n == 2 = Alignment 2+  | n == 4 = Alignment 4+  | n == 8 = Alignment 8+  | n == 16 = Alignment 16+  | n == 32 = Alignment 32+  | n == 64 = Alignment 64+  | n == 128 = Alignment 128+  | n == 256 = Alignment 256+  | n == 512 = Alignment 512+  | otherwise = panic "mkAlignment: received either a non power of 2 argument or > 512"++-- Calculates an alignment of a number. x is aligned at N bytes means+-- the remainder from x / N is zero. Currently, interested in N <= 8,+-- but can be expanded to N <= 16 or N <= 32 if used within SSE or AVX+-- context.+alignmentOf :: Int -> Alignment+alignmentOf x = case x .&. 7 of+  0 -> Alignment 8+  4 -> Alignment 4+  2 -> Alignment 2+  _ -> Alignment 1++instance Outputable Alignment where+  ppr (Alignment m) = ppr m {- ************************************************************************ *                                                                      *

@@ -166,9 +166,6 @@ -----------------------------------------------------------------------------  data Width   = W8 | W16 | W32 | W64-             | W80      -- Extended double-precision float,-                        -- used in x86 native codegen only.-                        -- (we use Ord, so it'd better be in this order)              | W128              | W256              | W512@@ -185,9 +182,9 @@ mrStr W128 = sLit("W128") mrStr W256 = sLit("W256") mrStr W512 = sLit("W512")-mrStr W80  = sLit("W80")  + -------- Common Widths  ------------ wordWidth :: DynFlags -> Width wordWidth dflags@@ -222,8 +219,8 @@ widthInBits W128 = 128 widthInBits W256 = 256 widthInBits W512 = 512-widthInBits W80  = 80 + widthInBytes :: Width -> Int widthInBytes W8   = 1 widthInBytes W16  = 2@@ -232,8 +229,8 @@ widthInBytes W128 = 16 widthInBytes W256 = 32 widthInBytes W512 = 64-widthInBytes W80  = 10 + widthFromBytes :: Int -> Width widthFromBytes 1  = W8 widthFromBytes 2  = W16@@ -242,7 +239,7 @@ widthFromBytes 16 = W128 widthFromBytes 32 = W256 widthFromBytes 64 = W512-widthFromBytes 10 = W80+ widthFromBytes n  = pprPanic "no width for given number of bytes" (ppr n)  -- log_2 of the width in bytes, useful for generating shifts.@@ -254,7 +251,7 @@ widthInLog W128 = 4 widthInLog W256 = 5 widthInLog W512 = 6-widthInLog W80  = panic "widthInLog: F80"+  -- widening / narrowing 

@@ -1,15 +0,0 @@-#include "Rts.h"--// This file is only included in the dynamic library.-// It contains an __attribute__((constructor)) function (run prior to main())-// which sets the keepCAFs flag in the RTS, before any Haskell code is run.-// This is required so that GHCi can use dynamic libraries instead of HSxyz.o-// files.--static void keepCAFsForGHCi(void) __attribute__((constructor));--static void keepCAFsForGHCi(void)-{-    keepCAFs = 1;-}-

@@ -105,14 +105,22 @@ type LBangType pass = Located (BangType pass)  -- | Bang Type+--+-- In the parser, strictness and packedness annotations bind more tightly+-- than docstrings. This means that when consuming a 'BangType' (and looking+-- for 'HsBangTy') we must be ready to peer behind a potential layer of+-- 'HsDocTy'. See #15206 for motivation and 'getBangType' for an example. type BangType pass  = HsType pass       -- Bangs are in the HsType data type  getBangType :: LHsType a -> LHsType a-getBangType (L _ (HsBangTy _ _ ty)) = ty-getBangType ty                      = ty+getBangType                 (L _ (HsBangTy _ _ lty))       = lty+getBangType (L _ (HsDocTy x (L _ (HsBangTy _ _ lty)) lds)) =+  addCLoc lty lds (HsDocTy x lty lds)+getBangType lty                                            = lty  getBangStrictness :: LHsType a -> HsSrcBang-getBangStrictness (L _ (HsBangTy _ s _)) = s+getBangStrictness                 (L _ (HsBangTy _ s _))     = s+getBangStrictness (L _ (HsDocTy _ (L _ (HsBangTy _ s _)) _)) = s getBangStrictness _ = (HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict)  {-

@@ -106,7 +106,7 @@ import RdrName import Var import TyCoRep-import Type   ( tyConArgFlags )+import Type   ( appTyArgFlags, splitAppTys, tyConArgFlags ) import TysWiredIn ( unitTy ) import TcType import DataCon@@ -665,7 +665,6 @@                           , hst_xforall = noExt                           , hst_body = go tau })     go (TyVarTy tv)         = nlHsTyVar (getRdrName tv)-    go (AppTy t1 t2)        = nlHsAppTy (go t1) (go t2)     go (LitTy (NumTyLit n))       = noLoc $ HsTyLit NoExt (HsNumTy NoSourceText n)     go (LitTy (StrTyLit s))@@ -674,26 +673,34 @@       | tyConAppNeedsKindSig True tc (length args)         -- We must produce an explicit kind signature here to make certain         -- programs kind-check. See Note [Kind signatures in typeToLHsType].-      = nlHsParTy $ noLoc $ HsKindSig NoExt lhs_ty (go (tcTypeKind ty))-      | otherwise = lhs_ty+      = nlHsParTy $ noLoc $ HsKindSig NoExt ty' (go (tcTypeKind ty))+      | otherwise = ty'        where-        arg_flags :: [ArgFlag]-        arg_flags = tyConArgFlags tc args--        lhs_ty :: LHsType GhcPs-        lhs_ty = foldl' (\f (arg, flag) ->-                          let arg' = go arg in-                          case flag of-                            Inferred  -> f-                            Specified -> f `nlHsAppKindTy` arg'-                            Required  -> f `nlHsAppTy`     arg')-                        (nlHsTyVar (getRdrName tc))-                        (zip args arg_flags)+        ty' :: LHsType GhcPs+        ty' = go_app (nlHsTyVar (getRdrName tc)) args (tyConArgFlags tc args)+    go ty@(AppTy {})        = go_app (go head) args (appTyArgFlags head args)+      where+        head :: Type+        args :: [Type]+        (head, args) = splitAppTys ty     go (CastTy ty _)        = go ty     go (CoercionTy co)      = pprPanic "toLHsSigWcType" (ppr co)           -- Source-language types have _invisible_ kind arguments,          -- so we must remove them here (#8563)++    go_app :: LHsType GhcPs -- The type being applied+           -> [Type]        -- The argument types+           -> [ArgFlag]     -- The argument types' visibilities+           -> LHsType GhcPs+    go_app head args arg_flags =+      foldl' (\f (arg, flag) ->+               let arg' = go arg in+               case flag of+                 Inferred  -> f+                 Specified -> f `nlHsAppKindTy` arg'+                 Required  -> f `nlHsAppTy`     arg')+             head (zip args arg_flags)      go_tv :: TyVar -> LHsTyVarBndr GhcPs     go_tv tv = noLoc $ KindedTyVar noExt (noLoc (getRdrName tv))

@@ -1034,7 +1034,7 @@     -- a compound field type is if it's preceded by a bang pattern.     pprFieldArgTy (bang, ty) = ppr_arg_ty (bang_prec bang) bang ty     -- If not using record syntax, a compound field type might need to be-    -- parenthesize if one of the following holds:+    -- parenthesized if one of the following holds:     --     -- 1. We're using Haskell98 syntax.     -- 2. The field type is preceded with a bang pattern.@@ -1046,18 +1046,23 @@     -- If we're displaying the fields GADT-style, e.g.,     --     --   data Foo a where-    --     MkFoo :: Maybe a -> Foo+    --     MkFoo :: (Int -> Int) -> Maybe a -> Foo     ---    -- Then there is no inherent need to parenthesize compound fields like-    -- `Maybe a` (bang patterns notwithstanding). If we're displaying the-    -- fields Haskell98-style, e.g.,+    -- Then we use `funPrec`, since that will ensure `Int -> Int` gets the+    -- parentheses that it requires, but simple compound types like `Maybe a`+    -- (which don't require parentheses in a function argument position) won't+    -- get them, assuming that there are no bang patterns (see bang_prec).     ---    --   data Foo a = MkFoo (Maybe a)+    -- If we're displaying the fields Haskell98-style, e.g.,     ---    -- Then we *must* parenthesize compound fields like (Maybe a).+    --   data Foo a = MkFoo (Int -> Int) (Maybe a)+    --+    -- Then not only must we parenthesize `Int -> Int`, we must also+    -- parenthesize compound fields like (Maybe a). Therefore, we pick+    -- `appPrec`, which has higher precedence than `funPrec`.     gadt_prec :: PprPrec     gadt_prec-      | gadt_style = topPrec+      | gadt_style = funPrec       | otherwise  = appPrec      -- The presence of bang patterns or UNPACK annotations requires

@@ -369,4 +369,3 @@ isObjectFilename, isDynLibFilename :: Platform -> FilePath -> Bool isObjectFilename platform f = isObjectSuffix platform (drop 1 $ takeExtension f) isDynLibFilename platform f = isDynLibSuffix platform (drop 1 $ takeExtension f)-

@@ -41,6 +41,7 @@         whenGeneratingDynamicToo, ifGeneratingDynamicToo,         whenCannotGenerateDynamicToo,         dynamicTooMkDynamicDynFlags,+        dynamicOutputFile,         DynFlags(..),         FlagSpec(..),         HasDynFlags(..), ContainsDynFlags(..),@@ -58,7 +59,7 @@         fFlags, fLangFlags, xFlags,         wWarningFlags,         dynFlagDependencies,-        tablesNextToCode, mkTablesNextToCode,+        tablesNextToCode,         makeDynFlagsConsistent,         shouldUseColor,         shouldUseHexWordLiterals,@@ -92,7 +93,8 @@         extraGccViaCFlags, systemPackageConfig,         pgm_L, pgm_P, pgm_F, pgm_c, pgm_a, pgm_l, pgm_dll, pgm_T,         pgm_windres, pgm_libtool, pgm_ar, pgm_ranlib, pgm_lo, pgm_lc,-        pgm_lcc, pgm_i, opt_L, opt_P, opt_F, opt_c, opt_a, opt_l, opt_i,+        pgm_lcc, pgm_i,+        opt_L, opt_P, opt_F, opt_c, opt_cxx, opt_a, opt_l, opt_i,         opt_P_signature,         opt_windres, opt_lo, opt_lc, opt_lcc, @@ -146,6 +148,7 @@ #include "GHCConstantsHaskellExports.hs"         bLOCK_SIZE_W,         wORD_SIZE_IN_BITS,+        wordAlignment,         tAG_MASK,         mAX_PTR_TAG,         tARGET_MIN_INT, tARGET_MAX_INT, tARGET_MAX_WORD,@@ -204,7 +207,7 @@ import MonadUtils import qualified Pretty import SrcLoc-import BasicTypes       ( IntWithInf, treatZeroAsInf )+import BasicTypes       ( Alignment, alignmentOf, IntWithInf, treatZeroAsInf ) import FastString import Fingerprint import Outputable@@ -382,6 +385,7 @@    | Opt_D_dump_spec    | Opt_D_dump_prep    | Opt_D_dump_stg+   | Opt_D_dump_stg_final    | Opt_D_dump_call_arity    | Opt_D_dump_exitify    | Opt_D_dump_stranal@@ -1340,6 +1344,7 @@                                          -- See Note [Repeated -optP hashing]   sOpt_F                 :: [String],   sOpt_c                 :: [String],+  sOpt_cxx               :: [String],   sOpt_a                 :: [String],   sOpt_l                 :: [String],   sOpt_windres           :: [String],@@ -1423,6 +1428,8 @@ opt_c                 :: DynFlags -> [String] opt_c dflags = concatMap (wayOptc (targetPlatform dflags)) (ways dflags)             ++ sOpt_c (settings dflags)+opt_cxx               :: DynFlags -> [String]+opt_cxx dflags = sOpt_cxx (settings dflags) opt_a                 :: DynFlags -> [String] opt_a dflags = sOpt_a (settings dflags) opt_l                 :: DynFlags -> [String]@@ -1817,6 +1824,12 @@           dflags4 = gopt_unset dflags3 Opt_BuildDynamicToo       in dflags4 +-- | Compute the path of the dynamic object corresponding to an object file.+dynamicOutputFile :: DynFlags -> FilePath -> FilePath+dynamicOutputFile dflags outputFile = dynOut outputFile+  where+    dynOut = flip addExtension (dynObjectSuf dflags) . dropExtension+ -----------------------------------------------------------------------------  -- | Used by 'GHC.runGhc' to partially initialize a new 'DynFlags' value@@ -2520,7 +2533,7 @@          setDynObjectSuf, setDynHiSuf,          setDylibInstallName,          setObjectSuf, setHiSuf, setHieSuf, setHcSuf, parseDynLibLoaderMode,-         setPgmP, addOptl, addOptc, addOptP,+         setPgmP, addOptl, addOptc, addOptcxx, addOptP,          addCmdlineFramework, addHaddockOpts, addGhciScript,          setInteractivePrint    :: String -> DynFlags -> DynFlags@@ -2636,6 +2649,7 @@ setPgmP   f = let (pgm:args) = words f in alterSettings (\s -> s { sPgm_P   = (pgm, map Option args)}) addOptl   f = alterSettings (\s -> s { sOpt_l   = f : sOpt_l s}) addOptc   f = alterSettings (\s -> s { sOpt_c   = f : sOpt_c s})+addOptcxx f = alterSettings (\s -> s { sOpt_cxx = f : sOpt_cxx s}) addOptP   f = alterSettings (\s -> s { sOpt_P   = f : sOpt_P s                                      , sOpt_P_fingerprint = fingerprintStrings (f : sOpt_P s)                                      })@@ -2765,11 +2779,11 @@   let chooseOutput         | isJust (outputFile dflags3)          -- Only iff user specified -o ...         , not (isJust (dynOutputFile dflags3)) -- but not -dyno-        = return $ dflags3 { dynOutputFile = Just $ dynOut (fromJust $ outputFile dflags3) }+        = return $ dflags3 { dynOutputFile = Just $ dynamicOutputFile dflags3 outFile }         | otherwise         = return dflags3         where-          dynOut = flip addExtension (dynObjectSuf dflags3) . dropExtension+          outFile = fromJust $ outputFile dflags3   dflags4 <- ifGeneratingDynamicToo dflags3 chooseOutput (return dflags3)    let (dflags5, consistency_warnings) = makeDynFlagsConsistent dflags4@@ -3038,6 +3052,8 @@       (hasArg (\f -> alterSettings (\s -> s { sOpt_F   = f : sOpt_F s})))   , make_ord_flag defFlag "optc"       (hasArg addOptc)+  , make_ord_flag defFlag "optcxx"+      (hasArg addOptcxx)   , make_ord_flag defFlag "opta"       (hasArg (\f -> alterSettings (\s -> s { sOpt_a   = f : sOpt_a s})))   , make_ord_flag defFlag "optl"@@ -3331,6 +3347,8 @@         (setDumpFlag Opt_D_dump_prep)   , make_ord_flag defGhcFlag "ddump-stg"         (setDumpFlag Opt_D_dump_stg)+  , make_ord_flag defGhcFlag "ddump-stg-final"+        (setDumpFlag Opt_D_dump_stg_final)   , make_ord_flag defGhcFlag "ddump-call-arity"         (setDumpFlag Opt_D_dump_call_arity)   , make_ord_flag defGhcFlag "ddump-exitify"@@ -5654,6 +5672,9 @@ wORD_SIZE_IN_BITS :: DynFlags -> Int wORD_SIZE_IN_BITS dflags = wORD_SIZE dflags * 8 +wordAlignment :: DynFlags -> Alignment+wordAlignment dflags = alignmentOf (wORD_SIZE dflags)+ tAG_MASK :: DynFlags -> Int tAG_MASK dflags = (1 `shiftL` tAG_BITS dflags) - 1 @@ -5822,19 +5843,23 @@ isSseEnabled :: DynFlags -> Bool isSseEnabled dflags = case platformArch (targetPlatform dflags) of     ArchX86_64 -> True-    ArchX86    -> sseVersion dflags >= Just SSE1+    ArchX86    -> True     _          -> False  isSse2Enabled :: DynFlags -> Bool isSse2Enabled dflags = case platformArch (targetPlatform dflags) of-    ArchX86_64 -> -- SSE2 is fixed on for x86_64.  It would be-                  -- possible to make it optional, but we'd need to-                  -- fix at least the foreign call code where the-                  -- calling convention specifies the use of xmm regs,-                  -- and possibly other places.-                  True-    ArchX86    -> sseVersion dflags >= Just SSE2+  -- We Assume  SSE1 and SSE2 operations are available on both+  -- x86 and x86_64. Historically we didn't default to SSE2 and+  -- SSE1 on x86, which results in defacto nondeterminism for how+  -- rounding behaves in the associated x87 floating point instructions+  -- because variations in the spill/fpu stack placement of arguments for+  -- operations would change the precision and final result of what+  -- would otherwise be the same expressions with respect to single or+  -- double precision IEEE floating point computations.+    ArchX86_64 -> True+    ArchX86    -> True     _          -> False+  isSse4_2Enabled :: DynFlags -> Bool isSse4_2Enabled dflags = sseVersion dflags >= Just SSE42

@@ -30,6 +30,7 @@         ModGuts(..), CgGuts(..), ForeignStubs(..), appendStubC,         ImportedMods, ImportedBy(..), importedByUser, ImportedModsVal(..), SptEntry(..),         ForeignSrcLang(..),+        phaseForeignLanguage,          ModSummary(..), ms_imps, ms_installed_mod, ms_mod_name, showModMsg, isBootSummary,         msHsFilePath, msHiFilePath, msObjFilePath,@@ -182,6 +183,7 @@ import DynFlags import DriverPhases     ( Phase, HscSource(..), hscSourceString                         , isHsBootOrSig, isHsigFile )+import qualified DriverPhases as Phase import BasicTypes import IfaceSyn import Maybes@@ -2803,6 +2805,9 @@ msHiFilePath  ms = ml_hi_file  (ms_location ms) msObjFilePath ms = ml_obj_file (ms_location ms) +msDynObjFilePath :: ModSummary -> DynFlags -> FilePath+msDynObjFilePath ms dflags = dynamicOutputFile dflags (msObjFilePath ms)+ -- | Did this 'ModSummary' originate from a hs-boot file? isBootSummary :: ModSummary -> Bool isBootSummary ms = ms_hsc_src ms == HsBootFile@@ -2822,20 +2827,26 @@ showModMsg dflags target recomp mod_summary = showSDoc dflags $    if gopt Opt_HideSourcePaths dflags       then text mod_str-      else hsep+      else hsep $          [ text (mod_str ++ replicate (max 0 (16 - length mod_str)) ' ')          , char '('          , text (op $ msHsFilePath mod_summary) <> char ','-         , case target of-              HscInterpreted | recomp -> text "interpreted"-              HscNothing              -> text "nothing"-              _                       -> text (op $ msObjFilePath mod_summary)-         , char ')'-         ]+         ] +++         if gopt Opt_BuildDynamicToo dflags+            then [ text obj_file <> char ','+                 , text dyn_file+                 , char ')'+                 ]+            else [ text obj_file, char ')' ]   where-    op      = normalise-    mod     = moduleName (ms_mod mod_summary)-    mod_str = showPpr dflags mod ++ hscSourceString (ms_hsc_src mod_summary)+    op       = normalise+    mod      = moduleName (ms_mod mod_summary)+    mod_str  = showPpr dflags mod ++ hscSourceString (ms_hsc_src mod_summary)+    dyn_file = op $ msDynObjFilePath mod_summary dflags+    obj_file = case target of+                HscInterpreted | recomp -> "interpreted"+                HscNothing              -> "nothing"+                _                       -> (op $ msObjFilePath mod_summary)  {- ************************************************************************@@ -3136,3 +3147,15 @@ explanation for how GHC ensures that all the conlikes in a COMPLETE set are consistent. -}++-- | Foreign language of the phase if the phase deals with a foreign code+phaseForeignLanguage :: Phase -> Maybe ForeignSrcLang+phaseForeignLanguage phase = case phase of+  Phase.Cc           -> Just LangC+  Phase.Ccxx         -> Just LangCxx+  Phase.Cobjc        -> Just LangObjc+  Phase.Cobjcxx      -> Just LangObjcxx+  Phase.HCc          -> Just LangC+  Phase.As _         -> Just LangAsm+  Phase.MergeForeign -> Just RawObject+  _                  -> Nothing

@@ -50,7 +50,6 @@          -- Bunch of functions in the parser monad for         -- checking and constructing values-        checkBlockArguments,         checkPrecP,           -- Int -> P Int         checkContext,         -- HsType -> P HsContext         checkPattern,         -- HsExp -> P HsPat@@ -61,7 +60,6 @@         checkMonadComp,       -- P (HsStmtContext RdrName)         checkValDef,          -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl         checkValSigLhs,-        checkDoAndIfThenElse,         LRuleTyTmVar, RuleTyTmVar(..),         mkRuleBndrs, mkRuleTyVarBndrs,         checkRuleTyVarBndrNames,@@ -94,14 +92,6 @@         ExpCmdI(..),         ecFromExp,         ecFromCmd,-        ecHsLam,-        ecHsLet,-        ecOpApp,-        ecHsCase,-        ecHsApp,-        ecHsIf,-        ecHsDo,-        ecHsPar,      ) where @@ -672,10 +662,8 @@                , con_forall = noLoc $ isJust mb_forall                , con_ex_tvs = mb_forall `orElse` []                , con_mb_cxt = mb_cxt-               , con_args   = args'+               , con_args   = args                , con_doc    = Nothing }-  where-    args' = nudgeHsSrcBangs args  mkGadtDecl :: [Located RdrName]            -> LHsType GhcPs     -- Always a HsForAllTy@@ -686,7 +674,7 @@                  , con_forall = cL l $ isLHsForAllTy ty'                  , con_qvars  = mkHsQTvs tvs                  , con_mb_cxt = mcxt-                 , con_args   = args'+                 , con_args   = args                  , con_res_ty = res_ty                  , con_doc    = Nothing }     , anns1 ++ anns2)@@ -703,7 +691,6 @@       = (Nothing, tau, ann)      (args, res_ty) = split_tau tau-    args' = nudgeHsSrcBangs args      -- See Note [GADT abstract syntax] in HsDecls     split_tau (dL->L _ (HsFunTy _ (dL->L loc (HsRecTy _ rf)) res_ty))@@ -715,28 +702,7 @@                                                        (ann++mkParensApiAnn l)     peel_parens ty                   ann = (ty, ann) -nudgeHsSrcBangs :: HsConDeclDetails GhcPs -> HsConDeclDetails GhcPs--- ^ This function ensures that fields with strictness or packedness--- annotations put these annotations on an outer 'HsBangTy'.------ The problem is that in the parser, strictness and packedness annotations--- bind more tightly that docstrings. However, the expectation downstream of--- the parser (by functions such as 'getBangType' and 'getBangStrictness')--- is that docstrings bind more tightly so that 'HsBangTy' may end up as the--- top-level type.------ See #15206-nudgeHsSrcBangs details-  = case details of-      PrefixCon as -> PrefixCon (map go as)-      RecCon r -> RecCon r-      InfixCon a1 a2 -> InfixCon (go a1) (go a2)-  where-    go (dL->L l (HsDocTy _ (dL->L _ (HsBangTy _ s lty)) lds)) =-      cL l (HsBangTy noExt s (addCLoc lty lds (HsDocTy noExt lty lds)))-    go lty = lty - setRdrNameSpace :: RdrName -> NameSpace -> RdrName -- ^ This rather gruesome function is used mainly by the parser. -- When parsing:@@ -1004,8 +970,9 @@  -- | Yield a parse error if we have a function applied directly to a do block -- etc. and BlockArguments is not enabled.-checkBlockArguments :: forall b. ExpCmdI b => Located (b GhcPs) -> PV ()-checkBlockArguments = case expCmdG @b of { ExpG -> checkExpr; CmdG -> checkCmd }+checkExpBlockArguments :: LHsExpr GhcPs -> P ()+checkCmdBlockArguments :: LHsCmd GhcPs -> P ()+(checkExpBlockArguments, checkCmdBlockArguments) = (checkExpr, checkCmd)   where     checkExpr :: LHsExpr GhcPs -> P ()     checkExpr expr = case unLoc expr of@@ -1315,19 +1282,6 @@     default_RDR = mkUnqual varName (fsLit "default")     pattern_RDR = mkUnqual varName (fsLit "pattern") -checkDoAndIfThenElse-  :: forall b. ExpCmdI b =>-     LHsExpr GhcPs-  -> Bool-  -> Located (b GhcPs)-  -> Bool-  -> Located (b GhcPs)-  -> P ()-checkDoAndIfThenElse =-  case expCmdG @b of-    ExpG -> checkDoAndIfThenElse'-    CmdG -> checkDoAndIfThenElse'- checkDoAndIfThenElse'   :: (HasSrcSpan a, Outputable a, Outputable b, HasSrcSpan c, Outputable c)   => a -> Bool -> b -> Bool -> c -> P ()@@ -1924,73 +1878,78 @@ newtype ExpCmdP =   ExpCmdP { runExpCmdP :: forall b. ExpCmdI b => PV (Located (b GhcPs)) } --- See Note [Ambiguous syntactic categories]-data ExpCmdG b where-  ExpG :: ExpCmdG HsExpr-  CmdG :: ExpCmdG HsCmd---- See Note [Ambiguous syntactic categories]-class    ExpCmdI b      where expCmdG :: ExpCmdG b-instance ExpCmdI HsExpr where expCmdG = ExpG-instance ExpCmdI HsCmd  where expCmdG = CmdG--ecFromCmd :: LHsCmd GhcPs -> ExpCmdP-ecFromCmd c@(getLoc -> l) = ExpCmdP onB-  where-    onB :: forall b. ExpCmdI b => PV (Located (b GhcPs))-    onB = case expCmdG @b of { ExpG -> onExp; CmdG -> return c }-    onExp :: P (LHsExpr GhcPs)-    onExp = do-      addError l $ vcat-        [ text "Arrow command found where an expression was expected:",-          nest 2 (ppr c) ]-      return (cL l hsHoleExpr)- ecFromExp :: LHsExpr GhcPs -> ExpCmdP-ecFromExp e@(getLoc -> l) = ExpCmdP onB-  where-    onB :: forall b. ExpCmdI b => PV (Located (b GhcPs))-    onB = case expCmdG @b of { ExpG -> return e; CmdG -> onCmd }-    onCmd :: P (LHsCmd GhcPs)-    onCmd =-      addFatalError l $-        text "Parse error in command:" <+> ppr e--hsHoleExpr :: HsExpr (GhcPass id)-hsHoleExpr = HsUnboundVar noExt (TrueExprHole (mkVarOcc "_"))+ecFromExp a = ExpCmdP (ecFromExp' a) -ecHsLam :: forall b. ExpCmdI b => MatchGroup GhcPs (Located (b GhcPs)) -> b GhcPs-ecHsLam = case expCmdG @b of { ExpG -> HsLam noExt; CmdG -> HsCmdLam noExt }+ecFromCmd :: LHsCmd GhcPs -> ExpCmdP+ecFromCmd a = ExpCmdP (ecFromCmd' a) -ecHsLet :: forall b. ExpCmdI b => LHsLocalBinds GhcPs -> Located (b GhcPs) -> b GhcPs-ecHsLet = case expCmdG @b of { ExpG -> HsLet noExt; CmdG -> HsCmdLet noExt }+-- See Note [Ambiguous syntactic categories]+class ExpCmdI b where+  -- | Return a command without ambiguity, or fail in a non-command context.+  ecFromCmd' :: LHsCmd GhcPs -> PV (Located (b GhcPs))+  -- | Return an expression without ambiguity, or fail in a non-expression context.+  ecFromExp' :: LHsExpr GhcPs -> PV (Located (b GhcPs))+  -- | Disambiguate "\... -> ..." (lambda)+  ecHsLam :: MatchGroup GhcPs (Located (b GhcPs)) -> b GhcPs+  -- | Disambiguate "let ... in ..."+  ecHsLet :: LHsLocalBinds GhcPs -> Located (b GhcPs) -> b GhcPs+  -- | Disambiguate "f # x" (infix operator)+  ecOpApp :: Located (b GhcPs) -> LHsExpr GhcPs -> Located (b GhcPs) -> b GhcPs+  -- | Disambiguate "case ... of ..."+  ecHsCase :: LHsExpr GhcPs -> MatchGroup GhcPs (Located (b GhcPs)) -> b GhcPs+  -- | Disambiguate "f x" (function application)+  ecHsApp :: Located (b GhcPs) -> LHsExpr GhcPs -> b GhcPs+  -- | Disambiguate "if ... then ... else ..."+  ecHsIf :: LHsExpr GhcPs -> Located (b GhcPs) -> Located (b GhcPs) -> b GhcPs+  -- | Disambiguate "do { ... }" (do notation)+  ecHsDo :: Located [LStmt GhcPs (Located (b GhcPs))] -> b GhcPs+  -- | Disambiguate "( ... )" (parentheses)+  ecHsPar :: Located (b GhcPs) -> b GhcPs+  -- | Check if the argument requires -XBlockArguments.+  checkBlockArguments :: Located (b GhcPs) -> PV ()+  -- | Check if -XDoAndIfThenElse is enabled.+  checkDoAndIfThenElse :: LHsExpr GhcPs -> Bool -> Located (b GhcPs)+                                        -> Bool -> Located (b GhcPs) -> P () -ecOpApp :: forall b. ExpCmdI b => Located (b GhcPs) -> LHsExpr GhcPs-        -> Located (b GhcPs) -> b GhcPs-ecOpApp = case expCmdG @b of { ExpG -> OpApp noExt; CmdG -> cmdOpApp }-  where-    cmdOpApp c1 op c2 =+instance ExpCmdI HsCmd where+  ecFromCmd' = return+  ecFromExp' (dL-> L l e) =+    addFatalError l $+      text "Parse error in command:" <+> ppr e+  ecHsLam = HsCmdLam noExt+  ecHsLet = HsCmdLet noExt+  ecOpApp c1 op c2 =       let cmdArg c = cL (getLoc c) $ HsCmdTop noExt c in       HsCmdArrForm noExt op Infix Nothing [cmdArg c1, cmdArg c2]--ecHsCase :: forall b. ExpCmdI b =>-  LHsExpr GhcPs -> MatchGroup GhcPs (Located (b GhcPs)) -> b GhcPs-ecHsCase = case expCmdG @b of { ExpG -> HsCase noExt; CmdG -> HsCmdCase noExt }--ecHsApp :: forall b. ExpCmdI b =>-  Located (b GhcPs) -> LHsExpr GhcPs -> b GhcPs-ecHsApp = case expCmdG @b of { ExpG -> HsApp noExt; CmdG -> HsCmdApp noExt }--ecHsIf :: forall b. ExpCmdI b =>-   LHsExpr GhcPs -> Located (b GhcPs) -> Located (b GhcPs) -> b GhcPs-ecHsIf = case expCmdG @b of { ExpG -> mkHsIf; CmdG -> mkHsCmdIf }+  ecHsCase = HsCmdCase noExt+  ecHsApp = HsCmdApp noExt+  ecHsIf = mkHsCmdIf+  ecHsDo = HsCmdDo noExt+  ecHsPar = HsCmdPar noExt+  checkBlockArguments = checkCmdBlockArguments+  checkDoAndIfThenElse = checkDoAndIfThenElse' -ecHsDo :: forall b. ExpCmdI b =>-  Located [LStmt GhcPs (Located (b GhcPs))] -> b GhcPs-ecHsDo = case expCmdG @b of { ExpG -> HsDo noExt DoExpr; CmdG -> HsCmdDo noExt }+instance ExpCmdI HsExpr where+  ecFromCmd' (dL -> L l c) = do+    addError l $ vcat+      [ text "Arrow command found where an expression was expected:",+        nest 2 (ppr c) ]+    return (cL l hsHoleExpr)+  ecFromExp' = return+  ecHsLam = HsLam noExt+  ecHsLet = HsLet noExt+  ecOpApp = OpApp noExt+  ecHsCase = HsCase noExt+  ecHsApp = HsApp noExt+  ecHsIf = mkHsIf+  ecHsDo = HsDo noExt DoExpr+  ecHsPar = HsPar noExt+  checkBlockArguments = checkExpBlockArguments+  checkDoAndIfThenElse = checkDoAndIfThenElse' -ecHsPar :: forall b. ExpCmdI b => Located (b GhcPs) -> b GhcPs-ecHsPar = case expCmdG @b of { ExpG -> HsPar noExt; CmdG -> HsCmdPar noExt }+hsHoleExpr :: HsExpr (GhcPass id)+hsHoleExpr = HsUnboundVar noExt (TrueExprHole (mkVarOcc "_"))  {- Note [Ambiguous syntactic categories] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -2043,19 +2002,12 @@  The solution that keeps basic definitions (such as HsExpr) clean, keeps the concerns local to the parser, and does not require duplication of hsSyn types,-or an extra pass over the entire AST, is to parse into a function from a GADT-to a parser-validator:--    data ExpCmdG b where-      ExpG :: ExpCmdG HsExpr-      CmdG :: ExpCmdG HsCmd--    type ExpCmd = forall b. ExpCmdG b -> PV (Located (b GhcPs))+or an extra pass over the entire AST, is to parse into an overloaded+parser-validator (a so-called tagless final encoding): -    checkExp :: ExpCmd -> PV (LHsExpr GhcPs)-    checkCmd :: ExpCmd -> PV (LHsCmd GhcPs)-    checkExp f = f ExpG  -- interpret as an expression-    checkCmd f = f CmdG  -- interpret as a command+    class ExpCmdI b where ...+    instance ExpCmdI HsCmd where ...+    instance ExpCmdI HsExp where ...  Consider the 'alts' production used to parse case-of alternatives: @@ -2065,30 +2017,6 @@  We abstract over LHsExpr, and it becomes: -  alts :: { forall b. ExpCmdG b -> PV (Located ([AddAnn],[LMatch GhcPs (Located (b GhcPs))])) }-    : alts1-        { \tag -> $1 tag >>= \ $1 ->-                  return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }-    | ';' alts-        { \tag -> $2 tag >>= \ $2 ->-                  return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }--Note that 'ExpCmdG' is a singleton type, the value is completely-determined by the type:--  when (b~HsExpr),  tag = ExpG-  when (b~HsCmd),   tag = CmdG--This is a clear indication that we can use a class to pass this value behind-the scenes:--  class    ExpCmdI b      where expCmdG :: ExpCmdG b-  instance ExpCmdI HsExpr where expCmdG = ExpG-  instance ExpCmdI HsCmd  where expCmdG = CmdG--And now the 'alts' production is simplified, as we no longer need to-thread 'tag' explicitly:-   alts :: { forall b. ExpCmdI b => PV (Located ([AddAnn],[LMatch GhcPs (Located (b GhcPs))])) }     : alts1     { $1 >>= \ $1 ->                   return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }@@ -2330,6 +2258,63 @@  And the same goes for other productions: 'altslist', 'alts1', 'alt', 'alt_rhs', 'ralt', 'gdpats', 'gdpat', 'exp', ... and so on. That is a lot of code!++Alternative VIII, a function from a GADT+----------------------------------------+We could avoid code duplication of the Alternative VII by representing the product+as a function from a GADT:++    data ExpCmdG b where+      ExpG :: ExpCmdG HsExpr+      CmdG :: ExpCmdG HsCmd++    type ExpCmd = forall b. ExpCmdG b -> PV (Located (b GhcPs))++    checkExp :: ExpCmd -> PV (LHsExpr GhcPs)+    checkCmd :: ExpCmd -> PV (LHsCmd GhcPs)+    checkExp f = f ExpG  -- interpret as an expression+    checkCmd f = f CmdG  -- interpret as a command++Consider the 'alts' production used to parse case-of alternatives:++  alts :: { Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)]) }+    : alts1     { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }+    | ';' alts  { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }++We abstract over LHsExpr, and it becomes:++  alts :: { forall b. ExpCmdG b -> PV (Located ([AddAnn],[LMatch GhcPs (Located (b GhcPs))])) }+    : alts1+        { \tag -> $1 tag >>= \ $1 ->+                  return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }+    | ';' alts+        { \tag -> $2 tag >>= \ $2 ->+                  return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }++Note that 'ExpCmdG' is a singleton type, the value is completely+determined by the type:++  when (b~HsExpr),  tag = ExpG+  when (b~HsCmd),   tag = CmdG++This is a clear indication that we can use a class to pass this value behind+the scenes:++  class    ExpCmdI b      where expCmdG :: ExpCmdG b+  instance ExpCmdI HsExpr where expCmdG = ExpG+  instance ExpCmdI HsCmd  where expCmdG = CmdG++And now the 'alts' production is simplified, as we no longer need to+thread 'tag' explicitly:++  alts :: { forall b. ExpCmdI b => PV (Located ([AddAnn],[LMatch GhcPs (Located (b GhcPs))])) }+    : alts1     { $1 >>= \ $1 ->+                  return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }+    | ';' alts  { $2 >>= \ $2 ->+                  return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }++This encoding works well enough for two cases (Exp vs Cmd), but it does not scale well to+more cases (Exp vs Cmd vs Pat), as we would need multiple GADTs for all possible ambiguities.  -} 

@@ -778,8 +778,8 @@ ************************************************************************ -} -msg :: Severity -> SDoc -> CoreM ()-msg sev doc+msg :: Severity -> WarnReason -> SDoc -> CoreM ()+msg sev reason doc   = do { dflags <- getDynFlags        ; loc    <- getSrcSpanM        ; unqual <- getPrintUnqualified@@ -791,7 +791,7 @@              err_sty  = mkErrStyle dflags unqual              user_sty = mkUserStyle dflags unqual AllTheWay              dump_sty = mkDumpStyle dflags unqual-       ; liftIO $ putLogMsg dflags NoReason sev loc sty doc }+       ; liftIO $ putLogMsg dflags reason sev loc sty doc }  -- | Output a String message to the screen putMsgS :: String -> CoreM ()@@ -799,7 +799,7 @@  -- | Output a message to the screen putMsg :: SDoc -> CoreM ()-putMsg = msg SevInfo+putMsg = msg SevInfo NoReason  -- | Output an error to the screen. Does not cause the compiler to die. errorMsgS :: String -> CoreM ()@@ -807,9 +807,9 @@  -- | Output an error to the screen. Does not cause the compiler to die. errorMsg :: SDoc -> CoreM ()-errorMsg = msg SevError+errorMsg = msg SevError NoReason -warnMsg :: SDoc -> CoreM ()+warnMsg :: WarnReason -> SDoc -> CoreM () warnMsg = msg SevWarning  -- | Output a fatal error to the screen. Does not cause the compiler to die.@@ -818,7 +818,7 @@  -- | Output a fatal error to the screen. Does not cause the compiler to die. fatalErrorMsg :: SDoc -> CoreM ()-fatalErrorMsg = msg SevFatal+fatalErrorMsg = msg SevFatal NoReason  -- | Output a string debugging message at verbosity level of @-v@ or higher debugTraceMsgS :: String -> CoreM ()@@ -826,7 +826,7 @@  -- | Outputs a debugging message at verbosity level of @-v@ or higher debugTraceMsg :: SDoc -> CoreM ()-debugTraceMsg = msg SevDump+debugTraceMsg = msg SevDump NoReason  -- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher dumpIfSet_dyn :: DumpFlag -> String -> SDoc -> CoreM ()

@@ -118,8 +118,8 @@         (Pair in_ty1  in_ty2,  in_role)  = coercionKindRole co         (Pair out_ty1 out_ty2, out_role) = coercionKindRole out_co     in-    ASSERT2( substTy env in_ty1 `eqType` out_ty1 &&-             substTy env in_ty2 `eqType` out_ty2 &&+    ASSERT2( substTyUnchecked env in_ty1 `eqType` out_ty1 &&+             substTyUnchecked env in_ty2 `eqType` out_ty2 &&              in_role == out_role            , text "optCoercion changed types!"              $$ hang (text "in_co:") 2 (ppr co)

@@ -1328,12 +1328,12 @@    number of bits.  It may represent a signed or unsigned integer, a    floating-point value, or an address. -    data Width = W8 | W16 | W32 | W64 | W80 | W128+    data Width = W8 | W16 | W32 | W64  | W128   - Size, which is used in the native code generator, is Width +    floating point information. -   data Size = II8 | II16 | II32 | II64 | FF32 | FF64 | FF80+   data Size = II8 | II16 | II32 | II64 | FF32 | FF64     it is necessary because e.g. the instruction to move a 64-bit float    on x86 (movsd) is different from the instruction to move a 64-bit

@@ -1044,7 +1044,7 @@     init_subst = mkEmptyTCvSubst $ mkInScopeSet (tyCoVarsOfTypes (ty:orig_args))      go :: TCvSubst -> Type -> [Type] -> Type-    go subst ty [] = substTy subst ty+    go subst ty [] = substTyUnchecked subst ty      go subst ty all_args@(arg:args)       | Just ty' <- coreView ty@@ -1698,6 +1698,21 @@         subst' = extendTvSubst subst tv arg_ty     go subst (TyVarTy tv) arg_tys       | Just ki <- lookupTyVar subst tv = go subst ki arg_tys+    -- This FunTy case is important to handle kinds with nested foralls, such+    -- as this kind (inspired by #16518):+    --+    --   forall {k1} k2. k1 -> k2 -> forall k3. k3 -> Type+    --+    -- Here, we want to get the following ArgFlags:+    --+    -- [Inferred,   Specified, Required, Required, Specified, Required]+    -- forall {k1}. forall k2. k1 ->     k2 ->     forall k3. k3 ->     Type+    go subst (FunTy{ft_af = af, ft_res = res_ki}) (_:arg_tys)+      = argf : go subst res_ki arg_tys+      where+        argf = case af of+                 VisArg   -> Required+                 InvisArg -> Inferred     go _ _ arg_tys = map (const Required) arg_tys                         -- something is ill-kinded. But this can happen                         -- when printing errors. Assume everything is Required.

@@ -327,6 +327,10 @@ instance IsString SDoc where   fromString = text +-- The lazy programmer's friend.+instance Outputable SDoc where+  ppr = id+ initSDocContext :: DynFlags -> PprStyle -> SDocContext initSDocContext dflags sty = SDC   { sdocStyle = sty

@@ -1149,7 +1149,6 @@     pow2 x | x == 1 = 0            | otherwise = 1 + pow2 (x `shiftR` 1) - {- -- ----------------------------------------------------------------------------- -- Floats

@@ -1,7 +1,7 @@ cabal-version: >=1.22 build-type: Simple name: ghc-lib-parser-version: 0.20190402+version: 0.20190423 license: BSD3 license-file: LICENSE category: Development@@ -55,7 +55,7 @@ tested-with:GHC==8.6.3 source-repository head     type: git-    location: git://git.haskell.org/ghc.git+    location: git@github.com:digital-asset/ghc-lib.git  library     default-language:   Haskell2010@@ -124,7 +124,6 @@         UndecidableInstances     c-sources:         compiler/cbits/genSym.c-        compiler/ghci/keepCAFsForGHCi.c         compiler/parser/cutils.c     hs-source-dirs:         compiler

@@ -5,7 +5,8 @@ # define __GLASGOW_HASKELL__ 809 #endif -#define __GLASGOW_HASKELL_PATCHLEVEL1__ 20190402+#define __GLASGOW_HASKELL_PATCHLEVEL1__ 0+#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20190423  #define MIN_VERSION_GLASGOW_HASKELL(ma,mi,pl1,pl2) (\    ((ma)*100+(mi)) <  __GLASGOW_HASKELL__ || \

@@ -9562,7 +9562,7 @@   {-# LINE 18 "<built-in>" #-}-{-# LINE 1 "/var/folders/f_/bb4zyb7d2_z9bqm3hrqrjgp40000gn/T/ghc75776_0/ghc_2.h" #-}+{-# LINE 1 "/var/folders/f_/bb4zyb7d2_z9bqm3hrqrjgp40000gn/T/ghc27488_0/ghc_2.h" #-}   

@@ -19,17 +19,17 @@ cProjectName          :: String cProjectName          = "The Glorious Glasgow Haskell Compilation System" cProjectGitCommitId   :: String-cProjectGitCommitId   = "bf73419518ca550e85188616f860961c7e2a336b"+cProjectGitCommitId   = "ab9b3ace24e57359d5745dd9abf593d1ec94a0ad" cProjectVersion       :: String-cProjectVersion       = "8.9.20190402"+cProjectVersion       = "8.9.0.20190423" cProjectVersionInt    :: String cProjectVersionInt    = "809" cProjectPatchLevel    :: String-cProjectPatchLevel    = "20190402"+cProjectPatchLevel    = "020190423" cProjectPatchLevel1   :: String-cProjectPatchLevel1   = "20190402"+cProjectPatchLevel1   = "0" cProjectPatchLevel2   :: String-cProjectPatchLevel2   = ""+cProjectPatchLevel2   = "20190423" cBooterVersion        :: String cBooterVersion        = "8.6.4" cStage                :: String

@@ -1,35 +1,34 @@-[("GCC extra via C opts", " -fwrapv -fno-builtin"),- ("C compiler command", "gcc"),- ("C compiler flags", ""),- ("C compiler link flags", " "),- ("C compiler supports -no-pie", "NO"),- ("Haskell CPP command","gcc"),- ("Haskell CPP flags","-E -undef -traditional -Wno-invalid-pp-token -Wno-unicode -Wno-trigraphs"),- ("ld command", "ld"),- ("ld flags", ""),- ("ld supports compact unwind", "YES"),- ("ld supports build-id", "NO"),- ("ld supports filelist", "YES"),- ("ld is GNU ld", "NO"),- ("ar command", "ar"),- ("ar flags", "qcls"),- ("ar supports at file", "NO"),- ("ranlib command", "ranlib"),- ("touch command", "touch"),- ("dllwrap command", "/bin/false"),- ("windres command", "/bin/false"),- ("libtool command", "libtool"),- ("cross compiling", "NO"),- ("target os", "OSDarwin"),- ("target arch", "ArchX86_64"),- ("target word size", "8"),- ("target has GNU nonexec stack", "False"),- ("target has .ident directive", "True"),- ("target has subsections via symbols", "True"),- ("target has RTS linker", "YES"),- ("Unregisterised", "NO"),- ("LLVM llc command", "llc"),- ("LLVM opt command", "opt"),- ("LLVM clang command", "clang")- ]-+[("GCC extra via C opts", " -fwrapv -fno-builtin")+,("C compiler command", "gcc")+,("C compiler flags", "")+,("C compiler link flags", " ")+,("C compiler supports -no-pie", "NO")+,("Haskell CPP command", "gcc")+,("Haskell CPP flags", "-E -undef -traditional -Wno-invalid-pp-token -Wno-unicode -Wno-trigraphs")+,("ld command", "ld")+,("ld flags", "")+,("ld supports compact unwind", "YES")+,("ld supports build-id", "NO")+,("ld supports filelist", "YES")+,("ld is GNU ld", "NO")+,("ar command", "ar")+,("ar flags", "qcls")+,("ar supports at file", "NO")+,("ranlib command", "ranlib")+,("touch command", "touch")+,("dllwrap command", "/bin/false")+,("windres command", "/bin/false")+,("libtool command", "libtool")+,("cross compiling", "NO")+,("target os", "OSDarwin")+,("target arch", "ArchX86_64")+,("target word size", "8")+,("target has GNU nonexec stack", "False")+,("target has .ident directive", "True")+,("target has subsections via symbols", "True")+,("target has RTS linker", "YES")+,("Unregisterised", "NO")+,("LLVM llc command", "llc")+,("LLVM opt command", "opt")+,("LLVM clang command", "clang")+]

@@ -41,65 +41,59 @@ #  define r15   15 # endif -# define fake0 16-# define fake1 17-# define fake2 18-# define fake3 19-# define fake4 20-# define fake5 21  -- N.B. XMM, YMM, and ZMM are all aliased to the same hardware registers hence -- being assigned the same RegNos.-# define xmm0  24-# define xmm1  25-# define xmm2  26-# define xmm3  27-# define xmm4  28-# define xmm5  29-# define xmm6  30-# define xmm7  31-# define xmm8  32-# define xmm9  33-# define xmm10 34-# define xmm11 35-# define xmm12 36-# define xmm13 37-# define xmm14 38-# define xmm15 39+# define xmm0  16+# define xmm1  17+# define xmm2  18+# define xmm3  19+# define xmm4  20+# define xmm5  21+# define xmm6  22+# define xmm7  23+# define xmm8  24+# define xmm9  25+# define xmm10 26+# define xmm11 27+# define xmm12 28+# define xmm13 29+# define xmm14 30+# define xmm15 31 -# define ymm0  24-# define ymm1  25-# define ymm2  26-# define ymm3  27-# define ymm4  28-# define ymm5  29-# define ymm6  30-# define ymm7  31-# define ymm8  32-# define ymm9  33-# define ymm10 34-# define ymm11 35-# define ymm12 36-# define ymm13 37-# define ymm14 38-# define ymm15 39+# define ymm0  16+# define ymm1  17+# define ymm2  18+# define ymm3  19+# define ymm4  20+# define ymm5  21+# define ymm6  22+# define ymm7  23+# define ymm8  24+# define ymm9  25+# define ymm10 26+# define ymm11 27+# define ymm12 28+# define ymm13 29+# define ymm14 30+# define ymm15 31 -# define zmm0  24-# define zmm1  25-# define zmm2  26-# define zmm3  27-# define zmm4  28-# define zmm5  29-# define zmm6  30-# define zmm7  31-# define zmm8  32-# define zmm9  33-# define zmm10 34-# define zmm11 35-# define zmm12 36-# define zmm13 37-# define zmm14 38-# define zmm15 39+# define zmm0  16+# define zmm1  17+# define zmm2  18+# define zmm3  19+# define zmm4  20+# define zmm5  21+# define zmm6  22+# define zmm7  23+# define zmm8  24+# define zmm9  25+# define zmm10 26+# define zmm11 27+# define zmm12 28+# define zmm13 29+# define zmm14 30+# define zmm15 31  -- Note: these are only needed for ARM/ARM64 because globalRegMaybe is now used in CmmSink.hs. -- Since it's only used to check 'isJust', the actual values don't matter, thus

@@ -1,6 +1,8 @@ {-# LANGUAGE CPP, DeriveDataTypeable,              DeriveGeneric, FlexibleInstances, DefaultSignatures,              RankNTypes, RoleAnnotations, ScopedTypeVariables,+             MagicHash, KindSignatures, PolyKinds, TypeApplications, DataKinds,+             GADTs, UnboxedTuples, UnboxedSums, TypeInType,              Trustworthy #-}  {-# OPTIONS_GHC -fno-warn-inline-rule-shadowing #-}@@ -32,13 +34,17 @@ import Control.Monad (liftM) import Control.Monad.IO.Class (MonadIO (..)) import System.IO        ( hPutStrLn, stderr )-import Data.Char        ( isAlpha, isAlphaNum, isUpper )+import Data.Char        ( isAlpha, isAlphaNum, isUpper, ord ) import Data.Int import Data.List.NonEmpty ( NonEmpty(..) ) import Data.Void        ( Void, absurd ) import Data.Word import Data.Ratio+import GHC.CString      ( unpackCString# ) import GHC.Generics     ( Generic )+import GHC.Types        ( Int(..), Word(..), Char(..), Double(..), Float(..),+                          TYPE, RuntimeRep(..) )+import GHC.Prim         ( Int#, Word#, Char#, Double#, Float#, Addr# ) import GHC.Lexeme       ( startsVarSym, startsVarId ) import GHC.ForeignSrcLang.Type import Language.Haskell.TH.LanguageExtensions@@ -201,7 +207,7 @@ -----------------------------------------------------  type role TExp nominal   -- See Note [Role of TExp]-newtype TExp a = TExp+newtype TExp (a :: TYPE (r :: RuntimeRep)) = TExp   { unType :: Exp -- ^ Underlying untyped Template Haskell expression   } -- ^ Represents an expression which has type @a@. Built on top of 'Exp', typed@@ -240,7 +246,9 @@  -- | Discard the type annotation and produce a plain Template Haskell -- expression-unTypeQ :: Q (TExp a) -> Q Exp+--+-- Levity-polymorphic since /template-haskell-2.16.0.0/.+unTypeQ :: forall (r :: RuntimeRep) (a :: TYPE r). Q (TExp a) -> Q Exp unTypeQ m = do { TExp e <- m                ; return e } @@ -248,7 +256,9 @@ -- -- This is unsafe because GHC cannot check for you that the expression -- really does have the type you claim it has.-unsafeTExpCoerce :: Q Exp -> Q (TExp a)+--+-- Levity-polymorphic since /template-haskell-2.16.0.0/.+unsafeTExpCoerce :: forall (r :: RuntimeRep) (a :: TYPE r). Q Exp -> Q (TExp a) unsafeTExpCoerce m = do { e <- m                         ; return (TExp e) } @@ -651,17 +661,18 @@  -- | A 'Lift' instance can have any of its values turned into a Template -- Haskell expression. This is needed when a value used within a Template--- Haskell quotation is bound outside the Oxford brackets (@[| ... |]@) but not--- at the top level. As an example:+-- Haskell quotation is bound outside the Oxford brackets (@[| ... |]@ or+-- @[|| ... ||]@) but not at the top level. As an example: ----- > add1 :: Int -> Q Exp--- > add1 x = [| x + 1 |]+-- > add1 :: Int -> Q (TExp Int)+-- > add1 x = [|| x + 1 ||] -- -- Template Haskell has no way of knowing what value @x@ will take on at -- splice-time, so it requires the type of @x@ to be an instance of 'Lift'. ----- A 'Lift' instance must satisfy @$(lift x) ≡ x@ for all @x@, where @$(...)@--- is a Template Haskell splice.+-- A 'Lift' instance must satisfy @$(lift x) ≡ x@ and @$$(liftTyped x) ≡ x@+-- for all @x@, where @$(...)@ and @$$(...)@ are Template Haskell splices.+-- It is additionally expected that @'lift' x ≡ 'unTypeQ' ('liftTyped' x)@. -- -- 'Lift' instances can be derived automatically by use of the @-XDeriveLift@ -- GHC language extension:@@ -673,10 +684,13 @@ -- > -- > data Bar a = Bar1 a (Bar a) | Bar2 String -- >   deriving Lift-class Lift t where+--+-- Levity-polymorphic since /template-haskell-2.16.0.0/.+class Lift (t :: TYPE r) where   -- | Turn a value into a Template Haskell expression, suitable for use in   -- a splice.   lift :: t -> Q Exp+  default lift :: (r ~ 'LiftedRep) => t -> Q Exp   lift = unTypeQ . liftTyped    -- | Turn a value into a Template Haskell typed expression, suitable for use@@ -684,73 +698,127 @@   --   -- @since 2.16.0.0   liftTyped :: t -> Q (TExp t)-  liftTyped = unsafeTExpCoerce . lift -  {-# MINIMAL lift | liftTyped #-} - -- If you add any instances here, consider updating test th/TH_Lift instance Lift Integer where+  liftTyped x = unsafeTExpCoerce (lift x)   lift x = return (LitE (IntegerL x))  instance Lift Int where+  liftTyped x = unsafeTExpCoerce (lift x)   lift x = return (LitE (IntegerL (fromIntegral x))) +-- | @since 2.16.0.0+instance Lift Int# where+  liftTyped x = unsafeTExpCoerce (lift x)+  lift x = return (LitE (IntPrimL (fromIntegral (I# x))))+ instance Lift Int8 where+  liftTyped x = unsafeTExpCoerce (lift x)   lift x = return (LitE (IntegerL (fromIntegral x)))  instance Lift Int16 where+  liftTyped x = unsafeTExpCoerce (lift x)   lift x = return (LitE (IntegerL (fromIntegral x)))  instance Lift Int32 where+  liftTyped x = unsafeTExpCoerce (lift x)   lift x = return (LitE (IntegerL (fromIntegral x)))  instance Lift Int64 where+  liftTyped x = unsafeTExpCoerce (lift x)   lift x = return (LitE (IntegerL (fromIntegral x))) +-- | @since 2.16.0.0+instance Lift Word# where+  liftTyped x = unsafeTExpCoerce (lift x)+  lift x = return (LitE (WordPrimL (fromIntegral (W# x))))+ instance Lift Word where+  liftTyped x = unsafeTExpCoerce (lift x)   lift x = return (LitE (IntegerL (fromIntegral x)))  instance Lift Word8 where+  liftTyped x = unsafeTExpCoerce (lift x)   lift x = return (LitE (IntegerL (fromIntegral x)))  instance Lift Word16 where+  liftTyped x = unsafeTExpCoerce (lift x)   lift x = return (LitE (IntegerL (fromIntegral x)))  instance Lift Word32 where+  liftTyped x = unsafeTExpCoerce (lift x)   lift x = return (LitE (IntegerL (fromIntegral x)))  instance Lift Word64 where+  liftTyped x = unsafeTExpCoerce (lift x)   lift x = return (LitE (IntegerL (fromIntegral x)))  instance Lift Natural where+  liftTyped x = unsafeTExpCoerce (lift x)   lift x = return (LitE (IntegerL (fromIntegral x)))  instance Integral a => Lift (Ratio a) where+  liftTyped x = unsafeTExpCoerce (lift x)   lift x = return (LitE (RationalL (toRational x)))  instance Lift Float where+  liftTyped x = unsafeTExpCoerce (lift x)   lift x = return (LitE (RationalL (toRational x))) +-- | @since 2.16.0.0+instance Lift Float# where+  liftTyped x = unsafeTExpCoerce (lift x)+  lift x = return (LitE (FloatPrimL (toRational (F# x))))+ instance Lift Double where+  liftTyped x = unsafeTExpCoerce (lift x)   lift x = return (LitE (RationalL (toRational x))) +-- | @since 2.16.0.0+instance Lift Double# where+  liftTyped x = unsafeTExpCoerce (lift x)+  lift x = return (LitE (DoublePrimL (toRational (D# x))))+ instance Lift Char where+  liftTyped x = unsafeTExpCoerce (lift x)   lift x = return (LitE (CharL x)) +-- | @since 2.16.0.0+instance Lift Char# where+  liftTyped x = unsafeTExpCoerce (lift x)+  lift x = return (LitE (CharPrimL (C# x)))+ instance Lift Bool where+  liftTyped x = unsafeTExpCoerce (lift x)+   lift True  = return (ConE trueName)   lift False = return (ConE falseName) +-- | Produces an 'Addr#' literal from the NUL-terminated C-string starting at+-- the given memory address.+--+-- @since 2.16.0.0+instance Lift Addr# where+  liftTyped x = unsafeTExpCoerce (lift x)+  lift x+    = return (LitE (StringPrimL (map (fromIntegral . ord) (unpackCString# x))))+ instance Lift a => Lift (Maybe a) where+  liftTyped x = unsafeTExpCoerce (lift x)+   lift Nothing  = return (ConE nothingName)   lift (Just x) = liftM (ConE justName `AppE`) (lift x)  instance (Lift a, Lift b) => Lift (Either a b) where+  liftTyped x = unsafeTExpCoerce (lift x)+   lift (Left x)  = liftM (ConE leftName  `AppE`) (lift x)   lift (Right y) = liftM (ConE rightName `AppE`) (lift y)  instance Lift a => Lift [a] where+  liftTyped x = unsafeTExpCoerce (lift x)   lift xs = do { xs' <- mapM lift xs; return (ListE xs') }  liftString :: String -> Q Exp@@ -759,6 +827,8 @@  -- | @since 2.15.0.0 instance Lift a => Lift (NonEmpty a) where+  liftTyped x = unsafeTExpCoerce (lift x)+   lift (x :| xs) = do     x' <- lift x     xs' <- lift xs@@ -766,38 +836,166 @@  -- | @since 2.15.0.0 instance Lift Void where+  liftTyped = pure . absurd   lift = pure . absurd  instance Lift () where+  liftTyped x = unsafeTExpCoerce (lift x)   lift () = return (ConE (tupleDataName 0))  instance (Lift a, Lift b) => Lift (a, b) where+  liftTyped x = unsafeTExpCoerce (lift x)   lift (a, b)     = liftM TupE $ sequence [lift a, lift b]  instance (Lift a, Lift b, Lift c) => Lift (a, b, c) where+  liftTyped x = unsafeTExpCoerce (lift x)   lift (a, b, c)     = liftM TupE $ sequence [lift a, lift b, lift c]  instance (Lift a, Lift b, Lift c, Lift d) => Lift (a, b, c, d) where+  liftTyped x = unsafeTExpCoerce (lift x)   lift (a, b, c, d)     = liftM TupE $ sequence [lift a, lift b, lift c, lift d]  instance (Lift a, Lift b, Lift c, Lift d, Lift e)       => Lift (a, b, c, d, e) where+  liftTyped x = unsafeTExpCoerce (lift x)   lift (a, b, c, d, e)     = liftM TupE $ sequence [lift a, lift b, lift c, lift d, lift e]  instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f)       => Lift (a, b, c, d, e, f) where+  liftTyped x = unsafeTExpCoerce (lift x)   lift (a, b, c, d, e, f)     = liftM TupE $ sequence [lift a, lift b, lift c, lift d, lift e, lift f]  instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f, Lift g)       => Lift (a, b, c, d, e, f, g) where+  liftTyped x = unsafeTExpCoerce (lift x)   lift (a, b, c, d, e, f, g)     = liftM TupE $ sequence [lift a, lift b, lift c, lift d, lift e, lift f, lift g] +-- | @since 2.16.0.0+instance Lift (# #) where+  liftTyped x = unsafeTExpCoerce (lift x)+  lift (# #) = return (ConE (unboxedTupleTypeName 0))++-- | @since 2.16.0.0+instance (Lift a) => Lift (# a #) where+  liftTyped x = unsafeTExpCoerce (lift x)+  lift (# a #)+    = liftM UnboxedTupE $ sequence [lift a]++-- | @since 2.16.0.0+instance (Lift a, Lift b) => Lift (# a, b #) where+  liftTyped x = unsafeTExpCoerce (lift x)+  lift (# a, b #)+    = liftM UnboxedTupE $ sequence [lift a, lift b]++-- | @since 2.16.0.0+instance (Lift a, Lift b, Lift c)+      => Lift (# a, b, c #) where+  liftTyped x = unsafeTExpCoerce (lift x)+  lift (# a, b, c #)+    = liftM UnboxedTupE $ sequence [lift a, lift b, lift c]++-- | @since 2.16.0.0+instance (Lift a, Lift b, Lift c, Lift d)+      => Lift (# a, b, c, d #) where+  liftTyped x = unsafeTExpCoerce (lift x)+  lift (# a, b, c, d #)+    = liftM UnboxedTupE $ sequence [lift a, lift b, lift c, lift d]++-- | @since 2.16.0.0+instance (Lift a, Lift b, Lift c, Lift d, Lift e)+      => Lift (# a, b, c, d, e #) where+  liftTyped x = unsafeTExpCoerce (lift x)+  lift (# a, b, c, d, e #)+    = liftM UnboxedTupE $ sequence [lift a, lift b, lift c, lift d, lift e]++-- | @since 2.16.0.0+instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f)+      => Lift (# a, b, c, d, e, f #) where+  liftTyped x = unsafeTExpCoerce (lift x)+  lift (# a, b, c, d, e, f #)+    = liftM UnboxedTupE $ sequence [lift a, lift b, lift c, lift d, lift e, lift f]++-- | @since 2.16.0.0+instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f, Lift g)+      => Lift (# a, b, c, d, e, f, g #) where+  liftTyped x = unsafeTExpCoerce (lift x)+  lift (# a, b, c, d, e, f, g #)+    = liftM UnboxedTupE $ sequence [lift a, lift b, lift c, lift d, lift e, lift f, lift g]++-- | @since 2.16.0.0+instance (Lift a, Lift b) => Lift (# a | b #) where+  liftTyped x = unsafeTExpCoerce (lift x)+  lift x+    = case x of+        (# y | #) -> UnboxedSumE <$> lift y <*> pure 1 <*> pure 2+        (# | y #) -> UnboxedSumE <$> lift y <*> pure 2 <*> pure 2++-- | @since 2.16.0.0+instance (Lift a, Lift b, Lift c)+      => Lift (# a | b | c #) where+  liftTyped x = unsafeTExpCoerce (lift x)+  lift x+    = case x of+        (# y | | #) -> UnboxedSumE <$> lift y <*> pure 1 <*> pure 3+        (# | y | #) -> UnboxedSumE <$> lift y <*> pure 2 <*> pure 3+        (# | | y #) -> UnboxedSumE <$> lift y <*> pure 3 <*> pure 3++-- | @since 2.16.0.0+instance (Lift a, Lift b, Lift c, Lift d)+      => Lift (# a | b | c | d #) where+  liftTyped x = unsafeTExpCoerce (lift x)+  lift x+    = case x of+        (# y | | | #) -> UnboxedSumE <$> lift y <*> pure 1 <*> pure 4+        (# | y | | #) -> UnboxedSumE <$> lift y <*> pure 2 <*> pure 4+        (# | | y | #) -> UnboxedSumE <$> lift y <*> pure 3 <*> pure 4+        (# | | | y #) -> UnboxedSumE <$> lift y <*> pure 4 <*> pure 4++-- | @since 2.16.0.0+instance (Lift a, Lift b, Lift c, Lift d, Lift e)+      => Lift (# a | b | c | d | e #) where+  liftTyped x = unsafeTExpCoerce (lift x)+  lift x+    = case x of+        (# y | | | | #) -> UnboxedSumE <$> lift y <*> pure 1 <*> pure 5+        (# | y | | | #) -> UnboxedSumE <$> lift y <*> pure 2 <*> pure 5+        (# | | y | | #) -> UnboxedSumE <$> lift y <*> pure 3 <*> pure 5+        (# | | | y | #) -> UnboxedSumE <$> lift y <*> pure 4 <*> pure 5+        (# | | | | y #) -> UnboxedSumE <$> lift y <*> pure 5 <*> pure 5++-- | @since 2.16.0.0+instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f)+      => Lift (# a | b | c | d | e | f #) where+  liftTyped x = unsafeTExpCoerce (lift x)+  lift x+    = case x of+        (# y | | | | | #) -> UnboxedSumE <$> lift y <*> pure 1 <*> pure 6+        (# | y | | | | #) -> UnboxedSumE <$> lift y <*> pure 2 <*> pure 6+        (# | | y | | | #) -> UnboxedSumE <$> lift y <*> pure 3 <*> pure 6+        (# | | | y | | #) -> UnboxedSumE <$> lift y <*> pure 4 <*> pure 6+        (# | | | | y | #) -> UnboxedSumE <$> lift y <*> pure 5 <*> pure 6+        (# | | | | | y #) -> UnboxedSumE <$> lift y <*> pure 6 <*> pure 6++-- | @since 2.16.0.0+instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f, Lift g)+      => Lift (# a | b | c | d | e | f | g #) where+  liftTyped x = unsafeTExpCoerce (lift x)+  lift x+    = case x of+        (# y | | | | | | #) -> UnboxedSumE <$> lift y <*> pure 1 <*> pure 7+        (# | y | | | | | #) -> UnboxedSumE <$> lift y <*> pure 2 <*> pure 7+        (# | | y | | | | #) -> UnboxedSumE <$> lift y <*> pure 3 <*> pure 7+        (# | | | y | | | #) -> UnboxedSumE <$> lift y <*> pure 4 <*> pure 7+        (# | | | | y | | #) -> UnboxedSumE <$> lift y <*> pure 5 <*> pure 7+        (# | | | | | y | #) -> UnboxedSumE <$> lift y <*> pure 6 <*> pure 7+        (# | | | | | | y #) -> UnboxedSumE <$> lift y <*> pure 7 <*> pure 7+ -- TH has a special form for literal strings, -- which we should take advantage of. -- NB: the lhs of the rule has no args, so that@@ -1619,8 +1817,8 @@          | WordPrimL Integer          | FloatPrimL Rational          | DoublePrimL Rational-         | StringPrimL [Word8]  -- ^ A primitive C-style string, type Addr#-         | BytesPrimL Bytes     -- ^ Some raw bytes, type Addr#:+         | StringPrimL [Word8]  -- ^ A primitive C-style string, type 'Addr#'+         | BytesPrimL Bytes     -- ^ Some raw bytes, type 'Addr#':          | CharPrimL Char     deriving( Show, Eq, Ord, Data, Generic )