Work around LLVM backend overlapping register limitations

The stg_ctoi_t and stg_ret_t procedures which convert unboxed
tuples between the bytecode an native calling convention were
causing a panic when using the LLVM backend.

Fixes #19591

1 files changed, 59 insertions, 0 deletions

diff --git a/compiler/GHC/StgToCmm/Foreign.hs b/compiler/GHC/StgToCmm/Foreign.hs
index 95fa21d648..39f25a7b86 100644
--- a/compiler/GHC/StgToCmm/Foreign.hs
+++ b/compiler/GHC/StgToCmm/Foreign.hs
@@ -15,6 +15,8 @@ module GHC.StgToCmm.Foreign (
   emitLoadThreadState,
   emitSaveRegs,
   emitRestoreRegs,
+  emitPushTupleRegs,
+  emitPopTupleRegs,
   loadThreadState,
   emitOpenNursery,
   emitCloseNursery,
@@ -340,6 +342,63 @@ emitRestoreRegs = do
        restore = catAGraphs (map (callerRestoreGlobalReg platform) regs)
    emit restore
 
+-- | Push a subset of STG registers onto the stack, specified by the bitmap
+--
+-- Sometimes, a "live" subset of the STG registers needs to be saved on the
+-- stack, for example when storing an unboxed tuple to be used in the GHCi
+-- bytecode interpreter.
+--
+-- The "live registers" bitmap corresponds to the list of registers given by
+-- 'tupleRegsCover', with the least significant bit indicating liveness of
+-- the first register in the list.
+--
+-- Each register is saved to a stack slot of one or more machine words, even
+-- if the register size itself is smaller.
+--
+-- The resulting Cmm code looks like this, with a line for each real or
+-- virtual register used for returning tuples:
+--
+--    ...
+--    if((mask & 2) != 0) { Sp_adj(-1); Sp(0) = R2; }
+--    if((mask & 1) != 0) { Sp_adj(-1); Sp(0) = R1; }
+--
+-- See Note [GHCi tuple layout]
+
+emitPushTupleRegs :: CmmExpr -> FCode ()
+emitPushTupleRegs regs_live = do
+  platform <- getPlatform
+  let regs = zip (tupleRegsCover platform) [0..]
+      save_arg (reg, n) =
+        let mask     = CmmLit (CmmInt (1 `shiftL` n) (wordWidth platform))
+            live     = cmmAndWord platform regs_live mask
+            cond     = cmmNeWord platform live (zeroExpr platform)
+            reg_ty   = cmmRegType platform (CmmGlobal reg)
+            width    = roundUpToWords platform
+                                      (widthInBytes $ typeWidth reg_ty)
+            adj_sp   = mkAssign spReg
+                                (cmmOffset platform spExpr (negate width))
+            save_reg = mkStore spExpr (CmmReg $ CmmGlobal reg)
+        in mkCmmIfThen cond $ catAGraphs [adj_sp, save_reg]
+  emit . catAGraphs =<< mapM save_arg (reverse regs)
+
+-- | Pop a subset of STG registers from the stack (see 'emitPushTupleRegs')
+emitPopTupleRegs :: CmmExpr -> FCode ()
+emitPopTupleRegs regs_live = do
+  platform <- getPlatform
+  let regs = zip (tupleRegsCover platform) [0..]
+      save_arg (reg, n) =
+        let mask     = CmmLit (CmmInt (1 `shiftL` n) (wordWidth platform))
+            live     = cmmAndWord platform regs_live mask
+            cond     = cmmNeWord platform live (zeroExpr platform)
+            reg_ty   = cmmRegType platform (CmmGlobal reg)
+            width    = roundUpToWords platform
+                                      (widthInBytes $ typeWidth reg_ty)
+            adj_sp   = mkAssign spReg
+                                (cmmOffset platform spExpr width)
+            restore_reg = mkAssign (CmmGlobal reg) (CmmLoad spExpr reg_ty)
+        in mkCmmIfThen cond $ catAGraphs [restore_reg, adj_sp]
+  emit . catAGraphs =<< mapM save_arg regs
+
 
 emitCloseNursery :: FCode ()
 emitCloseNursery = do