[Git][ghc/ghc][wip/sized-literals-deriving] Change 'deriving Show' to use extended literals

Krzysztof Gogolewski (@monoidal) gitlab at gitlab.haskell.org
Thu Jun 29 23:24:56 UTC 2023



Krzysztof Gogolewski pushed to branch wip/sized-literals-deriving at Glasgow Haskell Compiler / GHC


Commits:
7f4cc96b by Krzysztof Gogolewski at 2023-06-30T01:24:37+02:00
Change 'deriving Show' to use extended literals

Also add support for Int64 and Word64.

- - - - -


3 changed files:

- compiler/GHC/Tc/Deriv/Generate.hs
- testsuite/tests/primops/should_run/ShowPrim.hs
- testsuite/tests/primops/should_run/ShowPrim.stdout


Changes:

=====================================
compiler/GHC/Tc/Deriv/Generate.hs
=====================================
@@ -1282,8 +1282,7 @@ gen_Show_binds get_fixity loc dit@(DerivInstTys{ dit_rep_tc = tycon
              show_arg b arg_ty
                  | isUnliftedType arg_ty
                  -- See Note [Deriving and unboxed types] in GHC.Tc.Deriv.Infer
-                 = with_conv $
-                    nlHsApps compose_RDR
+                 = nlHsApps compose_RDR
                         [mk_shows_app boxed_arg, mk_showString_app postfixMod]
                  | otherwise
                  = mk_showsPrec_app arg_prec arg
@@ -1291,14 +1290,6 @@ gen_Show_binds get_fixity loc dit@(DerivInstTys{ dit_rep_tc = tycon
                  arg        = nlHsVar b
                  boxed_arg  = box "Show" arg arg_ty
                  postfixMod = assoc_ty_id "Show" postfixModTbl arg_ty
-                 with_conv expr
-                    | (Just conv) <- assoc_ty_id_maybe primConvTbl arg_ty =
-                        nested_compose_Expr
-                            [ mk_showString_app ("(" ++ conv ++ " ")
-                            , expr
-                            , mk_showString_app ")"
-                            ]
-                    | otherwise = expr
 
                 -- Fixity stuff
              is_infix = dataConIsInfix data_con
@@ -1514,9 +1505,8 @@ gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstrTag_RDR,
     eqAddr_RDR  , ltAddr_RDR  , geAddr_RDR  , gtAddr_RDR  , leAddr_RDR  ,
     eqFloat_RDR , ltFloat_RDR , geFloat_RDR , gtFloat_RDR , leFloat_RDR ,
     eqDouble_RDR, ltDouble_RDR, geDouble_RDR, gtDouble_RDR, leDouble_RDR,
-    word8ToWord_RDR , int8ToInt_RDR ,
-    word16ToWord_RDR, int16ToInt_RDR,
-    word32ToWord_RDR, int32ToInt_RDR
+    int8DataCon_RDR, int16DataCon_RDR, int32DataCon_RDR, int64DataCon_RDR,
+    word8DataCon_RDR, word16DataCon_RDR, word32DataCon_RDR, word64DataCon_RDR
     :: RdrName
 gfoldl_RDR     = varQual_RDR  gENERICS (fsLit "gfoldl")
 gunfold_RDR    = varQual_RDR  gENERICS (fsLit "gunfold")
@@ -1619,15 +1609,14 @@ leDouble_RDR   = varQual_RDR  gHC_PRIM (fsLit "<=##")
 gtDouble_RDR   = varQual_RDR  gHC_PRIM (fsLit ">##" )
 geDouble_RDR   = varQual_RDR  gHC_PRIM (fsLit ">=##")
 
-word8ToWord_RDR = varQual_RDR  gHC_PRIM (fsLit "word8ToWord#")
-int8ToInt_RDR   = varQual_RDR  gHC_PRIM (fsLit "int8ToInt#")
-
-word16ToWord_RDR = varQual_RDR  gHC_PRIM (fsLit "word16ToWord#")
-int16ToInt_RDR   = varQual_RDR  gHC_PRIM (fsLit "int16ToInt#")
-
-word32ToWord_RDR = varQual_RDR  gHC_PRIM (fsLit "word32ToWord#")
-int32ToInt_RDR   = varQual_RDR  gHC_PRIM (fsLit "int32ToInt#")
-
+int8DataCon_RDR   = dataQual_RDR gHC_INT (fsLit "I8#")
+int16DataCon_RDR  = dataQual_RDR gHC_INT (fsLit "I16#")
+int32DataCon_RDR  = dataQual_RDR gHC_INT (fsLit "I32#")
+int64DataCon_RDR  = dataQual_RDR gHC_INT (fsLit "I64#")
+word8DataCon_RDR  = dataQual_RDR gHC_WORD (fsLit "W8#")
+word16DataCon_RDR = dataQual_RDR gHC_WORD (fsLit "W16#")
+word32DataCon_RDR = dataQual_RDR gHC_WORD (fsLit "W32#")
+word64DataCon_RDR = dataQual_RDR gHC_WORD (fsLit "W64#")
 {-
 ************************************************************************
 *                                                                      *
@@ -2416,7 +2405,6 @@ ordOpTbl
 
 -- A mapping from a primitive type to a function that constructs its boxed
 -- version.
--- NOTE: Int8#/Word8# will become Int/Word.
 boxConTbl :: [(Type, LHsExpr GhcPs -> LHsExpr GhcPs)]
 boxConTbl =
     [ (charPrimTy  , nlHsApp (nlHsVar $ getRdrName charDataCon))
@@ -2424,24 +2412,14 @@ boxConTbl =
     , (wordPrimTy  , nlHsApp (nlHsVar $ getRdrName wordDataCon ))
     , (floatPrimTy , nlHsApp (nlHsVar $ getRdrName floatDataCon ))
     , (doublePrimTy, nlHsApp (nlHsVar $ getRdrName doubleDataCon))
-    , (int8PrimTy,
-        nlHsApp (nlHsVar $ getRdrName intDataCon)
-        . nlHsApp (nlHsVar int8ToInt_RDR))
-    , (word8PrimTy,
-        nlHsApp (nlHsVar $ getRdrName wordDataCon)
-        . nlHsApp (nlHsVar word8ToWord_RDR))
-    , (int16PrimTy,
-        nlHsApp (nlHsVar $ getRdrName intDataCon)
-        . nlHsApp (nlHsVar int16ToInt_RDR))
-    , (word16PrimTy,
-        nlHsApp (nlHsVar $ getRdrName wordDataCon)
-        . nlHsApp (nlHsVar word16ToWord_RDR))
-    , (int32PrimTy,
-        nlHsApp (nlHsVar $ getRdrName intDataCon)
-        . nlHsApp (nlHsVar int32ToInt_RDR))
-    , (word32PrimTy,
-        nlHsApp (nlHsVar $ getRdrName wordDataCon)
-        . nlHsApp (nlHsVar word32ToWord_RDR))
+    , (int8PrimTy,   nlHsApp (nlHsVar int8DataCon_RDR))
+    , (word8PrimTy,  nlHsApp (nlHsVar word8DataCon_RDR))
+    , (int16PrimTy,  nlHsApp (nlHsVar int16DataCon_RDR))
+    , (word16PrimTy, nlHsApp (nlHsVar word16DataCon_RDR))
+    , (int32PrimTy,  nlHsApp (nlHsVar int32DataCon_RDR))
+    , (word32PrimTy, nlHsApp (nlHsVar word32DataCon_RDR))
+    , (int64PrimTy,  nlHsApp (nlHsVar int64DataCon_RDR))
+    , (word64PrimTy, nlHsApp (nlHsVar word64DataCon_RDR))
     ]
 
 
@@ -2453,22 +2431,14 @@ postfixModTbl
     ,(wordPrimTy  , "##")
     ,(floatPrimTy , "#" )
     ,(doublePrimTy, "##")
-    ,(int8PrimTy, "#")
-    ,(word8PrimTy, "##")
-    ,(int16PrimTy, "#")
-    ,(word16PrimTy, "##")
-    ,(int32PrimTy, "#")
-    ,(word32PrimTy, "##")
-    ]
-
-primConvTbl :: [(Type, String)]
-primConvTbl =
-    [ (int8PrimTy, "intToInt8#")
-    , (word8PrimTy, "wordToWord8#")
-    , (int16PrimTy, "intToInt16#")
-    , (word16PrimTy, "wordToWord16#")
-    , (int32PrimTy, "intToInt32#")
-    , (word32PrimTy, "wordToWord32#")
+    ,(int8PrimTy  , "#Int8")
+    ,(word8PrimTy , "#Word8")
+    ,(int16PrimTy , "#Int16")
+    ,(word16PrimTy, "#Word16")
+    ,(int32PrimTy , "#Int32")
+    ,(word32PrimTy, "#Word32")
+    ,(int64PrimTy , "#Int64")
+    ,(word64PrimTy, "#Word64")
     ]
 
 litConTbl :: [(Type, LHsExpr GhcPs -> LHsExpr GhcPs)]


=====================================
testsuite/tests/primops/should_run/ShowPrim.hs
=====================================
@@ -1,4 +1,4 @@
-{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE MagicHash, ExtendedLiterals #-}
 
 module Main where
 
@@ -13,17 +13,24 @@ data Test2 = Test2 Int16# Word16#
 data Test3 = Test3 Int32# Word32#
     deriving (Show)
 
+data Test4 = Test4 Int64# Word64#
+    deriving (Show)
+
 test1 :: Test1
-test1 = Test1 (intToInt8# 1#) (wordToWord8# 2##)
+test1 = Test1 1#Int8 2#Word8
 
 test2 :: Test2
-test2 = Test2 (intToInt16# 1#) (wordToWord16# 2##)
+test2 = Test2 1#Int16 2#Word16
 
 test3 :: Test3
-test3 = Test3 (intToInt32# 1#) (wordToWord32# 2##)
+test3 = Test3 1#Int32 2#Word32
+
+test4 :: Test4
+test4 = Test4 -9223372036854775808#Int64 18446744073709551610#Word64
 
 main :: IO ()
 main = do
   print test1
   print test2
   print test3
+  print test4


=====================================
testsuite/tests/primops/should_run/ShowPrim.stdout
=====================================
@@ -1,3 +1,4 @@
-Test1 (intToInt8# 1#) (wordToWord8# 2##)
-Test2 (intToInt16# 1#) (wordToWord16# 2##)
-Test3 (intToInt32# 1#) (wordToWord32# 2##)
+Test1 1#Int8 2#Word8
+Test2 1#Int16 2#Word16
+Test3 1#Int32 2#Word32
+Test4 -9223372036854775808#Int64 18446744073709551610#Word64



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7f4cc96b3a2360840d05a2263f61cb23d5b2d15d

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7f4cc96b3a2360840d05a2263f61cb23d5b2d15d
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/20230629/cf940f96/attachment-0001.html>


More information about the ghc-commits mailing list