[Git][ghc/ghc][master] Add support for sized literals in the bytecode interpreter.
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Fri Jan 6 18:46:50 UTC 2023
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
28f8c0eb by Luite Stegeman at 2023-01-06T18:16:24+09:00
Add support for sized literals in the bytecode interpreter.
The bytecode interpreter only has branching instructions for
word-sized values. These are used for pattern matching.
Branching instructions for other types (e.g. Int16# or Word8#)
weren't needed, since unoptimized Core or STG never requires
branching on types like this.
It's now possible for optimized STG to reach the bytecode
generator (e.g. fat interface files or certain compiler flag
combinations), which requires dealing with various sized
literals in branches.
This patch improves support for generating bytecode from
optimized STG by adding the following new bytecode
instructions:
TESTLT_I64
TESTEQ_I64
TESTLT_I32
TESTEQ_I32
TESTLT_I16
TESTEQ_I16
TESTLT_I8
TESTEQ_I8
TESTLT_W64
TESTEQ_W64
TESTLT_W32
TESTEQ_W32
TESTLT_W16
TESTEQ_W16
TESTLT_W8
TESTEQ_W8
Fixes #21945
- - - - -
11 changed files:
- compiler/GHC/ByteCode/Asm.hs
- compiler/GHC/ByteCode/Instr.hs
- compiler/GHC/StgToByteCode.hs
- compiler/GHC/Utils/Outputable.hs
- rts/Disassembler.c
- rts/Interpreter.c
- rts/include/rts/Bytecodes.h
- + testsuite/tests/ghci/should_run/SizedLiterals.hs
- + testsuite/tests/ghci/should_run/SizedLiterals.stdout
- + testsuite/tests/ghci/should_run/SizedLiteralsA.hs
- testsuite/tests/ghci/should_run/all.T
Changes:
=====================================
compiler/GHC/ByteCode/Asm.hs
=====================================
@@ -440,6 +440,38 @@ assembleI platform i = case i of
emit bci_TESTLT_W [Op np, LabelOp l]
TESTEQ_W w l -> do np <- word w
emit bci_TESTEQ_W [Op np, LabelOp l]
+ TESTLT_I64 i l -> do np <- int64 i
+ emit bci_TESTLT_I64 [Op np, LabelOp l]
+ TESTEQ_I64 i l -> do np <- int64 i
+ emit bci_TESTEQ_I64 [Op np, LabelOp l]
+ TESTLT_I32 i l -> do np <- int (fromIntegral i)
+ emit bci_TESTLT_I32 [Op np, LabelOp l]
+ TESTEQ_I32 i l -> do np <- int (fromIntegral i)
+ emit bci_TESTEQ_I32 [Op np, LabelOp l]
+ TESTLT_I16 i l -> do np <- int (fromIntegral i)
+ emit bci_TESTLT_I16 [Op np, LabelOp l]
+ TESTEQ_I16 i l -> do np <- int (fromIntegral i)
+ emit bci_TESTEQ_I16 [Op np, LabelOp l]
+ TESTLT_I8 i l -> do np <- int (fromIntegral i)
+ emit bci_TESTLT_I8 [Op np, LabelOp l]
+ TESTEQ_I8 i l -> do np <- int (fromIntegral i)
+ emit bci_TESTEQ_I8 [Op np, LabelOp l]
+ TESTLT_W64 w l -> do np <- word64 w
+ emit bci_TESTLT_W64 [Op np, LabelOp l]
+ TESTEQ_W64 w l -> do np <- word64 w
+ emit bci_TESTEQ_W64 [Op np, LabelOp l]
+ TESTLT_W32 w l -> do np <- word (fromIntegral w)
+ emit bci_TESTLT_W32 [Op np, LabelOp l]
+ TESTEQ_W32 w l -> do np <- word (fromIntegral w)
+ emit bci_TESTEQ_W32 [Op np, LabelOp l]
+ TESTLT_W16 w l -> do np <- word (fromIntegral w)
+ emit bci_TESTLT_W16 [Op np, LabelOp l]
+ TESTEQ_W16 w l -> do np <- word (fromIntegral w)
+ emit bci_TESTEQ_W16 [Op np, LabelOp l]
+ TESTLT_W8 w l -> do np <- word (fromIntegral w)
+ emit bci_TESTLT_W8 [Op np, LabelOp l]
+ TESTEQ_W8 w l -> do np <- word (fromIntegral w)
+ emit bci_TESTEQ_W8 [Op np, LabelOp l]
TESTLT_F f l -> do np <- float f
emit bci_TESTLT_F [Op np, LabelOp l]
TESTEQ_F f l -> do np <- float f
@@ -505,6 +537,7 @@ assembleI platform i = case i of
int16 = words . mkLitI64 platform
int32 = words . mkLitI64 platform
int64 = words . mkLitI64 platform
+ word64 = words . mkLitW64 platform
words ws = lit (map BCONPtrWord ws)
word w = words [w]
@@ -590,6 +623,7 @@ mkLitI :: Int -> [Word]
mkLitF :: Platform -> Float -> [Word]
mkLitD :: Platform -> Double -> [Word]
mkLitI64 :: Platform -> Int64 -> [Word]
+mkLitW64 :: Platform -> Word64 -> [Word]
mkLitF platform f = case platformWordSize platform of
PW4 -> runST $ do
@@ -636,13 +670,18 @@ mkLitI64 platform ii = case platformWordSize platform of
w1 <- readArray d_arr 1
return [w0 :: Word,w1]
)
- PW8 -> runST (do
- arr <- newArray_ ((0::Int),0)
- writeArray arr 0 ii
+ PW8 -> [fromIntegral ii :: Word]
+
+mkLitW64 platform ww = case platformWordSize platform of
+ PW4 -> runST (do
+ arr <- newArray_ ((0::Word),1)
+ writeArray arr 0 ww
d_arr <- castSTUArray arr
w0 <- readArray d_arr 0
- return [w0 :: Word]
+ w1 <- readArray d_arr 1
+ return [w0 :: Word,w1]
)
+ PW8 -> [fromIntegral ww :: Word]
mkLitI i = [fromIntegral i :: Word]
=====================================
compiler/GHC/ByteCode/Instr.hs
=====================================
@@ -24,7 +24,9 @@ import GHC.Core.DataCon
import GHC.Builtin.PrimOps
import GHC.Runtime.Heap.Layout
+import Data.Int
import Data.Word
+
import GHC.Stack.CCS (CostCentre)
import GHC.Stg.Syntax
@@ -141,6 +143,22 @@ data BCInstr
| TESTEQ_I Int LocalLabel
| TESTLT_W Word LocalLabel
| TESTEQ_W Word LocalLabel
+ | TESTLT_I64 Int64 LocalLabel
+ | TESTEQ_I64 Int64 LocalLabel
+ | TESTLT_I32 Int32 LocalLabel
+ | TESTEQ_I32 Int32 LocalLabel
+ | TESTLT_I16 Int16 LocalLabel
+ | TESTEQ_I16 Int16 LocalLabel
+ | TESTLT_I8 Int8 LocalLabel
+ | TESTEQ_I8 Int16 LocalLabel
+ | TESTLT_W64 Word64 LocalLabel
+ | TESTEQ_W64 Word64 LocalLabel
+ | TESTLT_W32 Word32 LocalLabel
+ | TESTEQ_W32 Word32 LocalLabel
+ | TESTLT_W16 Word16 LocalLabel
+ | TESTEQ_W16 Word16 LocalLabel
+ | TESTLT_W8 Word8 LocalLabel
+ | TESTEQ_W8 Word8 LocalLabel
| TESTLT_F Float LocalLabel
| TESTEQ_F Float LocalLabel
| TESTLT_D Double LocalLabel
@@ -291,6 +309,22 @@ instance Outputable BCInstr where
ppr (TESTEQ_I i lab) = text "TESTEQ_I" <+> int i <+> text "__" <> ppr lab
ppr (TESTLT_W i lab) = text "TESTLT_W" <+> int (fromIntegral i) <+> text "__" <> ppr lab
ppr (TESTEQ_W i lab) = text "TESTEQ_W" <+> int (fromIntegral i) <+> text "__" <> ppr lab
+ ppr (TESTLT_I64 i lab) = text "TESTLT_I64" <+> ppr i <+> text "__" <> ppr lab
+ ppr (TESTEQ_I64 i lab) = text "TESTEQ_I64" <+> ppr i <+> text "__" <> ppr lab
+ ppr (TESTLT_I32 i lab) = text "TESTLT_I32" <+> ppr i <+> text "__" <> ppr lab
+ ppr (TESTEQ_I32 i lab) = text "TESTEQ_I32" <+> ppr i <+> text "__" <> ppr lab
+ ppr (TESTLT_I16 i lab) = text "TESTLT_I16" <+> ppr i <+> text "__" <> ppr lab
+ ppr (TESTEQ_I16 i lab) = text "TESTEQ_I16" <+> ppr i <+> text "__" <> ppr lab
+ ppr (TESTLT_I8 i lab) = text "TESTLT_I8" <+> ppr i <+> text "__" <> ppr lab
+ ppr (TESTEQ_I8 i lab) = text "TESTEQ_I8" <+> ppr i <+> text "__" <> ppr lab
+ ppr (TESTLT_W64 i lab) = text "TESTLT_W64" <+> ppr i <+> text "__" <> ppr lab
+ ppr (TESTEQ_W64 i lab) = text "TESTEQ_W64" <+> ppr i <+> text "__" <> ppr lab
+ ppr (TESTLT_W32 i lab) = text "TESTLT_W32" <+> ppr i <+> text "__" <> ppr lab
+ ppr (TESTEQ_W32 i lab) = text "TESTEQ_W32" <+> ppr i <+> text "__" <> ppr lab
+ ppr (TESTLT_W16 i lab) = text "TESTLT_W16" <+> ppr i <+> text "__" <> ppr lab
+ ppr (TESTEQ_W16 i lab) = text "TESTEQ_W16" <+> ppr i <+> text "__" <> ppr lab
+ ppr (TESTLT_W8 i lab) = text "TESTLT_W8" <+> ppr i <+> text "__" <> ppr lab
+ ppr (TESTEQ_W8 i lab) = text "TESTEQ_W8" <+> ppr i <+> text "__" <> ppr lab
ppr (TESTLT_F f lab) = text "TESTLT_F" <+> float f <+> text "__" <> ppr lab
ppr (TESTEQ_F f lab) = text "TESTEQ_F" <+> float f <+> text "__" <> ppr lab
ppr (TESTLT_D d lab) = text "TESTLT_D" <+> double d <+> text "__" <> ppr lab
@@ -380,6 +414,22 @@ bciStackUse TESTLT_I{} = 0
bciStackUse TESTEQ_I{} = 0
bciStackUse TESTLT_W{} = 0
bciStackUse TESTEQ_W{} = 0
+bciStackUse TESTLT_I64{} = 0
+bciStackUse TESTEQ_I64{} = 0
+bciStackUse TESTLT_I32{} = 0
+bciStackUse TESTEQ_I32{} = 0
+bciStackUse TESTLT_I16{} = 0
+bciStackUse TESTEQ_I16{} = 0
+bciStackUse TESTLT_I8{} = 0
+bciStackUse TESTEQ_I8{} = 0
+bciStackUse TESTLT_W64{} = 0
+bciStackUse TESTEQ_W64{} = 0
+bciStackUse TESTLT_W32{} = 0
+bciStackUse TESTEQ_W32{} = 0
+bciStackUse TESTLT_W16{} = 0
+bciStackUse TESTEQ_W16{} = 0
+bciStackUse TESTLT_W8{} = 0
+bciStackUse TESTEQ_W8{} = 0
bciStackUse TESTLT_F{} = 0
bciStackUse TESTEQ_F{} = 0
bciStackUse TESTLT_D{} = 0
=====================================
compiler/GHC/StgToByteCode.hs
=====================================
@@ -936,12 +936,26 @@ doCase d s p scrut bndr alts
| otherwise
-> DiscrP (fromIntegral (dataConTag dc - fIRST_TAG))
LitAlt l -> case l of
- LitNumber LitNumInt i -> DiscrI (fromInteger i)
- LitNumber LitNumWord w -> DiscrW (fromInteger w)
- LitFloat r -> DiscrF (fromRational r)
- LitDouble r -> DiscrD (fromRational r)
- LitChar i -> DiscrI (ord i)
- _ -> pprPanic "schemeE(StgCase).my_discr" (ppr l)
+ LitNumber LitNumInt i -> DiscrI (fromInteger i)
+ LitNumber LitNumInt8 i -> DiscrI8 (fromInteger i)
+ LitNumber LitNumInt16 i -> DiscrI16 (fromInteger i)
+ LitNumber LitNumInt32 i -> DiscrI32 (fromInteger i)
+ LitNumber LitNumInt64 i -> DiscrI64 (fromInteger i)
+ LitNumber LitNumWord w -> DiscrW (fromInteger w)
+ LitNumber LitNumWord8 w -> DiscrW8 (fromInteger w)
+ LitNumber LitNumWord16 w -> DiscrW16 (fromInteger w)
+ LitNumber LitNumWord32 w -> DiscrW32 (fromInteger w)
+ LitNumber LitNumWord64 w -> DiscrW64 (fromInteger w)
+ LitNumber LitNumBigNat _ -> unsupported
+ LitFloat r -> DiscrF (fromRational r)
+ LitDouble r -> DiscrD (fromRational r)
+ LitChar i -> DiscrI (ord i)
+ LitString {} -> unsupported
+ LitRubbish {} -> unsupported
+ LitNullAddr {} -> unsupported
+ LitLabel {} -> unsupported
+ where
+ unsupported = pprPanic "schemeE(StgCase).my_discr:" (ppr l)
maybe_ncons
| not isAlgCase = Nothing
@@ -1841,14 +1855,30 @@ mkMultiBranch maybe_ncons raw_ways = do
notd_ways = sortBy (comparing fst) not_defaults
testLT (DiscrI i) fail_label = TESTLT_I i fail_label
+ testLT (DiscrI8 i) fail_label = TESTLT_I8 (fromIntegral i) fail_label
+ testLT (DiscrI16 i) fail_label = TESTLT_I16 (fromIntegral i) fail_label
+ testLT (DiscrI32 i) fail_label = TESTLT_I32 (fromIntegral i) fail_label
+ testLT (DiscrI64 i) fail_label = TESTLT_I64 (fromIntegral i) fail_label
testLT (DiscrW i) fail_label = TESTLT_W i fail_label
+ testLT (DiscrW8 i) fail_label = TESTLT_W8 (fromIntegral i) fail_label
+ testLT (DiscrW16 i) fail_label = TESTLT_W16 (fromIntegral i) fail_label
+ testLT (DiscrW32 i) fail_label = TESTLT_W32 (fromIntegral i) fail_label
+ testLT (DiscrW64 i) fail_label = TESTLT_W64 (fromIntegral i) fail_label
testLT (DiscrF i) fail_label = TESTLT_F i fail_label
testLT (DiscrD i) fail_label = TESTLT_D i fail_label
testLT (DiscrP i) fail_label = TESTLT_P i fail_label
testLT NoDiscr _ = panic "mkMultiBranch NoDiscr"
testEQ (DiscrI i) fail_label = TESTEQ_I i fail_label
+ testEQ (DiscrI8 i) fail_label = TESTEQ_I8 (fromIntegral i) fail_label
+ testEQ (DiscrI16 i) fail_label = TESTEQ_I16 (fromIntegral i) fail_label
+ testEQ (DiscrI32 i) fail_label = TESTEQ_I32 (fromIntegral i) fail_label
+ testEQ (DiscrI64 i) fail_label = TESTEQ_I64 (fromIntegral i) fail_label
testEQ (DiscrW i) fail_label = TESTEQ_W i fail_label
+ testEQ (DiscrW8 i) fail_label = TESTEQ_W8 (fromIntegral i) fail_label
+ testEQ (DiscrW16 i) fail_label = TESTEQ_W16 (fromIntegral i) fail_label
+ testEQ (DiscrW32 i) fail_label = TESTEQ_W32 (fromIntegral i) fail_label
+ testEQ (DiscrW64 i) fail_label = TESTEQ_W64 (fromIntegral i) fail_label
testEQ (DiscrF i) fail_label = TESTEQ_F i fail_label
testEQ (DiscrD i) fail_label = TESTEQ_D i fail_label
testEQ (DiscrP i) fail_label = TESTEQ_P i fail_label
@@ -1859,7 +1889,15 @@ mkMultiBranch maybe_ncons raw_ways = do
[] -> panic "mkMultiBranch: awesome foursome"
(discr, _):_ -> case discr of
DiscrI _ -> ( DiscrI minBound, DiscrI maxBound )
+ DiscrI8 _ -> ( DiscrI8 minBound, DiscrI8 maxBound )
+ DiscrI16 _ -> ( DiscrI16 minBound, DiscrI16 maxBound )
+ DiscrI32 _ -> ( DiscrI32 minBound, DiscrI32 maxBound )
+ DiscrI64 _ -> ( DiscrI64 minBound, DiscrI64 maxBound )
DiscrW _ -> ( DiscrW minBound, DiscrW maxBound )
+ DiscrW8 _ -> ( DiscrW8 minBound, DiscrW8 maxBound )
+ DiscrW16 _ -> ( DiscrW16 minBound, DiscrW16 maxBound )
+ DiscrW32 _ -> ( DiscrW32 minBound, DiscrW32 maxBound )
+ DiscrW64 _ -> ( DiscrW64 minBound, DiscrW64 maxBound )
DiscrF _ -> ( DiscrF minF, DiscrF maxF )
DiscrD _ -> ( DiscrD minD, DiscrD maxD )
DiscrP _ -> ( DiscrP algMinBound, DiscrP algMaxBound )
@@ -1895,7 +1933,15 @@ mkMultiBranch maybe_ncons raw_ways = do
-- Describes case alts
data Discr
= DiscrI Int
+ | DiscrI8 Int8
+ | DiscrI16 Int16
+ | DiscrI32 Int32
+ | DiscrI64 Int64
| DiscrW Word
+ | DiscrW8 Word8
+ | DiscrW16 Word16
+ | DiscrW32 Word32
+ | DiscrW64 Word64
| DiscrF Float
| DiscrD Double
| DiscrP Word16
@@ -1904,7 +1950,15 @@ data Discr
instance Outputable Discr where
ppr (DiscrI i) = int i
+ ppr (DiscrI8 i) = text (show i)
+ ppr (DiscrI16 i) = text (show i)
+ ppr (DiscrI32 i) = text (show i)
+ ppr (DiscrI64 i) = text (show i)
ppr (DiscrW w) = text (show w)
+ ppr (DiscrW8 w) = text (show w)
+ ppr (DiscrW16 w) = text (show w)
+ ppr (DiscrW32 w) = text (show w)
+ ppr (DiscrW64 w) = text (show w)
ppr (DiscrF f) = text (show f)
ppr (DiscrD d) = text (show d)
ppr (DiscrP i) = ppr i
=====================================
compiler/GHC/Utils/Outputable.hs
=====================================
@@ -896,6 +896,12 @@ instance Outputable Ordering where
ppr EQ = text "EQ"
ppr GT = text "GT"
+instance Outputable Int8 where
+ ppr n = integer $ fromIntegral n
+
+instance Outputable Int16 where
+ ppr n = integer $ fromIntegral n
+
instance Outputable Int32 where
ppr n = integer $ fromIntegral n
@@ -908,6 +914,9 @@ instance Outputable Int where
instance Outputable Integer where
ppr n = integer n
+instance Outputable Word8 where
+ ppr n = integer $ fromIntegral n
+
instance Outputable Word16 where
ppr n = integer $ fromIntegral n
=====================================
rts/Disassembler.c
=====================================
@@ -254,26 +254,135 @@ disInstr ( StgBCO *bco, int pc )
debugBelch("TESTLT_I %" FMT_Int ", fail to %d\n", literals[discr], failto);
break;
}
+
+ case bci_TESTLT_I64: {
+ unsigned int discr = BCO_NEXT;
+ int failto = BCO_GET_LARGE_ARG;
+ debugBelch("TESTLT_I64 %" FMT_Int64 ", fail to %d\n", *((StgInt64*)(literals+discr)), failto);
+ break;
+ }
+
+ case bci_TESTLT_I32: {
+ unsigned int discr = BCO_NEXT;
+ int failto = BCO_GET_LARGE_ARG;
+ debugBelch("TESTLT_I32 %" FMT_Int ", fail to %d\n", literals[discr], failto);
+ break;
+ }
+
+ case bci_TESTLT_I16: {
+ unsigned int discr = BCO_NEXT;
+ int failto = BCO_GET_LARGE_ARG;
+ debugBelch("TESTLT_I16 %" FMT_Int ", fail to %d\n", literals[discr], failto);
+ break;
+ }
+
+ case bci_TESTLT_I8: {
+ unsigned int discr = BCO_NEXT;
+ int failto = BCO_GET_LARGE_ARG;
+ debugBelch("TESTLT_I8 %" FMT_Int ", fail to %d\n", literals[discr], failto);
+ break;
+ }
+
case bci_TESTEQ_I:
debugBelch("TESTEQ_I %" FMT_Int ", fail to %d\n", literals[instrs[pc]],
instrs[pc+1]);
pc += 2; break;
+ case bci_TESTEQ_I64:
+ debugBelch("TESTEQ_I64 %" FMT_Int64 ", fail to %d\n", *((StgInt64*)(literals+instrs[pc])),
+ instrs[pc+1]);
+ pc += 2; break;
+
+ case bci_TESTEQ_I32:
+ debugBelch("TESTEQ_I32 %" FMT_Int ", fail to %d\n", literals[instrs[pc]],
+ instrs[pc+1]);
+ pc += 2; break;
+
+ case bci_TESTEQ_I16:
+ debugBelch("TESTEQ_I16 %" FMT_Int ", fail to %d\n", literals[instrs[pc]],
+ instrs[pc+1]);
+ pc += 2; break;
+
+ case bci_TESTEQ_I8:
+ debugBelch("TESTEQ_I8 %" FMT_Int ", fail to %d\n", literals[instrs[pc]],
+ instrs[pc+1]);
+ pc += 2; break;
+
+ case bci_TESTLT_W: {
+ unsigned int discr = BCO_NEXT;
+ int failto = BCO_GET_LARGE_ARG;
+ debugBelch("TESTLT_W %" FMT_Word ", fail to %d\n", literals[discr], failto);
+ break;
+ }
+
+ case bci_TESTLT_W64: {
+ unsigned int discr = BCO_NEXT;
+ int failto = BCO_GET_LARGE_ARG;
+ debugBelch("TESTLT_W64 %" FMT_Word64 ", fail to %d\n", *((StgWord64*)(literals+discr)), failto);
+ break;
+ }
+
+ case bci_TESTLT_W32: {
+ unsigned int discr = BCO_NEXT;
+ int failto = BCO_GET_LARGE_ARG;
+ debugBelch("TESTLT_W32 %" FMT_Word ", fail to %d\n", literals[discr], failto);
+ break;
+ }
+
+ case bci_TESTLT_W16: {
+ unsigned int discr = BCO_NEXT;
+ int failto = BCO_GET_LARGE_ARG;
+ debugBelch("TESTLT_W16 %" FMT_Word ", fail to %d\n", literals[discr], failto);
+ break;
+ }
+
+ case bci_TESTLT_W8: {
+ unsigned int discr = BCO_NEXT;
+ int failto = BCO_GET_LARGE_ARG;
+ debugBelch("TESTLT_W8 %" FMT_Word ", fail to %d\n", literals[discr], failto);
+ break;
+ }
+
+ case bci_TESTEQ_W:
+ debugBelch("TESTEQ_W %" FMT_Word ", fail to %d\n", literals[instrs[pc]],
+ instrs[pc+1]);
+ pc += 2; break;
+
+ case bci_TESTEQ_W64:
+ debugBelch("TESTEQ_W64 %" FMT_Word64 ", fail to %d\n", *((StgWord64*)(literals+instrs[pc])),
+ instrs[pc+1]);
+ pc += 2; break;
+
+ case bci_TESTEQ_W32:
+ debugBelch("TESTEQ_W32 %" FMT_Word ", fail to %d\n", literals[instrs[pc]],
+ instrs[pc+1]);
+ pc += 2; break;
+
+ case bci_TESTEQ_W16:
+ debugBelch("TESTEQ_W16 %" FMT_Word ", fail to %d\n", literals[instrs[pc]],
+ instrs[pc+1]);
+ pc += 2; break;
+
+ case bci_TESTEQ_W8:
+ debugBelch("TESTEQ_W8 %" FMT_Word ", fail to %d\n", literals[instrs[pc]],
+ instrs[pc+1]);
+ pc += 2; break;
+
case bci_TESTLT_F:
- debugBelch("TESTLT_F %" FMT_Int ", fail to %d\n", literals[instrs[pc]],
+ debugBelch("TESTLT_F %f, fail to %d\n", *((StgFloat*)literals+instrs[pc]),
instrs[pc+1]);
pc += 2; break;
case bci_TESTEQ_F:
- debugBelch("TESTEQ_F %" FMT_Int ", fail to %d\n", literals[instrs[pc]],
+ debugBelch("TESTEQ_F %f, fail to %d\n", *((StgFloat*)literals+instrs[pc]),
instrs[pc+1]);
pc += 2; break;
case bci_TESTLT_D:
- debugBelch("TESTLT_D %" FMT_Int ", fail to %d\n", literals[instrs[pc]],
+ debugBelch("TESTLT_D %f, fail to %d\n", *((StgDouble*)(literals+instrs[pc])),
instrs[pc+1]);
pc += 2; break;
case bci_TESTEQ_D:
- debugBelch("TESTEQ_D %" FMT_Int ", fail to %d\n", literals[instrs[pc]],
+ debugBelch("TESTEQ_D %f, fail to %d\n", *((StgDouble*)(literals+instrs[pc])),
instrs[pc+1]);
pc += 2; break;
=====================================
rts/Interpreter.c
=====================================
@@ -75,6 +75,8 @@
#define BCO_PTR(n) (W_)ptrs[n]
#define BCO_LIT(n) literals[n]
+#define BCO_LITW64(n) (*(StgWord64*)(literals+n))
+#define BCO_LITI64(n) (*(StgInt64*)(literals+n))
#define LOAD_STACK_POINTERS \
Sp = cap->r.rCurrentTSO->stackobj->sp; \
@@ -1728,6 +1730,46 @@ run_BCO:
goto nextInsn;
}
+ case bci_TESTLT_I64: {
+ // There should be an Int64 at SpW(1), and an info table at SpW(0).
+ int discr = BCO_GET_LARGE_ARG;
+ int failto = BCO_GET_LARGE_ARG;
+ StgInt64 stackInt = (*(StgInt64*)Sp_plusW(1));
+ if (stackInt >= BCO_LITI64(discr))
+ bciPtr = failto;
+ goto nextInsn;
+ }
+
+ case bci_TESTLT_I32: {
+ // There should be an Int32 at SpW(1), and an info table at SpW(0).
+ int discr = BCO_GET_LARGE_ARG;
+ int failto = BCO_GET_LARGE_ARG;
+ StgInt32 stackInt = (*(StgInt32*)Sp_plusW(1));
+ if (stackInt >= (StgInt32)BCO_LIT(discr))
+ bciPtr = failto;
+ goto nextInsn;
+ }
+
+ case bci_TESTLT_I16: {
+ // There should be an Int16 at SpW(1), and an info table at SpW(0).
+ int discr = BCO_GET_LARGE_ARG;
+ int failto = BCO_GET_LARGE_ARG;
+ StgInt16 stackInt = (*(StgInt16*)Sp_plusW(1));
+ if (stackInt >= (StgInt16)BCO_LIT(discr))
+ bciPtr = failto;
+ goto nextInsn;
+ }
+
+ case bci_TESTLT_I8: {
+ // There should be an Int8 at SpW(1), and an info table at SpW(0).
+ int discr = BCO_GET_LARGE_ARG;
+ int failto = BCO_GET_LARGE_ARG;
+ StgInt8 stackInt = (*(StgInt8*)Sp_plusW(1));
+ if (stackInt >= (StgInt8)BCO_LIT(discr))
+ bciPtr = failto;
+ goto nextInsn;
+ }
+
case bci_TESTEQ_I: {
// There should be an Int at SpW(1), and an info table at SpW(0).
int discr = BCO_GET_LARGE_ARG;
@@ -1739,8 +1781,52 @@ run_BCO:
goto nextInsn;
}
+ case bci_TESTEQ_I64: {
+ // There should be an Int64 at SpW(1), and an info table at SpW(0).
+ int discr = BCO_GET_LARGE_ARG;
+ int failto = BCO_GET_LARGE_ARG;
+ StgInt64 stackInt = (*(StgInt64*)Sp_plusW(1));
+ if (stackInt != BCO_LITI64(discr)) {
+ bciPtr = failto;
+ }
+ goto nextInsn;
+ }
+
+ case bci_TESTEQ_I32: {
+ // There should be an Int32 at SpW(1), and an info table at SpW(0).
+ int discr = BCO_GET_LARGE_ARG;
+ int failto = BCO_GET_LARGE_ARG;
+ StgInt32 stackInt = (*(StgInt32*)Sp_plusW(1));
+ if (stackInt != (StgInt32)BCO_LIT(discr)) {
+ bciPtr = failto;
+ }
+ goto nextInsn;
+ }
+
+ case bci_TESTEQ_I16: {
+ // There should be an Int16 at SpW(1), and an info table at SpW(0).
+ int discr = BCO_GET_LARGE_ARG;
+ int failto = BCO_GET_LARGE_ARG;
+ StgInt16 stackInt = (*(StgInt16*)Sp_plusW(1));
+ if (stackInt != (StgInt16)BCO_LIT(discr)) {
+ bciPtr = failto;
+ }
+ goto nextInsn;
+ }
+
+ case bci_TESTEQ_I8: {
+ // There should be an Int8 at SpW(1), and an info table at SpW(0).
+ int discr = BCO_GET_LARGE_ARG;
+ int failto = BCO_GET_LARGE_ARG;
+ StgInt8 stackInt = (*(StgInt8*)Sp_plusW(1));
+ if (stackInt != (StgInt8)BCO_LIT(discr)) {
+ bciPtr = failto;
+ }
+ goto nextInsn;
+ }
+
case bci_TESTLT_W: {
- // There should be an Int at SpW(1), and an info table at SpW(0).
+ // There should be a Word at SpW(1), and an info table at SpW(0).
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
W_ stackWord = (W_)SpW(1);
@@ -1749,8 +1835,48 @@ run_BCO:
goto nextInsn;
}
+ case bci_TESTLT_W64: {
+ // There should be a Word64 at SpW(1), and an info table at SpW(0).
+ int discr = BCO_GET_LARGE_ARG;
+ int failto = BCO_GET_LARGE_ARG;
+ StgWord64 stackWord = (*(StgWord64*)Sp_plusW(1));
+ if (stackWord >= BCO_LITW64(discr))
+ bciPtr = failto;
+ goto nextInsn;
+ }
+
+ case bci_TESTLT_W32: {
+ // There should be a Word32 at SpW(1), and an info table at SpW(0).
+ int discr = BCO_GET_LARGE_ARG;
+ int failto = BCO_GET_LARGE_ARG;
+ StgWord32 stackWord = (*(StgWord32*)Sp_plusW(1));
+ if (stackWord >= (StgWord32)BCO_LIT(discr))
+ bciPtr = failto;
+ goto nextInsn;
+ }
+
+ case bci_TESTLT_W16: {
+ // There should be a Word16 at SpW(1), and an info table at SpW(0).
+ int discr = BCO_GET_LARGE_ARG;
+ int failto = BCO_GET_LARGE_ARG;
+ StgWord16 stackWord = (*(StgWord16*)Sp_plusW(1));
+ if (stackWord >= (StgWord16)BCO_LIT(discr))
+ bciPtr = failto;
+ goto nextInsn;
+ }
+
+ case bci_TESTLT_W8: {
+ // There should be a Word8 at SpW(1), and an info table at SpW(0).
+ int discr = BCO_GET_LARGE_ARG;
+ int failto = BCO_GET_LARGE_ARG;
+ StgWord8 stackWord = (*(StgWord8*)Sp_plusW(1));
+ if (stackWord >= (StgWord8)BCO_LIT(discr))
+ bciPtr = failto;
+ goto nextInsn;
+ }
+
case bci_TESTEQ_W: {
- // There should be an Int at SpW(1), and an info table at SpW(0).
+ // There should be a Word at SpW(1), and an info table at SpW(0).
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
W_ stackWord = (W_)SpW(1);
@@ -1760,6 +1886,50 @@ run_BCO:
goto nextInsn;
}
+ case bci_TESTEQ_W64: {
+ // There should be a Word64 at SpW(1), and an info table at SpW(0).
+ int discr = BCO_GET_LARGE_ARG;
+ int failto = BCO_GET_LARGE_ARG;
+ StgWord64 stackWord = (*(StgWord64*)Sp_plusW(1));
+ if (stackWord != BCO_LITW64(discr)) {
+ bciPtr = failto;
+ }
+ goto nextInsn;
+ }
+
+ case bci_TESTEQ_W32: {
+ // There should be a Word32 at SpW(1), and an info table at SpW(0).
+ int discr = BCO_GET_LARGE_ARG;
+ int failto = BCO_GET_LARGE_ARG;
+ StgWord32 stackWord = (*(StgWord32*)Sp_plusW(1));
+ if (stackWord != (StgWord32)BCO_LIT(discr)) {
+ bciPtr = failto;
+ }
+ goto nextInsn;
+ }
+
+ case bci_TESTEQ_W16: {
+ // There should be a Word16 at SpW(1), and an info table at SpW(0).
+ int discr = BCO_GET_LARGE_ARG;
+ int failto = BCO_GET_LARGE_ARG;
+ StgWord16 stackWord = (*(StgWord16*)Sp_plusW(1));
+ if (stackWord != (StgWord16)BCO_LIT(discr)) {
+ bciPtr = failto;
+ }
+ goto nextInsn;
+ }
+
+ case bci_TESTEQ_W8: {
+ // There should be a Word8 at SpW(1), and an info table at SpW(0).
+ int discr = BCO_GET_LARGE_ARG;
+ int failto = BCO_GET_LARGE_ARG;
+ StgWord8 stackWord = (*(StgWord8*)Sp_plusW(1));
+ if (stackWord != (StgWord8)BCO_LIT(discr)) {
+ bciPtr = failto;
+ }
+ goto nextInsn;
+ }
+
case bci_TESTLT_D: {
// There should be a Double at SpW(1), and an info table at SpW(0).
int discr = BCO_GET_LARGE_ARG;
=====================================
rts/include/rts/Bytecodes.h
=====================================
@@ -94,6 +94,24 @@
#define bci_RETURN_T 69
#define bci_PUSH_ALTS_T 70
+
+#define bci_TESTLT_I64 71
+#define bci_TESTEQ_I64 72
+#define bci_TESTLT_I32 73
+#define bci_TESTEQ_I32 74
+#define bci_TESTLT_I16 75
+#define bci_TESTEQ_I16 76
+#define bci_TESTLT_I8 77
+#define bci_TESTEQ_I8 78
+#define bci_TESTLT_W64 79
+#define bci_TESTEQ_W64 80
+#define bci_TESTLT_W32 81
+#define bci_TESTEQ_W32 82
+#define bci_TESTLT_W16 83
+#define bci_TESTEQ_W16 84
+#define bci_TESTLT_W8 85
+#define bci_TESTEQ_W8 86
+
/* If you need to go past 255 then you will run into the flags */
/* If you need to go below 0x0100 then you will run into the instructions */
=====================================
testsuite/tests/ghci/should_run/SizedLiterals.hs
=====================================
@@ -0,0 +1,117 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+import SizedLiteralsA
+import Language.Haskell.TH
+
+{-
+
+ This file is compiled with the GHC flags:
+
+ -O -fbyte-code-and-object-code -fprefer-byte-code
+
+ This makes sure that the Template Haskell runs in the bytecode
+ interpreter with optimized bytecode, allowing us to test the
+ sized unboxed literals.
+
+ Running the test in GHCi directly would disable optimization.
+
+ -}
+
+main :: IO ()
+main = do
+ print $(pure $ ListE [ ie (fibw8 5)
+ , ie (fibw16 5)
+ , ie (fibw32 5)
+ , ie (fibw64 5)
+ ])
+
+ print $(pure $ ListE [ ie (fibi8 5)
+ , ie (fibi16 5)
+ , ie (fibi32 5)
+ , ie (fibi64 5)
+ ])
+
+ print $(pure $ ListE [ ie (branchi8 0)
+ , ie (branchi8 1)
+ , ie (branchi8 (-1))
+ , ie (branchi8 126)
+ , ie (branchi8 127)
+ , ie (branchi8 (-127))
+ , ie (branchi8 (-128))
+ , ie (branchi8 2)
+ ])
+
+ print $(pure $ ListE [ ie (branchi16 0)
+ , ie (branchi16 1)
+ , ie (branchi16 (-1))
+ , ie (branchi16 32767)
+ , ie (branchi16 32766)
+ , ie (branchi16 (-32768))
+ , ie (branchi16 (-32767))
+ , ie (branchi16 2)
+ ])
+
+ print $(pure $ ListE [ ie (branchi32 0)
+ , ie (branchi32 1)
+ , ie (branchi32 (-1))
+ , ie (branchi32 2147483646)
+ , ie (branchi32 2147483647)
+ , ie (branchi32 (-2147483648))
+ , ie (branchi32 (-2147483647))
+ , ie (branchi32 2)
+ ])
+
+ print $(pure $ ListE [ ie (branchi64 0)
+ , ie (branchi64 1)
+ , ie (branchi64 (-1))
+ , ie (branchi64 2147483647)
+ , ie (branchi64 2147483648)
+ , ie (branchi64 4294967297)
+ , ie (branchi64 (-2147483648))
+ , ie (branchi64 (-2147483649))
+ , ie (branchi64 (-4294967295))
+ , ie (branchi64 9223372036854775807)
+ , ie (branchi64 9223372036854775806)
+ , ie (branchi64 (-9223372036854775808))
+ , ie (branchi64 (-9223372036854775807))
+ , ie (branchi64 2)
+ ])
+
+ print $(pure $ ListE [ ie (branchw8 0)
+ , ie (branchw8 1)
+ , ie (branchw8 254)
+ , ie (branchw8 255)
+ , ie (branchw8 2)
+ ])
+
+ print $(pure $ ListE [ ie (branchw16 0)
+ , ie (branchw16 1)
+ , ie (branchw16 255)
+ , ie (branchw16 256)
+ , ie (branchw16 65534)
+ , ie (branchw16 65535)
+ , ie (branchw16 2)
+ ])
+
+ print $(pure $ ListE [ ie (branchw32 0)
+ , ie (branchw32 1)
+ , ie (branchw32 65534)
+ , ie (branchw32 65535)
+ , ie (branchw32 65536)
+ , ie (branchw32 4294967295)
+ , ie (branchw32 4294967294)
+ , ie (branchw32 4294967293)
+ , ie (branchw32 2)
+ ])
+
+ print $(pure $ ListE [ ie (branchw64 0)
+ , ie (branchw64 1)
+ , ie (branchw64 65536)
+ , ie (branchw64 4294967295)
+ , ie (branchw64 4294967296)
+ , ie (branchw64 4294967297)
+ , ie (branchw64 18446744073709551615)
+ , ie (branchw64 18446744073709551614)
+ , ie (branchw64 18446744073709551613)
+ , ie (branchw64 2)
+ ])
\ No newline at end of file
=====================================
testsuite/tests/ghci/should_run/SizedLiterals.stdout
=====================================
@@ -0,0 +1,10 @@
+[5,5,5,5]
+[5,5,5,5]
+[1,2,3,4,5,6,7,0]
+[1,2,3,255,256,65534,65535,0]
+[1,2,3,65535,65536,4294967294,4294967295,0]
+[18446744073709551615,2147483648,4294967296,4294967297,9,1,18446744073709551614,3,4,5,6,7,8,0]
+[1,-1,2,-2,0]
+[256,-256,32767,-32768,-1,1,0]
+[2147483647,-2147483648,65535,65536,-1,-65536,-65537,1,0]
+[9223372036854775807,2147483648,4294967296,4294967297,-1,9223372036854775806,-9223372036854775808,-9223372036854775807,1,0]
=====================================
testsuite/tests/ghci/should_run/SizedLiteralsA.hs
=====================================
@@ -0,0 +1,139 @@
+module SizedLiteralsA where
+
+import GHC.Word
+import GHC.Int
+import Language.Haskell.TH.Syntax
+
+fibw8 :: Word8 -> Word8
+fibw8 0 = 0
+fibw8 1 = 1
+fibw8 n = fibw8 (n-1) + fibw8 (n-2)
+
+fibw16 :: Word16 -> Word16
+fibw16 0 = 0
+fibw16 1 = 1
+fibw16 n = fibw16 (n-1) + fibw16 (n-2)
+
+fibw32 :: Word32 -> Word32
+fibw32 0 = 0
+fibw32 1 = 1
+fibw32 n = fibw32 (n-1) + fibw32 (n-2)
+
+fibw64 :: Word64 -> Word64
+fibw64 0 = 0
+fibw64 1 = 1
+fibw64 n = fibw64 (n-1) + fibw64 (n-2)
+
+--
+
+fibi8 :: Int8 -> Int8
+fibi8 0 = 0
+fibi8 1 = 1
+fibi8 n = fibi8 (n-1) + fibi8 (n-2)
+
+fibi16 :: Int16 -> Int16
+fibi16 0 = 0
+fibi16 1 = 1
+fibi16 n = fibi16 (n-1) + fibi16 (n-2)
+
+fibi32 :: Int32 -> Int32
+fibi32 0 = 0
+fibi32 1 = 1
+fibi32 n = fibi32 (n-1) + fibi32 (n-2)
+
+fibi64 :: Int64 -> Int64
+fibi64 0 = 0
+fibi64 1 = 1
+fibi64 n = fibi64 (n-1) + fibi64 (n-2)
+
+--
+
+branchi8 :: Int8 -> Word8
+branchi8 0 = 1
+branchi8 1 = 2
+branchi8 (-1) = 3
+branchi8 126 = 4
+branchi8 127 = 5
+branchi8 (-127) = 6
+branchi8 (-128) = 7
+branchi8 _ = 0
+
+branchi16 :: Int16 -> Word16
+branchi16 0 = 1
+branchi16 1 = 2
+branchi16 (-1) = 3
+branchi16 32767 = 255
+branchi16 32766 = 256
+branchi16 (-32768) = 65534
+branchi16 (-32767) = 65535
+branchi16 _ = 0
+
+branchi32 :: Int32 -> Word32
+branchi32 0 = 1
+branchi32 1 = 2
+branchi32 (-1) = 3
+branchi32 2147483646 = 65535
+branchi32 2147483647 = 65536
+branchi32 (-2147483648) = 4294967294
+branchi32 (-2147483647) = 4294967295
+branchi32 _ = 0
+
+branchi64 :: Int64 -> Word64
+branchi64 0 = 18446744073709551615
+branchi64 1 = 2147483648
+branchi64 (-1) = 4294967296
+branchi64 2147483647 = 4294967297
+branchi64 2147483648 = 9
+branchi64 4294967297 = 1
+branchi64 (-2147483648) = 18446744073709551614
+branchi64 (-2147483649) = 3
+branchi64 (-4294967295) = 4
+branchi64 9223372036854775807 = 5
+branchi64 9223372036854775806 = 6
+branchi64 (-9223372036854775808) = 7
+branchi64 (-9223372036854775807) = 8
+branchi64 _ = 0
+
+branchw8 :: Word8 -> Int8
+branchw8 0 = 1
+branchw8 1 = (-1)
+branchw8 254 = 2
+branchw8 255 = (-2)
+branchw8 _ = 0
+
+branchw16 :: Word16 -> Int16
+branchw16 0 = 256
+branchw16 1 = (-256)
+branchw16 255 = 32767
+branchw16 256 = (-32768)
+branchw16 65534 = (-1)
+branchw16 65535 = 1
+branchw16 _ = 0
+
+branchw32 :: Word32 -> Int32
+branchw32 0 = 2147483647
+branchw32 1 = (-2147483648)
+branchw32 65534 = 65535
+branchw32 65535 = 65536
+branchw32 65536 = (-1)
+branchw32 4294967295 = (-65536)
+branchw32 4294967294 = (-65537)
+branchw32 4294967293 = 1
+branchw32 _ = 0
+
+branchw64 :: Word64 -> Int64
+branchw64 0 = 9223372036854775807
+branchw64 1 = 2147483648
+branchw64 65536 = 4294967296
+branchw64 4294967295 = 4294967297
+branchw64 4294967296 = (-1)
+branchw64 4294967297 = 9223372036854775806
+branchw64 18446744073709551615 = (-9223372036854775808)
+branchw64 18446744073709551614 = (-9223372036854775807)
+branchw64 18446744073709551613 = 1
+branchw64 _ = 0
+
+--
+
+ie :: Integral a => a -> Exp
+ie x = LitE (IntegerL (toInteger x))
=====================================
testsuite/tests/ghci/should_run/all.T
=====================================
@@ -85,3 +85,5 @@ test('T19628', [extra_files(['T19628a.hs']), only_ways(['ghci']) ], compile_and_
test('T21052', just_ghci, ghci_script, ['T21052.script'])
test('T21300', just_ghci, ghci_script, ['T21300.script'])
test('UnliftedDataType2', just_ghci, compile_and_run, [''])
+test('SizedLiterals', [req_interp, extra_files(["SizedLiteralsA.hs"]),extra_hc_opts("-O -fbyte-code-and-object-code -fprefer-byte-code")], compile_and_run, [''])
+
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/28f8c0ebbfe623784988745af75dcf3fdbdd3ca5
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/28f8c0ebbfe623784988745af75dcf3fdbdd3ca5
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/20230106/94c66e4d/attachment-0001.html>
More information about the ghc-commits
mailing list