[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