[Git][ghc/ghc][wip/backports-9.0] 4 commits: Backport: Fix for #18955 to GHC 9.0

Ben Gamari gitlab at gitlab.haskell.org
Mon Dec 14 15:32:01 UTC 2020



Ben Gamari pushed to branch wip/backports-9.0 at Glasgow Haskell Compiler / GHC


Commits:
00f07ca5 by Roland Senn at 2020-12-08T20:16:09+01:00
Backport: Fix for #18955 to GHC 9.0

Since MR !554 (#15454) GHCi automatically enabled the flag `-fobject-code` on
any module using the UnboxedTuples or UnboxedSum extensions.

MR !1553 (#16876) allowed to inhibit the automatic compiling to object-code
of these modules by setting the `fbyte-code` flag. However, it assigned 2
different semantics to this flag and introduced the regression described in
issue #18955.

This MR fixes this regression by unsetting the internal flag
`Opt_ByteCodeIfUnboxed` before it's copied to DynFlags local to the module.

- - - - -
3a1af9bf by Ben Gamari at 2020-12-14T10:31:58-05:00
Bump Cabal submodule to 3.4.0.0-rc5

- - - - -
f081501e by Andreas Klebinger at 2020-12-14T10:31:58-05:00
RegAlloc: Add missing raPlatformfield to RegAllocStatsSpill

Fixes #18994

Co-Author: Benjamin Maurer <maurer.benjamin at gmail.com>
(cherry picked from commit 3e3555cc9c2a9f5246895f151259fd2a81621f38)

- - - - -
ca506ea7 by Shayne Fletcher at 2020-12-14T10:31:58-05:00
Fix bad span calculations of post qualified imports

(cherry picked from commit 4a437bc19d2026845948356a932b2cac2417eb12)

- - - - -


15 changed files:

- compiler/GHC/CmmToAsm/Reg/Graph.hs
- compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Parser.y
- ghc/GHCi/UI.hs
- libraries/Cabal
- + testsuite/tests/ghci/scripts/T18955.hs
- + testsuite/tests/ghci/scripts/T18955.script
- + testsuite/tests/ghci/scripts/T18955.stdout
- testsuite/tests/ghci/scripts/all.T
- testsuite/tests/module/all.T
- + testsuite/tests/module/mod185.hs
- + testsuite/tests/module/mod185.stderr


Changes:

=====================================
compiler/GHC/CmmToAsm/Reg/Graph.hs
=====================================
@@ -278,7 +278,8 @@ regAlloc_spin config spinCount triv regsFree slotsFree slotsCount debug_codeGrap
                         , raCoalesced   = rmCoalesce
                         , raSpillStats  = spillStats
                         , raSpillCosts  = spillCosts
-                        , raSpilled     = code_spilled }
+                        , raSpilled     = code_spilled
+                        , raPlatform    = platform }
 
                 -- Bundle up all the register allocator statistics.
                 --   .. but make sure to drop them on the floor if they're not


=====================================
compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs
=====================================
@@ -73,7 +73,11 @@ data RegAllocStats statics instr
         , raSpillCosts  :: SpillCostInfo
 
           -- | Code with spill instructions added.
-        , raSpilled     :: [LiveCmmDecl statics instr] }
+        , raSpilled     :: [LiveCmmDecl statics instr]
+
+          -- | Target platform
+        , raPlatform    :: !Platform
+        }
 
 
         -- a successful coloring


=====================================
compiler/GHC/Driver/Flags.hs
=====================================
@@ -273,7 +273,7 @@ data GeneralFlag
    | Opt_SingleLibFolder
    | Opt_KeepCAFs
    | Opt_KeepGoing
-   | Opt_ByteCode
+   | Opt_ByteCodeIfUnboxed
    | Opt_LinkRts
 
    -- output style opts


=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -2230,7 +2230,7 @@ enableCodeGenForUnboxedTuplesOrSums =
   where
     condition ms =
       unboxed_tuples_or_sums (ms_hspp_opts ms) &&
-      not (gopt Opt_ByteCode (ms_hspp_opts ms)) &&
+      not (gopt Opt_ByteCodeIfUnboxed (ms_hspp_opts ms)) &&
       (isBootSummary ms == NotBoot)
     unboxed_tuples_or_sums d =
       xopt LangExt.UnboxedTuples d || xopt LangExt.UnboxedSums d


=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -3091,10 +3091,10 @@ dynamic_flags_deps = [
 
   , make_ord_flag defFlag "fno-code"         (NoArg ((upd $ \d ->
                   d { ghcLink=NoLink }) >> setTarget HscNothing))
-  , make_ord_flag defFlag "fbyte-code"
-      (noArgM $ \dflags -> do
-        setTarget HscInterpreted
-        pure $ gopt_set dflags Opt_ByteCode)
+  , make_ord_flag defFlag "fbyte-code"       (NoArg ((upd $ \d ->
+      -- Enabling Opt_ByteCodeIfUnboxed is a workaround for #18955.
+      -- See the comments for resetOptByteCodeIfUnboxed for more details.
+      gopt_set d Opt_ByteCodeIfUnboxed) >> setTarget HscInterpreted))
   , make_ord_flag defFlag "fobject-code"     $ NoArg $ do
       dflags <- liftEwM getCmdLineState
       setTarget $ defaultObjectTarget dflags


=====================================
compiler/GHC/Parser.y
=====================================
@@ -967,18 +967,20 @@ importdecls_semi
 importdecl :: { LImportDecl GhcPs }
         : 'import' maybe_src maybe_safe optqualified maybe_pkg modid optqualified maybeas maybeimpspec
                 {% do {
-                  ; checkImportDecl $4 $7
-                  ; ams (L (comb4 $1 $6 (snd $8) $9) $
+                  ; let { ; mPreQual = unLoc $4
+                          ; mPostQual = unLoc $7 }
+                  ; checkImportDecl mPreQual mPostQual
+                  ; ams (L (comb5 $1 $6 $7 (snd $8) $9) $
                       ImportDecl { ideclExt = noExtField
                                   , ideclSourceSrc = snd $ fst $2
                                   , ideclName = $6, ideclPkgQual = snd $5
                                   , ideclSource = snd $2, ideclSafe = snd $3
-                                  , ideclQualified = importDeclQualifiedStyle $4 $7
+                                  , ideclQualified = importDeclQualifiedStyle mPreQual mPostQual
                                   , ideclImplicit = False
                                   , ideclAs = unLoc (snd $8)
                                   , ideclHiding = unLoc $9 })
-                         (mj AnnImport $1 : fst (fst $2) ++ fst $3 ++ fmap (mj AnnQualified) (maybeToList $4)
-                                          ++ fst $5 ++ fmap (mj AnnQualified) (maybeToList $7) ++ fst $8)
+                         (mj AnnImport $1 : fst (fst $2) ++ fst $3 ++ fmap (mj AnnQualified) (maybeToList mPreQual)
+                                          ++ fst $5 ++ fmap (mj AnnQualified) (maybeToList mPostQual) ++ fst $8)
                   }
                 }
 
@@ -1002,9 +1004,9 @@ maybe_pkg :: { ([AddAnn],Maybe StringLiteral) }
                         ; return ([mj AnnPackageName $1], Just (StringLiteral (getSTRINGs $1) pkgFS)) } }
         | {- empty -}                           { ([],Nothing) }
 
-optqualified :: { Maybe (Located Token) }
-        : 'qualified'                           { Just $1 }
-        | {- empty -}                           { Nothing }
+optqualified :: { Located (Maybe (Located Token)) }
+        : 'qualified'                           { sL1 $1 (Just $1) }
+        | {- empty -}                           { noLoc Nothing }
 
 maybeas :: { ([AddAnn],Located (Maybe (Located ModuleName))) }
         : 'as' modid                           { ([mj AnnAs $1]
@@ -3754,6 +3756,11 @@ comb4 a b c d = a `seq` b `seq` c `seq` d `seq`
     (combineSrcSpans (getLoc a) $ combineSrcSpans (getLoc b) $
                 combineSrcSpans (getLoc c) (getLoc d))
 
+comb5 :: Located a -> Located b -> Located c -> Located d -> Located e -> SrcSpan
+comb5 a b c d e = a `seq` b `seq` c `seq` d `seq` e `seq`
+    (combineSrcSpans (getLoc a) $ combineSrcSpans (getLoc b) $
+       combineSrcSpans (getLoc c) $ combineSrcSpans (getLoc d) (getLoc e))
+
 -- strict constructor version:
 {-# INLINE sL #-}
 sL :: SrcSpan -> a -> Located a


=====================================
ghc/GHCi/UI.hs
=====================================
@@ -1941,6 +1941,7 @@ reloadModuleDefer = wrapDeferTypeErrors . reloadModule
 -- sessions.
 doLoadAndCollectInfo :: GhciMonad m => Bool -> LoadHowMuch -> m SuccessFlag
 doLoadAndCollectInfo retain_context howmuch = do
+  resetOptByteCodeIfUnboxed                                 -- #18955
   doCollectInfo <- isOptionSet CollectInfo
 
   doLoad retain_context howmuch >>= \case
@@ -1953,6 +1954,24 @@ doLoadAndCollectInfo retain_context howmuch = do
       return Succeeded
     flag -> return flag
 
+-- An `OPTIONS_GHC -fbyte-code` pragma at the beginning of a module sets the
+-- flag `Opt_ByteCodeIfUnboxed` locally for this module. This stops automatic
+-- compilation of this module to object code, if the module uses (or depends
+-- on a module using) the UnboxedSums/Tuples extensions.
+-- However a GHCi `:set -fbyte-code` command sets the flag Opt_ByteCodeIfUnboxed
+-- globally to all modules. This triggered #18955. This function unsets the
+-- flag from the global DynFlags before they are copied to the module-specific
+-- DynFlags.
+-- This is a temporary workaround until GHCi will support unboxed tuples and
+-- unboxed sums.
+resetOptByteCodeIfUnboxed :: GhciMonad m => m ()
+resetOptByteCodeIfUnboxed = do
+  dflags <- getDynFlags
+  when (gopt Opt_ByteCodeIfUnboxed dflags) $ do
+    _ <- GHC.setProgramDynFlags $ gopt_unset dflags Opt_ByteCodeIfUnboxed
+    pure ()
+  pure ()
+
 doLoad :: GhciMonad m => Bool -> LoadHowMuch -> m SuccessFlag
 doLoad retain_context howmuch = do
   -- turn off breakpoints before we load: we can't turn them off later, because


=====================================
libraries/Cabal
=====================================
@@ -1 +1 @@
-Subproject commit 5aea8a4b8463e1ae95272e190a1022764164294f
+Subproject commit 7907a676ada3a5944cfa3b45e23deda7496767cf


=====================================
testsuite/tests/ghci/scripts/T18955.hs
=====================================
@@ -0,0 +1,2 @@
+main :: IO ()
+main = putStrLn "Hello World"


=====================================
testsuite/tests/ghci/scripts/T18955.script
=====================================
@@ -0,0 +1,3 @@
+:set -v1
+:set -fbyte-code
+:l T18955


=====================================
testsuite/tests/ghci/scripts/T18955.stdout
=====================================
@@ -0,0 +1,2 @@
+[1 of 1] Compiling Main             ( T18955.hs, interpreted )
+Ok, one module loaded.


=====================================
testsuite/tests/ghci/scripts/all.T
=====================================
@@ -318,3 +318,4 @@ test('T17403', normal, ghci_script, ['T17403.script'])
 test('T17431', normal, ghci_script, ['T17431.script'])
 test('T17549', normal, ghci_script, ['T17549.script'])
 test('T17669', [extra_run_opts('-fexternal-interpreter -fobject-code'), expect_broken(17669)], ghci_script, ['T17669.script'])
+test('T18955', [extra_hc_opts("-fobject-code")], ghci_script, ['T18955.script'])


=====================================
testsuite/tests/module/all.T
=====================================
@@ -268,6 +268,7 @@ test('mod181', normal, compile, [''])
 test('mod182', normal, compile_fail, [''])
 test('mod183', normal, compile_fail, [''])
 test('mod184', normal, compile, ['-Wprepositive-qualified-module'])
+test('mod185', normal, compile, ['-ddump-parsed-ast'])
 
 test('T1148', normal, compile, [''])
 test('T1074', normal, compile, [''])


=====================================
testsuite/tests/module/mod185.hs
=====================================
@@ -0,0 +1,5 @@
+{-# LANGUAGE ImportQualifiedPost #-}
+-- The span of the import decl should include the 'qualified' keyword.
+import Prelude qualified
+
+main = Prelude.undefined


=====================================
testsuite/tests/module/mod185.stderr
=====================================
@@ -0,0 +1,62 @@
+==================== Parser AST ====================
+
+({ mod185.hs:1:1 }
+ (HsModule
+  (VirtualBraces
+   (1))
+  (Nothing)
+  (Nothing)
+  [({ mod185.hs:3:1-24 }
+    (ImportDecl
+     (NoExtField)
+     (NoSourceText)
+     ({ mod185.hs:3:8-14 }
+      {ModuleName: Prelude})
+     (Nothing)
+     (NotBoot)
+     (False)
+     (QualifiedPost)
+     (False)
+     (Nothing)
+     (Nothing)))]
+  [({ mod185.hs:5:1-24 }
+    (ValD
+     (NoExtField)
+     (FunBind
+      (NoExtField)
+      ({ mod185.hs:5:1-4 }
+       (Unqual
+        {OccName: main}))
+      (MG
+       (NoExtField)
+       ({ mod185.hs:5:1-24 }
+        [({ mod185.hs:5:1-24 }
+          (Match
+           (NoExtField)
+           (FunRhs
+            ({ mod185.hs:5:1-4 }
+             (Unqual
+              {OccName: main}))
+            (Prefix)
+            (NoSrcStrict))
+           []
+           (GRHSs
+            (NoExtField)
+            [({ mod185.hs:5:6-24 }
+              (GRHS
+               (NoExtField)
+               []
+               ({ mod185.hs:5:8-24 }
+                (HsVar
+                 (NoExtField)
+                 ({ mod185.hs:5:8-24 }
+                  (Qual
+                   {ModuleName: Prelude}
+                   {OccName: undefined}))))))]
+            ({ <no location info> }
+             (EmptyLocalBinds
+              (NoExtField))))))])
+       (FromSource))
+      [])))]
+  (Nothing)
+  (Nothing)))



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9ca9e1fd2197a57291824ed4e4266182b8d909a1...ca506ea7457df6ff971abb65a4f94025813bb737

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9ca9e1fd2197a57291824ed4e4266182b8d909a1...ca506ea7457df6ff971abb65a4f94025813bb737
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/20201214/63839ddb/attachment-0001.html>


More information about the ghc-commits mailing list