[Git][ghc/ghc][wip/bgamari/sized] 2 commits: Constant folding for extend/narrow
Ben Gamari
gitlab at gitlab.haskell.org
Tue Nov 3 00:39:08 UTC 2020
Ben Gamari pushed to branch wip/bgamari/sized at Glasgow Haskell Compiler / GHC
Commits:
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
- - - - -
4 changed files:
- compiler/GHC/Core/Opt/ConstantFold.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/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/92c9c27937704e8e1aea19a12ae01b4eeb268964...41ee3db93a80125162d66a756d43c6f4854d1613
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/92c9c27937704e8e1aea19a12ae01b4eeb268964...41ee3db93a80125162d66a756d43c6f4854d1613
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/9862f87f/attachment-0001.html>
More information about the ghc-commits
mailing list