[Git][ghc/ghc][master] Use datatype for unboxed returns when loading ghc into ghci
Marge Bot
gitlab at gitlab.haskell.org
Wed May 22 20:45:06 UTC 2019
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
ddae344e by Michael Sloan at 2019-05-22T20:41:31Z
Use datatype for unboxed returns when loading ghc into ghci
See #13101 and #15454
- - - - -
3 changed files:
- compiler/basicTypes/UniqSupply.hs
- compiler/nativeGen/AsmCodeGen.hs
- compiler/nativeGen/RegAlloc/Linear/State.hs
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
@@ -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/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
@@ -1024,36 +1028,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 }) ()
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/commit/ddae344e80eee3044f773061126937a69d16c957
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/commit/ddae344e80eee3044f773061126937a69d16c957
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/20190522/4cac26df/attachment-0001.html>
More information about the ghc-commits
mailing list