From 61222af1a92d896b31ed8e3c44746b9b98082615 Mon Sep 17 00:00:00 2001
From: Ben Gamari <ben@smart-cactus.org>
Date: Tue, 13 Oct 2020 19:20:28 -0400
Subject: compiler/ByteCode: Allow 2^32 local labels

This widens LocalLabel to 2^16, avoiding the crash observed in #14334.

Closes #14334.
---
 compiler/GHC/ByteCode/Asm.hs   | 4 +++-
 compiler/GHC/ByteCode/Instr.hs | 3 ++-
 compiler/GHC/CoreToByteCode.hs | 4 ++--
 3 files changed, 7 insertions(+), 4 deletions(-)

diff --git a/compiler/GHC/ByteCode/Asm.hs b/compiler/GHC/ByteCode/Asm.hs
index dd28b0076c..b6460f6925 100644
--- a/compiler/GHC/ByteCode/Asm.hs
+++ b/compiler/GHC/ByteCode/Asm.hs
@@ -177,7 +177,9 @@ assembleBCO platform (ProtoBCO { protoBCOName       = nm
       -- this BCO to be long.
       (n_insns0, lbl_map0) = inspectAsm platform False initial_offset asm
       ((n_insns, lbl_map), long_jumps)
-        | isLarge n_insns0 = (inspectAsm platform True initial_offset asm, True)
+        | isLarge (fromIntegral $ Map.size lbl_map0)
+          || isLarge n_insns0
+                    = (inspectAsm platform True initial_offset asm, True)
         | otherwise = ((n_insns0, lbl_map0), False)
 
       env :: LocalLabel -> Word
diff --git a/compiler/GHC/ByteCode/Instr.hs b/compiler/GHC/ByteCode/Instr.hs
index 4186c81045..89b59bfb4b 100644
--- a/compiler/GHC/ByteCode/Instr.hs
+++ b/compiler/GHC/ByteCode/Instr.hs
@@ -50,7 +50,8 @@ data ProtoBCO a
         protoBCOFFIs       :: [FFIInfo]
    }
 
-newtype LocalLabel = LocalLabel { getLocalLabel :: Word16 }
+-- | A local block label (e.g. identifying a case alternative).
+newtype LocalLabel = LocalLabel { getLocalLabel :: Word32 }
   deriving (Eq, Ord)
 
 instance Outputable LocalLabel where
diff --git a/compiler/GHC/CoreToByteCode.hs b/compiler/GHC/CoreToByteCode.hs
index f28d40221a..3e2b8399f1 100644
--- a/compiler/GHC/CoreToByteCode.hs
+++ b/compiler/GHC/CoreToByteCode.hs
@@ -1966,7 +1966,7 @@ data BcM_State
         { bcm_hsc_env :: HscEnv
         , uniqSupply  :: UniqSupply      -- for generating fresh variable names
         , thisModule  :: Module          -- current module (for breakpoints)
-        , nextlabel   :: Word16          -- for generating local labels
+        , nextlabel   :: Word32          -- for generating local labels
         , ffis        :: [FFIInfo]       -- ffi info blocks, to free later
                                          -- Should be free()d when it is GCd
         , modBreaks   :: Maybe ModBreaks -- info about breakpoints
@@ -2038,7 +2038,7 @@ getLabelBc
                         panic "getLabelBc: Ran out of labels"
                     return (st{nextlabel = nl + 1}, LocalLabel nl)
 
-getLabelsBc :: Word16 -> BcM [LocalLabel]
+getLabelsBc :: Word32 -> BcM [LocalLabel]
 getLabelsBc n
   = BcM $ \st -> let ctr = nextlabel st
                  in return (st{nextlabel = ctr+n}, coerce [ctr .. ctr+n-1])
-- 
cgit v1.2.1