Use datatype for unboxed returns when loading ghc into ghci

See #13101 and #15454

3 files changed, 110 insertions, 58 deletions

diff --git a/compiler/basicTypes/UniqSupply.hs b/compiler/basicTypes/UniqSupply.hs
index 9620ed4b01..8780a52208 100644
--- a/compiler/basicTypes/UniqSupply.hs
+++ b/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@.
 
 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]) #-}
diff --git a/compiler/nativeGen/AsmCodeGen.hs b/compiler/nativeGen/AsmCodeGen.hs
index 2d0bf30b5e..cc608b1ec6 100644
--- a/compiler/nativeGen/AsmCodeGen.hs
+++ b/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
diff --git a/compiler/nativeGen/RegAlloc/Linear/State.hs b/compiler/nativeGen/RegAlloc/Linear/State.hs
index 34637b04c8..8df4dd04f0 100644
--- a/compiler/nativeGen/RegAlloc/Linear/State.hs
+++ b/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@RA_State{ra_delta=delta, ra_stack=stack} ->
+spillR reg temp = RegM $ \ s@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@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@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@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@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 }) ()