[Git][ghc/ghc][wip/8-8-ghci] 5 commits: Have GHCi use object code for UnboxedTuples modules #15454
Matthew Pickering
gitlab at gitlab.haskell.org
Tue May 21 10:10:20 UTC 2019
Matthew Pickering pushed to branch wip/8-8-ghci at Glasgow Haskell Compiler / GHC
Commits:
e3733320 by Michael Sloan at 2019-05-21T10:09:56Z
Have GHCi use object code for UnboxedTuples modules #15454
The idea is to automatically enable -fobject-code for modules that use
UnboxedTuples, along with all the modules they depend on. When looking
into how to solve this, I was pleased to find that there was already
highly similar logic for enabling code generation when -fno-code is
specified but TemplateHaskell is used.
The state before this patch was that if you used unboxed tuples then you
had to enable `-fobject-code` globally rather than on a per module
basis.
- - - - -
2be66984 by Michael Sloan at 2019-05-21T10:09:56Z
Add PlainPanic for throwing exceptions without depending on pprint
This commit splits out a subset of GhcException which do not depend on
pretty printing (SDoc), as a new datatype called
PlainGhcException. These exceptions can be caught as GhcException,
because 'fromException' will convert them.
The motivation for this change is that that the Panic module
transitively depends on many modules, primarily due to pretty printing
code. It's on the order of about 130 modules. This large set of
dependencies has a few implications:
1. To avoid cycles / use of boot files, these dependencies cannot
throw GhcException.
2. There are some utility modules that use UnboxedTuples and also use
`panic`. This means that when loading GHC into GHCi, about 130
additional modules would need to be compiled instead of
interpreted. Splitting the non-pprint exception throwing into a new
module resolves this issue. See #13101
(cherry picked from commit fe9034e9b4820214a8c703bd8a3146ce6eed37b8)
- - - - -
34efaa60 by Michael Sloan at 2019-05-21T10:09:57Z
Remove unnecessary uses of UnboxedTuples pragma (see #13101 / #15454)
Also removes a couple unnecessary MagicHash pragmas
(cherry picked from commit 061276ea5d265eb3c23a3698f0a10f6a764ff4b4)
- - - - -
75807272 by Michael Sloan at 2019-05-21T10:09:57Z
Extract out use of UnboxedTuples from GHCi.Leak
See #13101 + #15454 for motivation. This change reduces the number of
modules that need to be compiled to object code when loading GHC into
GHCi.
(cherry picked from commit c01d5af31c8feb634fc3dffc84e6e7ece61ba190)
- - - - -
aa3346be by Michael Sloan at 2019-05-21T10:09:57Z
Use datatype for unboxed returns when loading ghc into ghci
See #13101 and #15454
(cherry picked from commit 64959e51bf17a9f991cc345476a40515e7b32d81)
- - - - -
30 changed files:
- compiler/basicTypes/UniqSupply.hs
- compiler/codeGen/StgCmmMonad.hs
- compiler/ghc.cabal.in
- compiler/ghci/ByteCodeLink.hs
- compiler/ghci/RtClosureInspect.hs
- compiler/iface/BinFingerprint.hs
- compiler/main/GhcMake.hs
- compiler/main/InteractiveEval.hs
- compiler/nativeGen/AsmCodeGen.hs
- compiler/nativeGen/RegAlloc/Linear/State.hs
- compiler/utils/Binary.hs
- compiler/utils/FastString.hs
- compiler/utils/Panic.hs
- + compiler/utils/PlainPanic.hs
- compiler/utils/Pretty.hs
- compiler/utils/StringBuffer.hs
- compiler/utils/Util.hs
- docs/users_guide/8.8.1-notes.rst
- docs/users_guide/ghci.rst
- ghc/GHCi/Leak.hs
- ghc/GHCi/UI/Monad.hs
- + ghc/GHCi/Util.hs
- ghc/ghc-bin.cabal.in
- includes/CodeGen.Platform.hs
- − testsuite/tests/ghci/prog014/prog014.stderr
- − testsuite/tests/ghci/should_fail/T14608.stderr
- testsuite/tests/ghci/should_fail/all.T
- testsuite/tests/ghci/should_fail/T14608.hs → testsuite/tests/ghci/should_run/T14608.hs
- testsuite/tests/ghci/should_fail/T14608.script → testsuite/tests/ghci/should_run/T14608.script
- testsuite/tests/ghci/should_run/all.T
Changes:
=====================================
compiler/basicTypes/UniqSupply.hs
=====================================
@@ -3,7 +3,12 @@
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-}
-{-# LANGUAGE CPP, UnboxedTuples #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE PatternSynonyms #-}
+
+#if !defined(GHC_LOADED_INTO_GHCI)
+{-# LANGUAGE UnboxedTuples #-}
+#endif
module UniqSupply (
-- * Main data type
@@ -32,7 +37,7 @@ module UniqSupply (
import GhcPrelude
import Unique
-import Panic (panic)
+import PlainPanic (panic)
import GHC.IO
@@ -131,22 +136,37 @@ splitUniqSupply4 us = (us1, us2, us3, us4)
************************************************************************
-}
+-- Avoids using unboxed tuples when loading into GHCi
+#if !defined(GHC_LOADED_INTO_GHCI)
+
+type UniqResult result = (# result, UniqSupply #)
+
+pattern UniqResult :: a -> b -> (# a, b #)
+pattern UniqResult x y = (# x, y #)
+{-# COMPLETE UniqResult #-}
+
+#else
+
+data UniqResult result = UniqResult !result {-# UNPACK #-} !UniqSupply
+
+#endif
+
-- | A monad which just gives the ability to obtain 'Unique's
-newtype UniqSM result = USM { unUSM :: UniqSupply -> (# result, UniqSupply #) }
+newtype UniqSM result = USM { unUSM :: UniqSupply -> UniqResult result }
instance Monad UniqSM where
(>>=) = thenUs
(>>) = (*>)
instance Functor UniqSM where
- fmap f (USM x) = USM (\us -> case x us of
- (# r, us' #) -> (# f r, us' #))
+ fmap f (USM x) = USM (\us0 -> case x us0 of
+ UniqResult r us1 -> UniqResult (f r) us1)
instance Applicative UniqSM where
pure = returnUs
- (USM f) <*> (USM x) = USM $ \us -> case f us of
- (# ff, us' #) -> case x us' of
- (# xx, us'' #) -> (# ff xx, us'' #)
+ (USM f) <*> (USM x) = USM $ \us0 -> case f us0 of
+ UniqResult ff us1 -> case x us1 of
+ UniqResult xx us2 -> UniqResult (ff xx) us2
(*>) = thenUs_
-- TODO: try to get rid of this instance
@@ -155,11 +175,11 @@ instance Fail.MonadFail UniqSM where
-- | Run the 'UniqSM' action, returning the final 'UniqSupply'
initUs :: UniqSupply -> UniqSM a -> (a, UniqSupply)
-initUs init_us m = case unUSM m init_us of { (# r, us #) -> (r,us) }
+initUs init_us m = case unUSM m init_us of { UniqResult r us -> (r, us) }
-- | Run the 'UniqSM' action, discarding the final 'UniqSupply'
initUs_ :: UniqSupply -> UniqSM a -> a
-initUs_ init_us m = case unUSM m init_us of { (# r, _ #) -> r }
+initUs_ init_us m = case unUSM m init_us of { UniqResult r _ -> r }
{-# INLINE thenUs #-}
{-# INLINE lazyThenUs #-}
@@ -169,29 +189,29 @@ initUs_ init_us m = case unUSM m init_us of { (# r, _ #) -> r }
-- @thenUs@ is where we split the @UniqSupply at .
liftUSM :: UniqSM a -> UniqSupply -> (a, UniqSupply)
-liftUSM (USM m) us = case m us of (# a, us' #) -> (a, us')
+liftUSM (USM m) us0 = case m us0 of UniqResult a us1 -> (a, us1)
instance MonadFix UniqSM where
- mfix m = USM (\us -> let (r,us') = liftUSM (m r) us in (# r,us' #))
+ mfix m = USM (\us0 -> let (r,us1) = liftUSM (m r) us0 in UniqResult r us1)
thenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b
thenUs (USM expr) cont
- = USM (\us -> case (expr us) of
- (# result, us' #) -> unUSM (cont result) us')
+ = USM (\us0 -> case (expr us0) of
+ UniqResult result us1 -> unUSM (cont result) us1)
lazyThenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b
lazyThenUs expr cont
- = USM (\us -> let (result, us') = liftUSM expr us in unUSM (cont result) us')
+ = USM (\us0 -> let (result, us1) = liftUSM expr us0 in unUSM (cont result) us1)
thenUs_ :: UniqSM a -> UniqSM b -> UniqSM b
thenUs_ (USM expr) (USM cont)
- = USM (\us -> case (expr us) of { (# _, us' #) -> cont us' })
+ = USM (\us0 -> case (expr us0) of { UniqResult _ us1 -> cont us1 })
returnUs :: a -> UniqSM a
-returnUs result = USM (\us -> (# result, us #))
+returnUs result = USM (\us -> UniqResult result us)
getUs :: UniqSM UniqSupply
-getUs = USM (\us -> case splitUniqSupply us of (us1,us2) -> (# us1, us2 #))
+getUs = USM (\us0 -> case splitUniqSupply us0 of (us1,us2) -> UniqResult us1 us2)
-- | A monad for generating unique identifiers
class Monad m => MonadUnique m where
@@ -221,12 +241,12 @@ liftUs :: MonadUnique m => UniqSM a -> m a
liftUs m = getUniqueSupplyM >>= return . flip initUs_ m
getUniqueUs :: UniqSM Unique
-getUniqueUs = USM (\us -> case takeUniqFromSupply us of
- (u,us') -> (# u, us' #))
+getUniqueUs = USM (\us0 -> case takeUniqFromSupply us0 of
+ (u,us1) -> UniqResult u us1)
getUniquesUs :: UniqSM [Unique]
-getUniquesUs = USM (\us -> case splitUniqSupply us of
- (us1,us2) -> (# uniqsFromSupply us1, us2 #))
+getUniquesUs = USM (\us0 -> case splitUniqSupply us0 of
+ (us1,us2) -> UniqResult (uniqsFromSupply us1) us2)
-- {-# SPECIALIZE mapM :: (a -> UniqSM b) -> [a] -> UniqSM [b] #-}
-- {-# SPECIALIZE mapAndUnzipM :: (a -> UniqSM (b,c)) -> [a] -> UniqSM ([b],[c]) #-}
=====================================
compiler/codeGen/StgCmmMonad.hs
=====================================
@@ -1,4 +1,4 @@
-{-# LANGUAGE GADTs, UnboxedTuples #-}
+{-# LANGUAGE GADTs #-}
-----------------------------------------------------------------------------
--
=====================================
compiler/ghc.cabal.in
=====================================
@@ -558,6 +558,7 @@ Library
Outputable
Pair
Panic
+ PlainPanic
PprColour
Pretty
State
=====================================
compiler/ghci/ByteCodeLink.hs
=====================================
@@ -3,7 +3,6 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE UnboxedTuples #-}
{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}
--
-- (c) The University of Glasgow 2002-2006
=====================================
compiler/ghci/RtClosureInspect.hs
=====================================
@@ -1,4 +1,4 @@
-{-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables, MagicHash, UnboxedTuples #-}
+{-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables, MagicHash #-}
-----------------------------------------------------------------------------
--
=====================================
compiler/iface/BinFingerprint.hs
=====================================
@@ -15,7 +15,7 @@ import GhcPrelude
import Fingerprint
import Binary
import Name
-import Panic
+import PlainPanic
import Util
fingerprintBinMem :: BinHandle -> IO Fingerprint
=====================================
compiler/main/GhcMake.hs
=====================================
@@ -1430,6 +1430,7 @@ upsweep_mod hsc_env mHscMessage old_hpt (stable_obj, stable_bco) summary mod_ind
&& (not (isObjectTarget prevailing_target)
|| not (isObjectTarget local_target))
&& not (prevailing_target == HscNothing)
+ && not (prevailing_target == HscInterpreted)
then prevailing_target
else local_target
@@ -1955,7 +1956,11 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
then enableCodeGenForTH
(defaultObjectTarget (targetPlatform dflags))
map0
- else return map0
+ else if hscTarget dflags == HscInterpreted
+ then enableCodeGenForUnboxedTuples
+ (defaultObjectTarget (targetPlatform dflags))
+ map0
+ else return map0
return $ concat $ nodeMapElts map1
where
calcDeps = msDeps
@@ -2034,7 +2039,50 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
enableCodeGenForTH :: HscTarget
-> NodeMap [Either ErrMsg ModSummary]
-> IO (NodeMap [Either ErrMsg ModSummary])
-enableCodeGenForTH target nodemap =
+enableCodeGenForTH =
+ enableCodeGenWhen condition should_modify TFL_CurrentModule TFL_GhcSession
+ where
+ condition = isTemplateHaskellOrQQNonBoot
+ should_modify (ModSummary { ms_hspp_opts = dflags }) =
+ hscTarget dflags == HscNothing &&
+ -- Don't enable codegen for TH on indefinite packages; we
+ -- can't compile anything anyway! See #16219.
+ not (isIndefinite dflags)
+
+-- | Update the every ModSummary that is depended on
+-- by a module that needs unboxed tuples. We enable codegen to
+-- the specified target, disable optimization and change the .hi
+-- and .o file locations to be temporary files.
+--
+-- This is used used in order to load code that uses unboxed tuples
+-- into GHCi while still allowing some code to be interpreted.
+enableCodeGenForUnboxedTuples :: HscTarget
+ -> NodeMap [Either ErrMsg ModSummary]
+ -> IO (NodeMap [Either ErrMsg ModSummary])
+enableCodeGenForUnboxedTuples =
+ enableCodeGenWhen condition should_modify TFL_GhcSession TFL_CurrentModule
+ where
+ condition ms =
+ xopt LangExt.UnboxedTuples (ms_hspp_opts ms) &&
+ not (isBootSummary ms)
+ should_modify (ModSummary { ms_hspp_opts = dflags }) =
+ hscTarget dflags == HscInterpreted
+
+-- | Helper used to implement 'enableCodeGenForTH' and
+-- 'enableCodeGenForUnboxedTuples'. In particular, this enables
+-- unoptimized code generation for all modules that meet some
+-- condition (first parameter), or are dependencies of those
+-- modules. The second parameter is a condition to check before
+-- marking modules for code generation.
+enableCodeGenWhen
+ :: (ModSummary -> Bool)
+ -> (ModSummary -> Bool)
+ -> TempFileLifetime
+ -> TempFileLifetime
+ -> HscTarget
+ -> NodeMap [Either ErrMsg ModSummary]
+ -> IO (NodeMap [Either ErrMsg ModSummary])
+enableCodeGenWhen condition should_modify staticLife dynLife target nodemap =
traverse (traverse (traverse enable_code_gen)) nodemap
where
enable_code_gen ms
@@ -2042,18 +2090,15 @@ enableCodeGenForTH target nodemap =
{ ms_mod = ms_mod
, ms_location = ms_location
, ms_hsc_src = HsSrcFile
- , ms_hspp_opts = dflags at DynFlags
- {hscTarget = HscNothing}
+ , ms_hspp_opts = dflags
} <- ms
- -- Don't enable codegen for TH on indefinite packages; we
- -- can't compile anything anyway! See #16219.
- , not (isIndefinite dflags)
+ , should_modify ms
, ms_mod `Set.member` needs_codegen_set
= do
let new_temp_file suf dynsuf = do
- tn <- newTempName dflags TFL_CurrentModule suf
+ tn <- newTempName dflags staticLife suf
let dyn_tn = tn -<.> dynsuf
- addFilesToClean dflags TFL_GhcSession [dyn_tn]
+ addFilesToClean dflags dynLife [dyn_tn]
return tn
-- We don't want to create .o or .hi files unless we have been asked
-- to by the user. But we need them, so we patch their locations in
@@ -2076,7 +2121,7 @@ enableCodeGenForTH target nodemap =
[ ms
| mss <- Map.elems nodemap
, Right ms <- mss
- , isTemplateHaskellOrQQNonBoot ms
+ , condition ms
]
-- find the set of all transitive dependencies of a list of modules.
=====================================
compiler/main/InteractiveEval.hs
=====================================
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, MagicHash, NondecreasingIndentation, UnboxedTuples,
+{-# LANGUAGE CPP, MagicHash, NondecreasingIndentation,
RecordWildCards, BangPatterns #-}
-- -----------------------------------------------------------------------------
=====================================
compiler/nativeGen/AsmCodeGen.hs
=====================================
@@ -6,7 +6,11 @@
--
-- -----------------------------------------------------------------------------
-{-# LANGUAGE BangPatterns, CPP, GADTs, ScopedTypeVariables, UnboxedTuples #-}
+{-# LANGUAGE BangPatterns, CPP, GADTs, ScopedTypeVariables, PatternSynonyms #-}
+
+#if !defined(GHC_LOADED_INTO_GHCI)
+{-# LANGUAGE UnboxedTuples #-}
+#endif
module AsmCodeGen (
-- * Module entry point
@@ -1062,36 +1066,50 @@ cmmToCmm dflags this_mod (CmmProc info lbl live graph)
do blocks' <- mapM cmmBlockConFold (toBlockList graph)
return $ CmmProc info lbl live (ofBlockList (g_entry graph) blocks')
-newtype CmmOptM a = CmmOptM (DynFlags -> Module -> [CLabel] -> (# a, [CLabel] #))
+-- Avoids using unboxed tuples when loading into GHCi
+#if !defined(GHC_LOADED_INTO_GHCI)
+
+type OptMResult a = (# a, [CLabel] #)
+
+pattern OptMResult :: a -> b -> (# a, b #)
+pattern OptMResult x y = (# x, y #)
+{-# COMPLETE OptMResult #-}
+#else
+
+data OptMResult a = OptMResult !a ![CLabel]
+#endif
+
+newtype CmmOptM a = CmmOptM (DynFlags -> Module -> [CLabel] -> OptMResult a)
instance Functor CmmOptM where
fmap = liftM
instance Applicative CmmOptM where
- pure x = CmmOptM $ \_ _ imports -> (# x, imports #)
+ pure x = CmmOptM $ \_ _ imports -> OptMResult x imports
(<*>) = ap
instance Monad CmmOptM where
(CmmOptM f) >>= g =
- CmmOptM $ \dflags this_mod imports ->
- case f dflags this_mod imports of
- (# x, imports' #) ->
+ CmmOptM $ \dflags this_mod imports0 ->
+ case f dflags this_mod imports0 of
+ OptMResult x imports1 ->
case g x of
- CmmOptM g' -> g' dflags this_mod imports'
+ CmmOptM g' -> g' dflags this_mod imports1
instance CmmMakeDynamicReferenceM CmmOptM where
addImport = addImportCmmOpt
- getThisModule = CmmOptM $ \_ this_mod imports -> (# this_mod, imports #)
+ getThisModule = CmmOptM $ \_ this_mod imports -> OptMResult this_mod imports
addImportCmmOpt :: CLabel -> CmmOptM ()
-addImportCmmOpt lbl = CmmOptM $ \_ _ imports -> (# (), lbl:imports #)
+addImportCmmOpt lbl = CmmOptM $ \_ _ imports -> OptMResult () (lbl:imports)
instance HasDynFlags CmmOptM where
- getDynFlags = CmmOptM $ \dflags _ imports -> (# dflags, imports #)
+ getDynFlags = CmmOptM $ \dflags _ imports -> OptMResult dflags imports
runCmmOpt :: DynFlags -> Module -> CmmOptM a -> (a, [CLabel])
-runCmmOpt dflags this_mod (CmmOptM f) = case f dflags this_mod [] of
- (# result, imports #) -> (result, imports)
+runCmmOpt dflags this_mod (CmmOptM f) =
+ case f dflags this_mod [] of
+ OptMResult result imports -> (result, imports)
cmmBlockConFold :: CmmBlock -> CmmOptM CmmBlock
cmmBlockConFold block = do
=====================================
compiler/nativeGen/RegAlloc/Linear/State.hs
=====================================
@@ -1,4 +1,8 @@
+{-# LANGUAGE CPP, PatternSynonyms #-}
+
+#if !defined(GHC_LOADED_INTO_GHCI)
{-# LANGUAGE UnboxedTuples #-}
+#endif
-- | State monad for the linear register allocator.
@@ -48,22 +52,36 @@ import UniqSupply
import Control.Monad (liftM, ap)
+-- Avoids using unboxed tuples when loading into GHCi
+#if !defined(GHC_LOADED_INTO_GHCI)
+
+type RA_Result freeRegs a = (# RA_State freeRegs, a #)
+
+pattern RA_Result :: a -> b -> (# a, b #)
+pattern RA_Result a b = (# a, b #)
+{-# COMPLETE RA_Result #-}
+#else
+
+data RA_Result freeRegs a = RA_Result {-# UNPACK #-} !(RA_State freeRegs) !a
+
+#endif
+
-- | The register allocator monad type.
newtype RegM freeRegs a
- = RegM { unReg :: RA_State freeRegs -> (# RA_State freeRegs, a #) }
+ = RegM { unReg :: RA_State freeRegs -> RA_Result freeRegs a }
instance Functor (RegM freeRegs) where
fmap = liftM
instance Applicative (RegM freeRegs) where
- pure a = RegM $ \s -> (# s, a #)
+ pure a = RegM $ \s -> RA_Result s a
(<*>) = ap
instance Monad (RegM freeRegs) where
- m >>= k = RegM $ \s -> case unReg m s of { (# s, a #) -> unReg (k a) s }
+ m >>= k = RegM $ \s -> case unReg m s of { RA_Result s a -> unReg (k a) s }
instance HasDynFlags (RegM a) where
- getDynFlags = RegM $ \s -> (# s, ra_DynFlags s #)
+ getDynFlags = RegM $ \s -> RA_Result s (ra_DynFlags s)
-- | Run a computation in the RegM register allocator monad.
@@ -89,12 +107,8 @@ runR dflags block_assig freeregs assig stack us thing =
, ra_DynFlags = dflags
, ra_fixups = [] })
of
- (# state'@RA_State
- { ra_blockassig = block_assig
- , ra_stack = stack' }
- , returned_thing #)
-
- -> (block_assig, stack', makeRAStats state', returned_thing)
+ RA_Result state returned_thing
+ -> (ra_blockassig state, ra_stack state, makeRAStats state, returned_thing)
-- | Make register allocator stats from its final state.
@@ -108,12 +122,12 @@ makeRAStats state
spillR :: Instruction instr
=> Reg -> Unique -> RegM freeRegs (instr, Int)
-spillR reg temp = RegM $ \ s at RA_State{ra_delta=delta, ra_stack=stack} ->
+spillR reg temp = RegM $ \ s at RA_State{ra_delta=delta, ra_stack=stack0} ->
let dflags = ra_DynFlags s
- (stack',slot) = getStackSlotFor stack temp
+ (stack1,slot) = getStackSlotFor stack0 temp
instr = mkSpillInstr dflags reg delta slot
in
- (# s{ra_stack=stack'}, (instr,slot) #)
+ RA_Result s{ra_stack=stack1} (instr,slot)
loadR :: Instruction instr
@@ -121,51 +135,51 @@ loadR :: Instruction instr
loadR reg slot = RegM $ \ s at RA_State{ra_delta=delta} ->
let dflags = ra_DynFlags s
- in (# s, mkLoadInstr dflags reg delta slot #)
+ in RA_Result s (mkLoadInstr dflags reg delta slot)
getFreeRegsR :: RegM freeRegs freeRegs
getFreeRegsR = RegM $ \ s at RA_State{ra_freeregs = freeregs} ->
- (# s, freeregs #)
+ RA_Result s freeregs
setFreeRegsR :: freeRegs -> RegM freeRegs ()
setFreeRegsR regs = RegM $ \ s ->
- (# s{ra_freeregs = regs}, () #)
+ RA_Result s{ra_freeregs = regs} ()
getAssigR :: RegM freeRegs (RegMap Loc)
getAssigR = RegM $ \ s at RA_State{ra_assig = assig} ->
- (# s, assig #)
+ RA_Result s assig
setAssigR :: RegMap Loc -> RegM freeRegs ()
setAssigR assig = RegM $ \ s ->
- (# s{ra_assig=assig}, () #)
+ RA_Result s{ra_assig=assig} ()
getBlockAssigR :: RegM freeRegs (BlockAssignment freeRegs)
getBlockAssigR = RegM $ \ s at RA_State{ra_blockassig = assig} ->
- (# s, assig #)
+ RA_Result s assig
setBlockAssigR :: BlockAssignment freeRegs -> RegM freeRegs ()
setBlockAssigR assig = RegM $ \ s ->
- (# s{ra_blockassig = assig}, () #)
+ RA_Result s{ra_blockassig = assig} ()
setDeltaR :: Int -> RegM freeRegs ()
setDeltaR n = RegM $ \ s ->
- (# s{ra_delta = n}, () #)
+ RA_Result s{ra_delta = n} ()
getDeltaR :: RegM freeRegs Int
-getDeltaR = RegM $ \s -> (# s, ra_delta s #)
+getDeltaR = RegM $ \s -> RA_Result s (ra_delta s)
getUniqueR :: RegM freeRegs Unique
getUniqueR = RegM $ \s ->
case takeUniqFromSupply (ra_us s) of
- (uniq, us) -> (# s{ra_us = us}, uniq #)
+ (uniq, us) -> RA_Result s{ra_us = us} uniq
-- | Record that a spill instruction was inserted, for profiling.
recordSpill :: SpillReason -> RegM freeRegs ()
recordSpill spill
- = RegM $ \s -> (# s { ra_spills = spill : ra_spills s}, () #)
+ = RegM $ \s -> RA_Result (s { ra_spills = spill : ra_spills s }) ()
-- | Record a created fixup block
recordFixupBlock :: BlockId -> BlockId -> BlockId -> RegM freeRegs ()
recordFixupBlock from between to
- = RegM $ \s -> (# s { ra_fixups = (from,between,to) : ra_fixups s}, () #)
+ = RegM $ \s -> RA_Result (s { ra_fixups = (from,between,to) : ra_fixups s }) ()
=====================================
compiler/utils/Binary.hs
=====================================
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
@@ -64,7 +64,7 @@ import GhcPrelude
import {-# SOURCE #-} Name (Name)
import FastString
-import Panic
+import PlainPanic
import UniqFM
import FastMutInt
import Fingerprint
=====================================
compiler/utils/FastString.hs
=====================================
@@ -101,7 +101,7 @@ import GhcPrelude as Prelude
import Encoding
import FastFunctions
-import Panic
+import PlainPanic
import Util
import Control.Concurrent.MVar
=====================================
compiler/utils/Panic.hs
=====================================
@@ -14,7 +14,7 @@ module Panic (
GhcException(..), showGhcException,
throwGhcException, throwGhcExceptionIO,
handleGhcException,
- progName,
+ PlainPanic.progName,
pgmError,
panic, sorry, assertPanic, trace,
@@ -27,20 +27,19 @@ module Panic (
withSignalHandlers,
) where
-#include "HsVersions.h"
import GhcPrelude
import {-# SOURCE #-} Outputable (SDoc, showSDocUnsafe)
+import PlainPanic
-import Config
import Exception
import Control.Monad.IO.Class
import Control.Concurrent
+import Data.Typeable ( cast )
import Debug.Trace ( trace )
import System.IO.Unsafe
-import System.Environment
#if !defined(mingw32_HOST_OS)
import System.Posix.Signals as S
@@ -50,7 +49,6 @@ import System.Posix.Signals as S
import GHC.ConsoleHandler as S
#endif
-import GHC.Stack
import System.Mem.Weak ( deRefWeak )
-- | GHC's own exception type
@@ -91,25 +89,25 @@ data GhcException
| ProgramError String
| PprProgramError String SDoc
-instance Exception GhcException
+instance Exception GhcException where
+ fromException (SomeException e)
+ | Just ge <- cast e = Just ge
+ | Just pge <- cast e = Just $
+ case pge of
+ PlainSignal n -> Signal n
+ PlainUsageError str -> UsageError str
+ PlainCmdLineError str -> CmdLineError str
+ PlainPanic str -> Panic str
+ PlainSorry str -> Sorry str
+ PlainInstallationError str -> InstallationError str
+ PlainProgramError str -> ProgramError str
+ | otherwise = Nothing
instance Show GhcException where
showsPrec _ e@(ProgramError _) = showGhcException e
showsPrec _ e@(CmdLineError _) = showString "<command line>: " . showGhcException e
showsPrec _ e = showString progName . showString ": " . showGhcException e
-
--- | The name of this GHC.
-progName :: String
-progName = unsafePerformIO (getProgName)
-{-# NOINLINE progName #-}
-
-
--- | Short usage information to display when we are given the wrong cmd line arguments.
-short_usage :: String
-short_usage = "Usage: For basic information, try the `--help' option."
-
-
-- | Show an exception as a string.
showException :: Exception e => e -> String
showException = show
@@ -134,42 +132,21 @@ safeShowException e = do
-- If the error message to be printed includes a pretty-printer document
-- which forces one of these fields this call may bottom.
showGhcException :: GhcException -> ShowS
-showGhcException exception
- = case exception of
- UsageError str
- -> showString str . showChar '\n' . showString short_usage
-
- CmdLineError str -> showString str
- PprProgramError str sdoc ->
- showString str . showString "\n\n" .
- showString (showSDocUnsafe sdoc)
- ProgramError str -> showString str
- InstallationError str -> showString str
- Signal n -> showString "signal: " . shows n
-
- PprPanic s sdoc ->
- panicMsg $ showString s . showString "\n\n"
- . showString (showSDocUnsafe sdoc)
- Panic s -> panicMsg (showString s)
-
- PprSorry s sdoc ->
- sorryMsg $ showString s . showString "\n\n"
- . showString (showSDocUnsafe sdoc)
- Sorry s -> sorryMsg (showString s)
- where
- sorryMsg :: ShowS -> ShowS
- sorryMsg s =
- showString "sorry! (unimplemented feature or known bug)\n"
- . showString (" (GHC version " ++ cProjectVersion ++ " for " ++ TargetPlatform_NAME ++ "):\n\t")
- . s . showString "\n"
-
- panicMsg :: ShowS -> ShowS
- panicMsg s =
- showString "panic! (the 'impossible' happened)\n"
- . showString (" (GHC version " ++ cProjectVersion ++ " for " ++ TargetPlatform_NAME ++ "):\n\t")
- . s . showString "\n\n"
- . showString "Please report this as a GHC bug: https://www.haskell.org/ghc/reportabug\n"
-
+showGhcException = showPlainGhcException . \case
+ Signal n -> PlainSignal n
+ UsageError str -> PlainUsageError str
+ CmdLineError str -> PlainCmdLineError str
+ Panic str -> PlainPanic str
+ Sorry str -> PlainSorry str
+ InstallationError str -> PlainInstallationError str
+ ProgramError str -> PlainProgramError str
+
+ PprPanic str sdoc -> PlainPanic $
+ concat [str, "\n\n", showSDocUnsafe sdoc]
+ PprSorry str sdoc -> PlainProgramError $
+ concat [str, "\n\n", showSDocUnsafe sdoc]
+ PprProgramError str sdoc -> PlainProgramError $
+ concat [str, "\n\n", showSDocUnsafe sdoc]
throwGhcException :: GhcException -> a
throwGhcException = Exception.throw
@@ -180,42 +157,11 @@ throwGhcExceptionIO = Exception.throwIO
handleGhcException :: ExceptionMonad m => (GhcException -> m a) -> m a -> m a
handleGhcException = ghandle
-
--- | Panics and asserts.
-panic, sorry, pgmError :: String -> a
-panic x = unsafeDupablePerformIO $ do
- stack <- ccsToStrings =<< getCurrentCCS x
- if null stack
- then throwGhcException (Panic x)
- else throwGhcException (Panic (x ++ '\n' : renderStack stack))
-
-sorry x = throwGhcException (Sorry x)
-pgmError x = throwGhcException (ProgramError x)
-
panicDoc, sorryDoc, pgmErrorDoc :: String -> SDoc -> a
panicDoc x doc = throwGhcException (PprPanic x doc)
sorryDoc x doc = throwGhcException (PprSorry x doc)
pgmErrorDoc x doc = throwGhcException (PprProgramError x doc)
-cmdLineError :: String -> a
-cmdLineError = unsafeDupablePerformIO . cmdLineErrorIO
-
-cmdLineErrorIO :: String -> IO a
-cmdLineErrorIO x = do
- stack <- ccsToStrings =<< getCurrentCCS x
- if null stack
- then throwGhcException (CmdLineError x)
- else throwGhcException (CmdLineError (x ++ '\n' : renderStack stack))
-
-
-
--- | Throw a failed assertion exception for a given filename and line number.
-assertPanic :: String -> Int -> a
-assertPanic file line =
- Exception.throw (Exception.AssertionFailed
- ("ASSERT failed! file " ++ file ++ ", line " ++ show line))
-
-
-- | Like try, but pass through UserInterrupt and Panic exceptions.
-- Used when we want soft failures when reading interface files, for example.
-- TODO: I'm not entirely sure if this is catching what we really want to catch
=====================================
compiler/utils/PlainPanic.hs
=====================================
@@ -0,0 +1,139 @@
+{-# LANGUAGE CPP, ScopedTypeVariables, LambdaCase #-}
+
+-- | Defines a simple exception type and utilities to throw it. The
+-- 'PlainGhcException' type is a subset of the 'Panic.GhcException'
+-- type. It omits the exception constructors that involve
+-- pretty-printing via 'Outputable.SDoc'.
+--
+-- There are two reasons for this:
+--
+-- 1. To avoid import cycles / use of boot files. "Outputable" has
+-- many transitive dependencies. To throw exceptions from these
+-- modules, the functions here can be used without introducing import
+-- cycles.
+--
+-- 2. To reduce the number of modules that need to be compiled to
+-- object code when loading GHC into GHCi. See #13101
+module PlainPanic
+ ( PlainGhcException(..)
+ , showPlainGhcException
+
+ , panic, sorry, pgmError
+ , cmdLineError, cmdLineErrorIO
+ , assertPanic
+
+ , progName
+ ) where
+
+#include "HsVersions.h"
+
+import Config
+import Exception
+import GHC.Stack
+import GhcPrelude
+import System.Environment
+import System.IO.Unsafe
+
+-- | This type is very similar to 'Panic.GhcException', but it omits
+-- the constructors that involve pretty-printing via
+-- 'Outputable.SDoc'. Due to the implementation of 'fromException'
+-- for 'Panic.GhcException', this type can be caught as a
+-- 'Panic.GhcException'.
+--
+-- Note that this should only be used for throwing exceptions, not for
+-- catching, as 'Panic.GhcException' will not be converted to this
+-- type when catching.
+data PlainGhcException
+ -- | Some other fatal signal (SIGHUP,SIGTERM)
+ = PlainSignal Int
+
+ -- | Prints the short usage msg after the error
+ | PlainUsageError String
+
+ -- | A problem with the command line arguments, but don't print usage.
+ | PlainCmdLineError String
+
+ -- | The 'impossible' happened.
+ | PlainPanic String
+
+ -- | The user tickled something that's known not to work yet,
+ -- but we're not counting it as a bug.
+ | PlainSorry String
+
+ -- | An installation problem.
+ | PlainInstallationError String
+
+ -- | An error in the user's code, probably.
+ | PlainProgramError String
+
+instance Exception PlainGhcException
+
+instance Show PlainGhcException where
+ showsPrec _ e@(PlainProgramError _) = showPlainGhcException e
+ showsPrec _ e@(PlainCmdLineError _) = showString "<command line>: " . showPlainGhcException e
+ showsPrec _ e = showString progName . showString ": " . showPlainGhcException e
+
+-- | The name of this GHC.
+progName :: String
+progName = unsafePerformIO (getProgName)
+{-# NOINLINE progName #-}
+
+-- | Short usage information to display when we are given the wrong cmd line arguments.
+short_usage :: String
+short_usage = "Usage: For basic information, try the `--help' option."
+
+-- | Append a description of the given exception to this string.
+showPlainGhcException :: PlainGhcException -> ShowS
+showPlainGhcException =
+ \case
+ PlainSignal n -> showString "signal: " . shows n
+ PlainUsageError str -> showString str . showChar '\n' . showString short_usage
+ PlainCmdLineError str -> showString str
+ PlainPanic s -> panicMsg (showString s)
+ PlainSorry s -> sorryMsg (showString s)
+ PlainInstallationError str -> showString str
+ PlainProgramError str -> showString str
+
+ where
+ sorryMsg :: ShowS -> ShowS
+ sorryMsg s =
+ showString "sorry! (unimplemented feature or known bug)\n"
+ . showString (" (GHC version " ++ cProjectVersion ++ " for " ++ TargetPlatform_NAME ++ "):\n\t")
+ . s . showString "\n"
+
+ panicMsg :: ShowS -> ShowS
+ panicMsg s =
+ showString "panic! (the 'impossible' happened)\n"
+ . showString (" (GHC version " ++ cProjectVersion ++ " for " ++ TargetPlatform_NAME ++ "):\n\t")
+ . s . showString "\n\n"
+ . showString "Please report this as a GHC bug: https://www.haskell.org/ghc/reportabug\n"
+
+throwPlainGhcException :: PlainGhcException -> a
+throwPlainGhcException = Exception.throw
+
+-- | Panics and asserts.
+panic, sorry, pgmError :: String -> a
+panic x = unsafeDupablePerformIO $ do
+ stack <- ccsToStrings =<< getCurrentCCS x
+ if null stack
+ then throwPlainGhcException (PlainPanic x)
+ else throwPlainGhcException (PlainPanic (x ++ '\n' : renderStack stack))
+
+sorry x = throwPlainGhcException (PlainSorry x)
+pgmError x = throwPlainGhcException (PlainProgramError x)
+
+cmdLineError :: String -> a
+cmdLineError = unsafeDupablePerformIO . cmdLineErrorIO
+
+cmdLineErrorIO :: String -> IO a
+cmdLineErrorIO x = do
+ stack <- ccsToStrings =<< getCurrentCCS x
+ if null stack
+ then throwPlainGhcException (PlainCmdLineError x)
+ else throwPlainGhcException (PlainCmdLineError (x ++ '\n' : renderStack stack))
+
+-- | Throw a failed assertion exception for a given filename and line number.
+assertPanic :: String -> Int -> a
+assertPanic file line =
+ Exception.throw (Exception.AssertionFailed
+ ("ASSERT failed! file " ++ file ++ ", line " ++ show line))
=====================================
compiler/utils/Pretty.hs
=====================================
@@ -115,7 +115,7 @@ import GhcPrelude hiding (error)
import BufWrite
import FastString
-import Panic
+import PlainPanic
import System.IO
import Numeric (showHex)
@@ -123,9 +123,6 @@ import Numeric (showHex)
import GHC.Base ( unpackCString#, unpackNBytes#, Int(..) )
import GHC.Ptr ( Ptr(..) )
--- Don't import Util( assertPanic ) because it makes a loop in the module structure
-
-
-- ---------------------------------------------------------------------------
-- The Doc calculus
=====================================
compiler/utils/StringBuffer.hs
=====================================
@@ -50,7 +50,7 @@ import GhcPrelude
import Encoding
import FastString
import FastFunctions
-import Outputable
+import PlainPanic
import Util
import Data.Maybe
=====================================
compiler/utils/Util.hs
=====================================
@@ -133,7 +133,7 @@ module Util (
import GhcPrelude
import Exception
-import Panic
+import PlainPanic
import Data.Data
import Data.IORef ( IORef, newIORef, atomicModifyIORef' )
=====================================
docs/users_guide/8.8.1-notes.rst
=====================================
@@ -92,6 +92,13 @@ Compiler
taking advantage of :extension:`DerivingStrategies`. The warning is supplied at each
``deriving`` site.
+- When loading modules that use :extension:`UnboxedTuples` into GHCi,
+ it will now automatically enable `-fobject-code` for these modules
+ and all modules they depend on. Before this change, attempting to
+ load these modules into the interpreter would just fail, and the
+ only convenient workaround was to enable `-fobject-code` for all
+ modules.
+
Runtime system
~~~~~~~~~~~~~~
=====================================
docs/users_guide/ghci.rst
=====================================
@@ -3308,11 +3308,14 @@ The interpreter can't load modules with foreign export declarations!
need to go fast, rather than interpreting them with optimisation
turned on.
-Unboxed tuples don't work with GHCi
- That's right. You can always compile a module that uses unboxed
- tuples and load it into GHCi, however. (Incidentally the previous
- point, namely that :ghc-flag:`-O` is incompatible with GHCi, is because the
- bytecode compiler can't deal with unboxed tuples).
+Modules using unboxed tuples will automatically enable `-fobject-code`
+ The interpreter doesn't support unboxed tuples, so GHCi will
+ automatically compile these modules, and all modules they depend
+ on, to object code instead of bytecode.
+
+ Incidentally, the previous point, that :ghc-flag:`-O` is
+ incompatible with GHCi, is because the bytecode compiler can't
+ deal with unboxed tuples.
Concurrent threads don't carry on running when GHCi is waiting for input.
This should work, as long as your GHCi was built with the
=====================================
ghc/GHCi/Leak.hs
=====================================
@@ -1,4 +1,4 @@
-{-# LANGUAGE RecordWildCards, LambdaCase, MagicHash, UnboxedTuples #-}
+{-# LANGUAGE RecordWildCards, LambdaCase #-}
module GHCi.Leak
( LeakIndicators
, getLeakIndicators
@@ -10,9 +10,8 @@ import Data.Bits
import DynFlags ( sTargetPlatform )
import Foreign.Ptr (ptrToIntPtr, intPtrToPtr)
import GHC
-import GHC.Exts (anyToAddr#)
import GHC.Ptr (Ptr (..))
-import GHC.Types (IO (..))
+import GHCi.Util
import HscTypes
import Outputable
import Platform (target32Bit)
@@ -64,8 +63,7 @@ checkLeakIndicators dflags (LeakIndicators leakmods) = do
report :: String -> Maybe a -> IO ()
report _ Nothing = return ()
report msg (Just a) = do
- addr <- IO (\s -> case anyToAddr# a s of
- (# s', addr #) -> (# s', Ptr addr #)) :: IO (Ptr ())
+ addr <- anyToPtr a
putStrLn ("-fghci-leak-check: " ++ msg ++ " is still alive at " ++
show (maskTagBits addr))
=====================================
ghc/GHCi/UI/Monad.hs
=====================================
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, FlexibleInstances, UnboxedTuples, MagicHash #-}
+{-# LANGUAGE CPP, FlexibleInstances #-}
{-# OPTIONS_GHC -fno-cse -fno-warn-orphans #-}
-- -fno-cse is needed for GLOBAL_VAR's to behave properly
=====================================
ghc/GHCi/Util.hs
=====================================
@@ -0,0 +1,16 @@
+{-# LANGUAGE MagicHash, UnboxedTuples #-}
+
+-- | Utilities for GHCi.
+module GHCi.Util where
+
+-- NOTE: Avoid importing GHC modules here, because the primary purpose
+-- of this module is to not use UnboxedTuples in a module that imports
+-- lots of other modules. See issue#13101 for more info.
+
+import GHC.Exts
+import GHC.Types
+
+anyToPtr :: a -> IO (Ptr ())
+anyToPtr x =
+ IO (\s -> case anyToAddr# x s of
+ (# s', addr #) -> (# s', Ptr addr #)) :: IO (Ptr ())
=====================================
ghc/ghc-bin.cabal.in
=====================================
@@ -71,6 +71,7 @@ Executable ghc
GHCi.UI.Info
GHCi.UI.Monad
GHCi.UI.Tags
+ GHCi.Util
Other-Extensions:
BangPatterns
FlexibleInstances
=====================================
includes/CodeGen.Platform.hs
=====================================
@@ -2,7 +2,7 @@
import CmmExpr
#if !(defined(MACHREGS_i386) || defined(MACHREGS_x86_64) \
|| defined(MACHREGS_sparc) || defined(MACHREGS_powerpc))
-import Panic
+import PlainPanic
#endif
import Reg
=====================================
testsuite/tests/ghci/prog014/prog014.stderr deleted
=====================================
@@ -1,2 +0,0 @@
-Error: bytecode compiler can't handle some foreign calling conventions
- Workaround: use -fobject-code, or compile this module to .o separately.
=====================================
testsuite/tests/ghci/should_fail/T14608.stderr deleted
=====================================
@@ -1,3 +0,0 @@
-Error: bytecode compiler can't handle unboxed tuples and sums.
- Possibly due to foreign import/export decls in source.
- Workaround: use -fobject-code, or compile this module to .o separately.
=====================================
testsuite/tests/ghci/should_fail/all.T
=====================================
@@ -1,6 +1,5 @@
test('T10549', [], ghci_script, ['T10549.script'])
test('T10549a', [], ghci_script, ['T10549a.script'])
-test('T14608', [], ghci_script, ['T14608.script'])
test('T15055', normalise_version('ghc'), ghci_script, ['T15055.script'])
test('T16013', [], ghci_script, ['T16013.script'])
test('T16287', [], ghci_script, ['T16287.script'])
=====================================
testsuite/tests/ghci/should_fail/T14608.hs → testsuite/tests/ghci/should_run/T14608.hs
=====================================
=====================================
testsuite/tests/ghci/should_fail/T14608.script → testsuite/tests/ghci/should_run/T14608.script
=====================================
=====================================
testsuite/tests/ghci/should_run/all.T
=====================================
@@ -36,6 +36,7 @@ test('T12549', just_ghci, ghci_script, ['T12549.script'])
test('BinaryArray', normal, compile_and_run, [''])
test('T14125a', just_ghci, ghci_script, ['T14125a.script'])
test('T13825-ghci',just_ghci, ghci_script, ['T13825-ghci.script'])
+test('T14608', just_ghci, ghci_script, ['T14608.script'])
test('T14963a', just_ghci, ghci_script, ['T14963a.script'])
test('T14963b', just_ghci, ghci_script, ['T14963b.script'])
test('T14963c', [extra_hc_opts("-fdefer-type-errors")], ghci_script, ['T14963c.script'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/compare/0c14558f794f068b26a13dade17fb188e5da39b7...aa3346be462d6ac5979d07f8cb8ea3c8a79f0e5c
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/compare/0c14558f794f068b26a13dade17fb188e5da39b7...aa3346be462d6ac5979d07f8cb8ea3c8a79f0e5c
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/20190521/657f2526/attachment-0001.html>
More information about the ghc-commits
mailing list