Commit 2783d498 authored by Luite Stegeman's avatar Luite Stegeman Committed by Marge Bot

fix sub-word literals in GHCi

parent 5db116e9
Pipeline #33972 canceled with stages
in 32 seconds
......@@ -327,7 +327,8 @@ bytesToWords platform (ByteOff bytes) =
let (q, r) = bytes `quotRem` (platformWordSizeInBytes platform)
in if r == 0
then fromIntegral q
else panic $ "GHC.StgToByteCode.bytesToWords: bytes=" ++ show bytes
else pprPanic "GHC.StgToByteCode.bytesToWords"
(text "bytes=" <> ppr bytes)
wordSize :: Platform -> ByteOff
wordSize platform = ByteOff (platformWordSizeInBytes platform)
......@@ -922,7 +923,7 @@ mkConAppCode orig_d _ p con args = app_code
do_pushery !d (arg : args) = do
(push, arg_bytes) <- case arg of
(Padding l _) -> return $! pushPadding l
(Padding l _) -> return $! pushPadding (ByteOff l)
(FieldOff a _) -> pushConstrAtom d p (fromNonVoid a)
more_push_code <- do_pushery (d + arg_bytes) args
return (push `appOL` more_push_code)
......@@ -1845,7 +1846,8 @@ pushAtom d p (StgVarArg var)
_ -> do
let !szw = bytesToWords platform szb
!off_w = trunc16W $ bytesToWords platform (d - d_v) + szw - 1
return (toOL (genericReplicate szw (PUSH_L off_w)), szb)
return (toOL (genericReplicate szw (PUSH_L off_w)),
wordsToBytes platform szw)
-- d - d_v offset from TOS to the first slot of the object
--
-- d - d_v + sz - 1 offset from the TOS of the last slot of the object
......@@ -1864,15 +1866,31 @@ pushAtom d p (StgVarArg var)
MASSERT( sz == wordSize platform )
return (unitOL (PUSH_G (getName var)), sz)
pushAtom _ _ (StgLitArg lit) = do
pushAtom _ _ (StgLitArg lit) = pushLiteral True lit
pushLiteral :: Bool -> Literal -> BcM (BCInstrList, ByteOff)
pushLiteral padded lit =
do
platform <- targetPlatform <$> getDynFlags
let code :: PrimRep -> BcM (BCInstrList, ByteOff)
code rep =
return (unitOL instr, size_bytes)
return (padding_instr `snocOL` instr, size_bytes + padding_bytes)
where
size_bytes = ByteOff $ primRepSizeB platform rep
-- Here we handle the non-word-width cases specifically since we
-- must emit different bytecode for them.
round_to_words (ByteOff bytes) =
ByteOff (roundUpToWords platform bytes)
padding_bytes
| padded = round_to_words size_bytes - size_bytes
| otherwise = 0
(padding_instr, _) = pushPadding padding_bytes
instr =
case size_bytes of
1 -> PUSH_UBX8 lit
......@@ -1910,8 +1928,7 @@ pushAtom _ _ (StgLitArg lit) = do
-- packing constructor fields. See also @mkConAppCode@ and @pushPadding@.
pushConstrAtom
:: StackDepth -> BCEnv -> StgArg -> BcM (BCInstrList, ByteOff)
pushConstrAtom _ _ (StgLitArg lit@(LitFloat _)) =
return (unitOL (PUSH_UBX32 lit), 4)
pushConstrAtom _ _ (StgLitArg lit) = pushLiteral False lit
pushConstrAtom d p va@(StgVarArg v)
| Just d_v <- lookupBCEnv_maybe v p = do -- v is a local variable
......@@ -1928,8 +1945,8 @@ pushConstrAtom d p va@(StgVarArg v)
pushConstrAtom d p expr = pushAtom d p expr
pushPadding :: Int -> (BCInstrList, ByteOff)
pushPadding !n = go n (nilOL, 0)
pushPadding :: ByteOff -> (BCInstrList, ByteOff)
pushPadding (ByteOff n) = go n (nilOL, 0)
where
go n acc@(!instrs, !off) = case n of
0 -> acc
......
{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-}
{-# OPTIONS_GHC -fbyte-code #-}
module ByteCode where
import GHC.Exts
import GHC.Word
import GHC.Int
import Types
#include "Common.hs-incl"
d1w8 :: Word8 -> D1
d1w8 (W8# x) = D1w8 x
d1i8 :: Int8 -> D1
d1i8 (I8# x) = D1i8 x
d1w16 :: Word16 -> D1
d1w16 (W16# x) = D1w16 x
d1i16 :: Int16 -> D1
d1i16 (I16# x) = D1i16 x
d1w32 :: Word32 -> D1
d1w32 (W32# x) = D1w32 x
d1i32 :: Int32 -> D1
d1i32 (I32# x) = D1i32 x
showD1 :: D1 -> String
showD1 (D1w8 x) = show (W8# x)
showD1 (D1i8 x) = show (I8# x)
showD1 (D1w16 x) = show (W16# x)
showD1 (D1i16 x) = show (I16# x)
showD1 (D1w32 x) = show (W32# x)
showD1 (D1i32 x) = show (I32# x)
d2a :: Word8 -> Word8 -> D2
d2a (W8# x1) (W8# x2) = D2a x1 x2
d2b :: Word8 -> Word16 -> D2
d2b (W8# x1) (W16# x2) = D2b x1 x2
d2c :: Word8 -> Word16 -> Word8 -> D2
d2c (W8# x1) (W16# x2) (W8# x3)= D2c x1 x2 x3
d2d :: Word -> Word8 -> Word -> D2
d2d (W# x1) (W8# x2) (W# x3) = D2d x1 x2 x3
d2e :: Word -> Int8 -> Double -> Float -> Word8 -> D2
d2e (W# x1) (I8# x2) (D# x3) (F# x4) (W8# x5) = D2e x1 x2 x3 x4 x5
d2l :: Int -> D2
d2l 0 = D2a (wordToWord8# 44##) (wordToWord8# 55##)
d2l 1 = D2b (wordToWord8# 44##) (wordToWord16# 55##)
d2l 2 = D2c (wordToWord8# 44##) (wordToWord16# 5555##) (wordToWord8# 66##)
d2l 3 = D2d 5555## (wordToWord8# 66##) 7777##
d2l _ = D2e 7777## (intToInt8# 66#) 55.55## 44.44# (wordToWord8# 33##)
showD2 :: D2 -> String
showD2 (D2a x1 x2) = show (W8# x1, W8# x2)
showD2 (D2b x1 x2) = show (W8# x1, W16# x2)
showD2 (D2c x1 x2 x3) = show (W8# x1, W16# x2, W8# x3)
showD2 (D2d x1 x2 x3) = show (W# x1, W8# x2, W# x3)
showD2 (D2e x1 x2 x3 x4 x5) = show (W# x1, I8# x2, D# x3, F# x4, W8# x5)
-- unboxed function arguments
type F1 = Int8# -> Float# -> Word16# -> Double# -> Word32# -> Word8# -> (Int8, Float, Word16, Double, Word32, Word8)
f1 :: F1
f1 x1 x2 x3 x4 x5 x6 = (I8# x1, F# x2, W16# x3, D# x4, W32# x5, W8# x6)
f1a :: Word8# -> F1
f1a x0 x1 x2 x3 x4 x5 x6 = (I8# x1, F# x2, W16# x3, D# x4, W32# x5, W8# x0)
f1a_app :: (Word8# -> F1) -> F1
f1a_app f = f (wordToWord8# 77##)
f1_show :: F1 -> String
f1_show f = show $ f (intToInt8# 123#)
456.789#
(wordToWord16# 8765##)
123.456##
(wordToWord32# 12345678##)
(wordToWord8# 33##)
-- unboxed return values of various sizes
type U1 = Int8 -> Int8#
unboxed1 :: U1
unboxed1 0 = intToInt8# 11#
unboxed1 _ = intToInt8# 13#
unboxed1_a :: U1 -> Int8 -> Int8
unboxed1_a f x = case f x of x1 -> I8# x1
type U2 = Word16 -> Word16#
unboxed2 :: U2
unboxed2 0 = wordToWord16# 1111##
unboxed2 _ = wordToWord16# 1333##
unboxed2_a :: U2 -> Word16 -> Word16
unboxed2_a f x = case f x of x1 -> W16# x1
type U3 = Word16 -> Float#
unboxed3 :: U3
unboxed3 0 = 55.55#
unboxed3 _ = 77.77#
unboxed3_a :: U3 -> Word16 -> Float
unboxed3_a f x = case f x of x1 -> F# x1
-- unboxed tuple
type T1 = Int -> (# Int8#, Word16#, Float#, Int #)
tuple1 :: T1
tuple1 x = (# intToInt8# 66#, wordToWord16# 7777##, 99.99#, x #)
tuple1_a :: T1 -> Int -> (Int8, Word16, Float, Int)
tuple1_a f x =
case f x of (# x1, x2, x3, x4 #) -> (I8# x1, W16# x2, F# x3, x4)
{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-}
{-# OPTIONS_GHC -fobject-code #-}
module Obj where
import GHC.Exts
import GHC.Word
import GHC.Int
import Types
#include "Common.hs-incl"
{-# OPTIONS_GHC -fbyte-code #-}
{-
Test constructor packing in GHCi with unboxed fields of various sizes
-}
module Main where
import qualified Obj as O
import qualified ByteCode as B
import GHC.Exts
import GHC.Word
main :: IO ()
main = do
-- pack a single field
testX "D1w8" B.showD1 O.showD1 B.d1w8 O.d1w8 (\f -> f 33)
testX "D1i8" B.showD1 O.showD1 B.d1i8 O.d1i8 (\f -> f 33)
testX "D1w16" B.showD1 O.showD1 B.d1w16 O.d1w16 (\f -> f 3333)
testX "D1i16" B.showD1 O.showD1 B.d1i16 O.d1i16 (\f -> f 3333)
testX "D1w32" B.showD1 O.showD1 B.d1w32 O.d1w32 (\f -> f 33333333)
testX "D1i32" B.showD1 O.showD1 B.d1i32 O.d1i32 (\f -> f 33333333)
-- pack multiple fields
testX "D2a" B.showD2 O.showD2 B.d2a O.d2a (\f -> f 44 55)
testX "D2b" B.showD2 O.showD2 B.d2b O.d2b (\f -> f 44 55)
testX "D2c" B.showD2 O.showD2 B.d2c O.d2c (\f -> f 44 5555 66)
testX "D2d" B.showD2 O.showD2 B.d2d O.d2d (\f -> f 5555 66 7777)
testX "D2e" B.showD2 O.showD2 B.d2e O.d2e (\f -> f 7777 66 55.55 44.44 33)
-- pack multiple fields from literals
testX "D2l 0" B.showD2 O.showD2 B.d2l O.d2l (\f -> f 0)
testX "D2l 1" B.showD2 O.showD2 B.d2l O.d2l (\f -> f 1)
testX "D2l 2" B.showD2 O.showD2 B.d2l O.d2l (\f -> f 2)
testX "D2l 3" B.showD2 O.showD2 B.d2l O.d2l (\f -> f 3)
testX "D2l 4" B.showD2 O.showD2 B.d2l O.d2l (\f -> f 4)
-- function arguments, not packed
testX' "f1 " B.f1_show O.f1_show B.f1 O.f1
testX' "f1a" B.f1_show O.f1_show (B.f1a_app B.f1a) (B.f1a_app B.f1a)
testX' "f1b" B.f1_show O.f1_show (B.f1a_app O.f1a) (B.f1a_app B.f1a)
testX' "f1c" B.f1_show O.f1_show (O.f1a_app B.f1a) (B.f1a_app B.f1a)
testX' "f1d" B.f1_show O.f1_show (O.f1a_app O.f1a) (B.f1a_app B.f1a)
-- unboxed return values and tuples
testX'' "unboxed1 0" B.unboxed1_a O.unboxed1_a B.unboxed1 O.unboxed1 (\f -> f 0)
testX'' "unboxed1 1" B.unboxed1_a O.unboxed1_a B.unboxed1 O.unboxed1 (\f -> f 1)
testX'' "unboxed2 0" B.unboxed2_a O.unboxed2_a B.unboxed2 O.unboxed2 (\f -> f 0)
testX'' "unboxed2 1" B.unboxed2_a O.unboxed2_a B.unboxed2 O.unboxed2 (\f -> f 1)
testX'' "unboxed3 0" B.unboxed3_a O.unboxed3_a B.unboxed3 O.unboxed3 (\f -> f 0)
testX'' "unboxed3 1" B.unboxed3_a O.unboxed3_a B.unboxed3 O.unboxed3 (\f -> f 1)
testX'' "tuple1" B.tuple1_a O.tuple1_a B.tuple1 O.tuple1 (\f -> f 3)
testX :: (Eq a, Show a)
=> String -> (p -> a) -> (p -> a) -> f -> f -> (f -> p) -> IO ()
testX msg a1 a2 b1 b2 ap =
let (r:rs) = [f (ap g) | f <- [a1,a2], g <- [b1,b2]]
in putStrLn (msg ++ " " ++ (show $ all (==r) rs) ++ " " ++ show r)
testX' :: String -> (f -> String) -> (f -> String) -> f -> f -> IO ()
testX' msg a1 a2 b1 b2 =
let (r:rs) = [f g | f <- [a1,a2], g <- [b1,b2]]
in putStrLn (msg ++ " " ++ (show $ all (==r) rs) ++ " " ++ show r)
testX'' :: (Eq a, Show a)
=> String -> (p -> t) -> (p -> t) -> p -> p -> (t -> a) -> IO ()
testX'' msg a1 a2 b1 b2 ap =
let (r:rs) = [ap (f g) | f <- [a1,a2], g <- [b1,b2]]
in putStrLn (msg ++ " " ++ (show $ all (==r) rs) ++ " " ++ show r)
D1w8 True "33"
D1i8 True "33"
D1w16 True "3333"
D1i16 True "3333"
D1w32 True "33333333"
D1i32 True "33333333"
D2a True "(44,55)"
D2b True "(44,55)"
D2c True "(44,5555,66)"
D2d True "(5555,66,7777)"
D2e True "(7777,66,55.55,44.44,33)"
D2l 0 True "(44,55)"
D2l 1 True "(44,55)"
D2l 2 True "(44,5555,66)"
D2l 3 True "(5555,66,7777)"
D2l 4 True "(7777,66,55.55,44.44,33)"
f1 True "(123,456.789,8765,123.456,12345678,33)"
f1a True "(123,456.789,8765,123.456,12345678,77)"
f1b True "(123,456.789,8765,123.456,12345678,77)"
f1c True "(123,456.789,8765,123.456,12345678,77)"
f1d True "(123,456.789,8765,123.456,12345678,77)"
unboxed1 0 True 11
unboxed1 1 True 13
unboxed2 0 True 1111
unboxed2 1 True 1333
unboxed3 0 True 55.55
unboxed3 1 True 77.77
tuple1 True (66,7777,99.99,3)
\ No newline at end of file
{-# LANGUAGE MagicHash #-}
{-# OPTIONS_GHC -fobject-code #-}
module Types where
import GHC.Exts
import GHC.Int
import GHC.Word
data D1 = D1w8 Word8#
| D1i8 Int8#
| D1w16 Word16#
| D1i16 Int16#
| D1w32 Word32#
| D1i32 Int32#
data D2 = D2a Word8# Word8#
| D2b Word8# Word16#
| D2c Word8# Word16# Word8#
| D2d Word# Word8# Word#
| D2e Word# Int8# Double# Float# Word8#
test('PackedDataCon',
[ extra_files(['Obj.hs', 'ByteCode.hs', 'Types.hs', 'Common.hs-incl']),
req_interp,
extra_ways(['ghci']),
when(config.have_ext_interp, extra_ways(['ghci', 'ghci-ext'])),
when(config.have_ext_interp and config.have_profiling, extra_ways(['ghci', 'ghci-ext', 'ghci-ext-prof']))
],
compile_and_run,
['']
)
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment