[Git][ghc/ghc][master] 4 commits: rts: Clean-up whitespace in Interpreter
Marge Bot
gitlab at gitlab.haskell.org
Fri Oct 16 01:58:36 UTC 2020
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
d495f36a by Ben Gamari at 2020-10-15T21:58:27-04:00
rts: Clean-up whitespace in Interpreter
- - - - -
cf10becd by Ben Gamari at 2020-10-15T21:58:27-04:00
compiler/ByteCode: Use strict Maps in bytecode assembler
- - - - -
ae146b53 by Ben Gamari at 2020-10-15T21:58:27-04:00
compiler/ByteCode: Make LocalLabel a newtype
- - - - -
cc536288 by Ben Gamari at 2020-10-15T21:58:27-04:00
compiler/ByteCode: Allow 2^32 local labels
This widens LocalLabel to 2^16, avoiding the crash observed in #14334.
Closes #14334.
- - - - -
4 changed files:
- compiler/GHC/ByteCode/Asm.hs
- compiler/GHC/ByteCode/Instr.hs
- compiler/GHC/CoreToByteCode.hs
- rts/Interpreter.c
Changes:
=====================================
compiler/GHC/ByteCode/Asm.hs
=====================================
@@ -59,9 +59,9 @@ import Data.Array.Unsafe( castSTUArray )
import Foreign
import Data.Char ( ord )
import Data.List ( genericLength )
-import Data.Map (Map)
+import Data.Map.Strict (Map)
import Data.Maybe (fromMaybe)
-import qualified Data.Map as Map
+import qualified Data.Map.Strict as Map
-- -----------------------------------------------------------------------------
-- Unlinked BCOs
@@ -179,10 +179,12 @@ 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 :: Word16 -> Word
+ env :: LocalLabel -> Word
env lbl = fromMaybe
(pprPanic "assembleBCO.findLabel" (ppr lbl))
(Map.lookup lbl lbl_map)
@@ -222,13 +224,13 @@ type AsmState = (SizedSeq Word16,
data Operand
= Op Word
| SmallOp Word16
- | LabelOp Word16
+ | LabelOp LocalLabel
-- (unused) | LargeOp Word
data Assembler a
= AllocPtr (IO BCOPtr) (Word -> Assembler a)
| AllocLit [BCONPtr] (Word -> Assembler a)
- | AllocLabel Word16 (Assembler a)
+ | AllocLabel LocalLabel (Assembler a)
| Emit Word16 [Operand] (Assembler a)
| NullAsm a
deriving (Functor)
@@ -253,13 +255,13 @@ ptr = ioptr . return
lit :: [BCONPtr] -> Assembler Word
lit l = AllocLit l return
-label :: Word16 -> Assembler ()
+label :: LocalLabel -> Assembler ()
label w = AllocLabel w (return ())
emit :: Word16 -> [Operand] -> Assembler ()
emit w ops = Emit w ops (return ())
-type LabelEnv = Word16 -> Word
+type LabelEnv = LocalLabel -> Word
largeOp :: Bool -> Operand -> Bool
largeOp long_jumps op = case op of
@@ -299,7 +301,7 @@ runAsm platform long_jumps e = go
in ((), (st_i1,st_l0,st_p0))
go k
-type LabelEnvMap = Map Word16 Word
+type LabelEnvMap = Map LocalLabel Word
data InspectState = InspectState
{ instrCount :: !Word
=====================================
compiler/GHC/ByteCode/Instr.hs
=====================================
@@ -6,7 +6,7 @@
-- | Bytecode instruction definitions
module GHC.ByteCode.Instr (
- BCInstr(..), ProtoBCO(..), bciStackUse,
+ BCInstr(..), ProtoBCO(..), bciStackUse, LocalLabel(..)
) where
#include "HsVersions.h"
@@ -50,7 +50,12 @@ data ProtoBCO a
protoBCOFFIs :: [FFIInfo]
}
-type LocalLabel = Word16
+-- | A local block label (e.g. identifying a case alternative).
+newtype LocalLabel = LocalLabel { getLocalLabel :: Word32 }
+ deriving (Eq, Ord)
+
+instance Outputable LocalLabel where
+ ppr (LocalLabel lbl) = text "lbl:" <> ppr lbl
data BCInstr
-- Messing with the stack
=====================================
compiler/GHC/CoreToByteCode.hs
=====================================
@@ -74,6 +74,7 @@ import GHC.Unit.Module
import Control.Exception
import Data.Array
+import Data.Coerce (coerce)
import Data.ByteString (ByteString)
import Data.Map (Map)
import Data.IntMap (IntMap)
@@ -1967,7 +1968,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
@@ -2032,17 +2033,17 @@ recordFFIBc :: RemotePtr C_ffi_cif -> BcM ()
recordFFIBc a
= BcM $ \st -> return (st{ffis = FFIInfo a : ffis st}, ())
-getLabelBc :: BcM Word16
+getLabelBc :: BcM LocalLabel
getLabelBc
= BcM $ \st -> do let nl = nextlabel st
when (nl == maxBound) $
panic "getLabelBc: Ran out of labels"
- return (st{nextlabel = nl + 1}, nl)
+ return (st{nextlabel = nl + 1}, LocalLabel nl)
-getLabelsBc :: Word16 -> BcM [Word16]
+getLabelsBc :: Word32 -> BcM [LocalLabel]
getLabelsBc n
= BcM $ \st -> let ctr = nextlabel st
- in return (st{nextlabel = ctr+n}, [ctr .. ctr+n-1])
+ in return (st{nextlabel = ctr+n}, coerce [ctr .. ctr+n-1])
getCCArray :: BcM (Array BreakIndex (RemotePtr CostCentre))
getCCArray = BcM $ \st ->
=====================================
rts/Interpreter.c
=====================================
@@ -1478,11 +1478,11 @@ run_BCO:
for (i = 0; i < n_payload; i++)
ap->payload[i] = (StgClosure*)SpW(i+1);
- Sp_addW(n_payload+1);
- IF_DEBUG(interpreter,
- debugBelch("\tBuilt ");
- printObj((StgClosure*)ap);
- );
+ Sp_addW(n_payload+1);
+ IF_DEBUG(interpreter,
+ debugBelch("\tBuilt ");
+ printObj((StgClosure*)ap);
+ );
goto nextInsn;
}
@@ -1504,11 +1504,11 @@ run_BCO:
for (i = 0; i < n_payload; i++)
pap->payload[i] = (StgClosure*)SpW(i+1);
- Sp_addW(n_payload+1);
- IF_DEBUG(interpreter,
- debugBelch("\tBuilt ");
- printObj((StgClosure*)pap);
- );
+ Sp_addW(n_payload+1);
+ IF_DEBUG(interpreter,
+ debugBelch("\tBuilt ");
+ printObj((StgClosure*)pap);
+ );
goto nextInsn;
}
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6b14c4185ca944295d5cfa60ebc6f7ab2a257fc9...cc536288c32df9c4b9f37020b76348f58a57b3cb
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6b14c4185ca944295d5cfa60ebc6f7ab2a257fc9...cc536288c32df9c4b9f37020b76348f58a57b3cb
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/20201015/47473eb4/attachment-0001.html>
More information about the ghc-commits
mailing list