[Git][ghc/ghc][wip/angerman/sized] 4 commits: CodeToByteCode: Fix handling of narrow datacon fields
Moritz Angermann
gitlab at gitlab.haskell.org
Tue Nov 3 01:49:40 UTC 2020
Moritz Angermann pushed to branch wip/angerman/sized at Glasgow Haskell Compiler / GHC
Commits:
7a15e68f by Ben Gamari at 2020-11-02T16:03:55-05:00
CodeToByteCode: Fix handling of narrow datacon fields
Handle the non-word-size cases specifically and emit the appropriate
bytecode instructions.
- - - - -
f6fb87a1 by Ben Gamari at 2020-11-02T19:39:00-05:00
Constant folding for extend/narrow
- - - - -
41ee3db9 by Ben Gamari at 2020-11-02T19:39:00-05:00
StgToCmm: Normalize padding
- - - - -
0c51530e by Moritz Angermann at 2020-11-03T01:49:08+00:00
Merge remote-tracking branch 'origin/wip/bgamari/sized' into wip/angerman/sized
- - - - -
5 changed files:
- compiler/GHC/Core/Opt/ConstantFold.hs
- compiler/GHC/CoreToByteCode.hs
- compiler/GHC/StgToCmm/DataCon.hs
- compiler/GHC/Types/Literal.hs
- testsuite/tests/simplCore/should_compile/T8832.stdout
Changes:
=====================================
compiler/GHC/Core/Opt/ConstantFold.hs
=====================================
@@ -199,40 +199,34 @@ primOpRules nm = \case
-- coercions
- Int8ExtendOp -> mkPrimOpRule nm 1 [ do [Var primop_id `App` e] <- getArgs
- matchPrimOpId Int8NarrowOp primop_id
- return (Var (mkPrimOpId Narrow8IntOp) `App` e) ]
- Int16ExtendOp -> mkPrimOpRule nm 1 [ do [Var primop_id `App` e] <- getArgs
- matchPrimOpId Int16NarrowOp primop_id
- return (Var (mkPrimOpId Narrow16IntOp) `App` e) ]
- Int32ExtendOp -> mkPrimOpRule nm 1 [ do [Var primop_id `App` e] <- getArgs
- matchPrimOpId Int32NarrowOp primop_id
- return (Var (mkPrimOpId Narrow32IntOp) `App` e) ]
- Int8NarrowOp -> mkPrimOpRule nm 1 [ subsumedByPrimOp Int8NarrowOp
+ Int8ExtendOp -> mkPrimOpRule nm 1 [ liftLitPlatform extendIntLit ]
+ Int16ExtendOp -> mkPrimOpRule nm 1 [ liftLitPlatform extendIntLit ]
+ Int32ExtendOp -> mkPrimOpRule nm 1 [ liftLitPlatform extendIntLit ]
+ Int8NarrowOp -> mkPrimOpRule nm 1 [ liftLit narrowInt8Lit
+ , subsumedByPrimOp Int8NarrowOp
, narrowSubsumesAnd AndIOp Int8NarrowOp 8 ]
- Int16NarrowOp -> mkPrimOpRule nm 1 [ subsumedByPrimOp Int8NarrowOp
+ Int16NarrowOp -> mkPrimOpRule nm 1 [ liftLit narrowInt16Lit
+ , subsumedByPrimOp Int8NarrowOp
, subsumedByPrimOp Int16NarrowOp
, narrowSubsumesAnd AndIOp Int16NarrowOp 16 ]
- Int32NarrowOp -> mkPrimOpRule nm 1 [ subsumedByPrimOp Int8NarrowOp
+ Int32NarrowOp -> mkPrimOpRule nm 1 [ liftLit narrowInt32Lit
+ , subsumedByPrimOp Int8NarrowOp
, subsumedByPrimOp Int16NarrowOp
, subsumedByPrimOp Int32NarrowOp
, narrowSubsumesAnd AndIOp Int32NarrowOp 32 ]
- Word8ExtendOp -> mkPrimOpRule nm 1 [ do [Var primop_id `App` e] <- getArgs
- matchPrimOpId Word8NarrowOp primop_id
- return (Var (mkPrimOpId Narrow8WordOp) `App` e) ]
- Word16ExtendOp -> mkPrimOpRule nm 1 [ do [Var primop_id `App` e] <- getArgs
- matchPrimOpId Word16NarrowOp primop_id
- return (Var (mkPrimOpId Narrow16WordOp) `App` e) ]
- Word32ExtendOp -> mkPrimOpRule nm 1 [ do [Var primop_id `App` e] <- getArgs
- matchPrimOpId Word32NarrowOp primop_id
- return (Var (mkPrimOpId Narrow32WordOp) `App` e) ]
- Word8NarrowOp -> mkPrimOpRule nm 1 [ subsumedByPrimOp Word8NarrowOp
+ Word8ExtendOp -> mkPrimOpRule nm 1 [ liftLitPlatform extendWordLit ]
+ Word16ExtendOp -> mkPrimOpRule nm 1 [ liftLitPlatform extendWordLit ]
+ Word32ExtendOp -> mkPrimOpRule nm 1 [ liftLitPlatform extendWordLit ]
+ Word8NarrowOp -> mkPrimOpRule nm 1 [ liftLit narrowWord8Lit
+ , subsumedByPrimOp Word8NarrowOp
, narrowSubsumesAnd AndOp Word8NarrowOp 8 ]
- Word16NarrowOp -> mkPrimOpRule nm 1 [ subsumedByPrimOp Word8NarrowOp
+ Word16NarrowOp -> mkPrimOpRule nm 1 [ liftLit narrowWord16Lit
+ , subsumedByPrimOp Word8NarrowOp
, subsumedByPrimOp Word16NarrowOp
, narrowSubsumesAnd AndOp Word16NarrowOp 16 ]
- Word32NarrowOp -> mkPrimOpRule nm 1 [ subsumedByPrimOp Word8NarrowOp
+ Word32NarrowOp -> mkPrimOpRule nm 1 [ liftLit narrowWord32Lit
+ , subsumedByPrimOp Word8NarrowOp
, subsumedByPrimOp Word16NarrowOp
, subsumedByPrimOp Word32NarrowOp
, narrowSubsumesAnd AndOp Word32NarrowOp 32 ]
=====================================
compiler/GHC/CoreToByteCode.hs
=====================================
@@ -1633,30 +1633,39 @@ pushAtom d p (AnnVar var)
pushAtom _ _ (AnnLit lit) = do
platform <- targetPlatform <$> getDynFlags
- let code rep
- = let size_words = WordOff (argRepSizeW platform rep)
- in return (unitOL (PUSH_UBX lit (trunc16W size_words)),
- wordsToBytes platform size_words)
+ let code :: PrimRep -> BcM (BCInstrList, ByteOff)
+ code rep =
+ return (unitOL instr, size_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.
+ instr =
+ case size_bytes of
+ 1 -> PUSH_UBX8 lit
+ 2 -> PUSH_UBX16 lit
+ 4 -> PUSH_UBX32 lit
+ _ -> PUSH_UBX lit (trunc16W $ bytesToWords platform size_bytes)
case lit of
- LitLabel _ _ _ -> code N
- LitFloat _ -> code F
- LitDouble _ -> code D
- LitChar _ -> code N
- LitNullAddr -> code N
- LitString _ -> code N
- LitRubbish -> code N
+ LitLabel _ _ _ -> code AddrRep
+ LitFloat _ -> code FloatRep
+ LitDouble _ -> code DoubleRep
+ LitChar _ -> code WordRep
+ LitNullAddr -> code AddrRep
+ LitString _ -> code AddrRep
+ LitRubbish -> code WordRep
LitNumber nt _ -> case nt of
- LitNumInt -> code N
- LitNumWord -> code N
- LitNumInt8 -> code (toArgRep Int8Rep)
- LitNumWord8 -> code (toArgRep Word8Rep)
- LitNumInt16 -> code (toArgRep Int16Rep)
- LitNumWord16 -> code (toArgRep Word16Rep)
- LitNumInt32 -> code (toArgRep Int32Rep)
- LitNumWord32 -> code (toArgRep Word32Rep)
- LitNumInt64 -> code L
- LitNumWord64 -> code L
+ LitNumInt -> code IntRep
+ LitNumWord -> code WordRep
+ LitNumInt8 -> code Int8Rep
+ LitNumWord8 -> code Word8Rep
+ LitNumInt16 -> code Int16Rep
+ LitNumWord16 -> code Word16Rep
+ LitNumInt32 -> code Int32Rep
+ LitNumWord32 -> code Word32Rep
+ LitNumInt64 -> code Int64Rep
+ LitNumWord64 -> code Word64Rep
-- No LitInteger's or LitNatural's should be left by the time this is
-- called. CorePrep should have converted them all to a real core
-- representation.
=====================================
compiler/GHC/StgToCmm/DataCon.hs
=====================================
@@ -102,6 +102,21 @@ cgTopRhsCon dflags id con args
nv_args_w_offsets) =
mkVirtHeapOffsetsWithPadding profile StdHeader (addArgReps args)
+ ; let
+ -- Decompose padding into units of length 8, 4, 2, or 1 bytes to
+ -- allow the implementation of mk_payload to use widthFromBytes,
+ -- which only handles these cases.
+ fix_padding (x@(Padding n off) : rest)
+ | n == 0 = fix_padding rest
+ | n `elem` [1,2,4,8] = x : fix_padding rest
+ | n > 8 = add_pad 8
+ | n > 4 = add_pad 4
+ | n > 2 = add_pad 2
+ | otherwise = add_pad 1
+ where add_pad m = Padding m off : fix_padding (Padding (n-m) (off+m) : rest)
+ fix_padding (x : rest) = x : fix_padding rest
+ fix_padding [] = []
+
mk_payload (Padding len _) = return (CmmInt 0 (widthFromBytes len))
mk_payload (FieldOff arg _) = do
amode <- getArgAmode arg
@@ -117,7 +132,7 @@ cgTopRhsCon dflags id con args
info_tbl = mkDataConInfoTable profile con True ptr_wds nonptr_wds
- ; payload <- mapM mk_payload nv_args_w_offsets
+ ; payload <- mapM mk_payload (fix_padding nv_args_w_offsets)
-- NB1: nv_args_w_offsets is sorted into ptrs then non-ptrs
-- NB2: all the amodes should be Lits!
-- TODO (osa): Why?
=====================================
compiler/GHC/Types/Literal.hs
=====================================
@@ -46,9 +46,11 @@ module GHC.Types.Literal
-- ** Coercions
, wordToIntLit, intToWordLit
- , narrowLit
, narrow8IntLit, narrow16IntLit, narrow32IntLit
, narrow8WordLit, narrow16WordLit, narrow32WordLit
+ , narrowInt8Lit, narrowInt16Lit, narrowInt32Lit
+ , narrowWord8Lit, narrowWord16Lit, narrowWord32Lit
+ , extendIntLit, extendWordLit
, int8Lit, int16Lit, int32Lit
, word8Lit, word16Lit, word32Lit
, charToIntLit, intToCharLit
@@ -614,16 +616,33 @@ intToWordLit platform (LitNumber LitNumInt i)
intToWordLit _ l = pprPanic "intToWordLit" (ppr l)
-- | Narrow a literal number (unchecked result range)
-narrowLit :: forall a. Integral a => Proxy a -> Literal -> Literal
-narrowLit _ (LitNumber nt i) = LitNumber nt (toInteger (fromInteger i :: a))
-narrowLit _ l = pprPanic "narrowLit" (ppr l)
-
-narrow8IntLit = narrowLit (Proxy :: Proxy Int8)
-narrow16IntLit = narrowLit (Proxy :: Proxy Int16)
-narrow32IntLit = narrowLit (Proxy :: Proxy Int32)
-narrow8WordLit = narrowLit (Proxy :: Proxy Word8)
-narrow16WordLit = narrowLit (Proxy :: Proxy Word16)
-narrow32WordLit = narrowLit (Proxy :: Proxy Word32)
+narrowLit' :: forall a. Integral a => Proxy a -> LitNumType -> Literal -> Literal
+narrowLit' _ nt' (LitNumber _ i) = LitNumber nt' (toInteger (fromInteger i :: a))
+narrowLit' _ _ l = pprPanic "narrowLit" (ppr l)
+
+narrow8IntLit = narrowLit' (Proxy :: Proxy Int8) LitNumInt
+narrow16IntLit = narrowLit' (Proxy :: Proxy Int16) LitNumInt
+narrow32IntLit = narrowLit' (Proxy :: Proxy Int32) LitNumInt
+narrow8WordLit = narrowLit' (Proxy :: Proxy Word8) LitNumWord
+narrow16WordLit = narrowLit' (Proxy :: Proxy Word16) LitNumWord
+narrow32WordLit = narrowLit' (Proxy :: Proxy Word32) LitNumWord
+
+narrowInt8Lit, narrowInt16Lit, narrowInt32Lit,
+ narrowWord8Lit, narrowWord16Lit, narrowWord32Lit :: Literal -> Literal
+narrowInt8Lit = narrowLit' (Proxy :: Proxy Int8) LitNumInt8
+narrowInt16Lit = narrowLit' (Proxy :: Proxy Int16) LitNumInt16
+narrowInt32Lit = narrowLit' (Proxy :: Proxy Int32) LitNumInt32
+narrowWord8Lit = narrowLit' (Proxy :: Proxy Word8) LitNumWord8
+narrowWord16Lit = narrowLit' (Proxy :: Proxy Word16) LitNumWord16
+narrowWord32Lit = narrowLit' (Proxy :: Proxy Word32) LitNumWord32
+
+-- | Extend a fixed-width literal (e.g. 'Int16#') to a word-sized literal (e.g.
+-- 'Int#').
+extendWordLit, extendIntLit :: Platform -> Literal -> Literal
+extendWordLit platform (LitNumber _nt i) = mkLitWord platform i
+extendWordLit _platform l = pprPanic "extendWordLit" (ppr l)
+extendIntLit platform (LitNumber _nt i) = mkLitInt platform i
+extendIntLit _platform l = pprPanic "extendIntLit" (ppr l)
int8Lit (LitNumber _ i) = mkLitInt8 i
int8Lit l = pprPanic "int8Lit" (ppr l)
=====================================
testsuite/tests/simplCore/should_compile/T8832.stdout
=====================================
@@ -1,11 +1,11 @@
i = GHC.Types.I# 0#
-i8 = GHC.Int.I8# (GHC.Prim.narrowInt8# 0#)
-i16 = GHC.Int.I16# (GHC.Prim.narrowInt16# 0#)
-i32 = GHC.Int.I32# (GHC.Prim.narrowInt32# 0#)
+i8 = GHC.Int.I8# 0#8
+i16 = GHC.Int.I16# 0#16
+i32 = GHC.Int.I32# 0#32
i64 = GHC.Int.I64# 0#
w = GHC.Types.W# 0##
-w8 = GHC.Word.W8# (GHC.Prim.narrowWord8# 0##)
-w16 = GHC.Word.W16# (GHC.Prim.narrowWord16# 0##)
-w32 = GHC.Word.W32# (GHC.Prim.narrowWord32# 0##)
+w8 = GHC.Word.W8# 0##8
+w16 = GHC.Word.W16# 0##16
+w32 = GHC.Word.W32# 0##32
w64 = GHC.Word.W64# 0##
z = 0
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f42424ad9b7daacce022c5d0d46553afae45e361...0c51530e2b951a97d2fb4fd93daa7af94e9b3604
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f42424ad9b7daacce022c5d0d46553afae45e361...0c51530e2b951a97d2fb4fd93daa7af94e9b3604
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/20201102/080e06c1/attachment-0001.html>
More information about the ghc-commits
mailing list