[Git][ghc/ghc][master] VoidRep-related refactor

Marge Bot (@marge-bot) gitlab at gitlab.haskell.org
Fri Jan 5 07:08:26 UTC 2024



Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC


Commits:
90ea574e by Krzysztof Gogolewski at 2024-01-05T02:07:54-05:00
VoidRep-related refactor

* In GHC.StgToByteCode, replace bcIdPrimId with idPrimRep,
  bcIdArgRep with idArgRep, atomPrimRep with stgArgRep1.
  All of them were duplicates.
* In GHC.Stg.Unarise, we were converting a PrimRep to a Type and back to
  PrimRep. Remove the calls to primRepToType and typePrimRep1 which cancel out.
* In GHC.STG.Lint, GHC.StgToCmm, GHC.Types.RepType we were filtering out
  VoidRep from the result of typePrimRep. But typePrimRep never returns
  VoidRep - remove the filtering.

- - - - -


8 changed files:

- compiler/GHC/Stg/Lint.hs
- compiler/GHC/Stg/Unarise.hs
- compiler/GHC/StgToByteCode.hs
- compiler/GHC/StgToCmm.hs
- compiler/GHC/StgToCmm/Layout.hs
- compiler/GHC/StgToCmm/Ticky.hs
- compiler/GHC/Types/Id/Make.hs
- compiler/GHC/Types/RepType.hs


Changes:

=====================================
compiler/GHC/Stg/Lint.hs
=====================================
@@ -381,9 +381,9 @@ lintStgAppReps fun args = do
         | actual_rep == expected_rep
         = match_args actual_reps_left expected_reps_left
 
-        -- Check for void rep which can be either an empty list *or* [VoidRep]
-           -- No, typePrimRep_maybe will never return a result containing VoidRep.
-           -- We should refactor to make this obvious from the types.
+        -- Check for void rep (empty list)
+        -- Note typePrimRep_maybe will never return a result containing VoidRep.
+        -- We should refactor to make this obvious from the types.
         | isVoidRep actual_rep && isVoidRep expected_rep
         = match_args actual_reps_left expected_reps_left
 
@@ -410,7 +410,6 @@ lintStgAppReps fun args = do
               text "unarised?:" <> ppr (lf_unarised lf))
         where
           isVoidRep [] = True
-          isVoidRep [VoidRep] = True
           isVoidRep _ = False
           -- Try to strip one non-void arg rep from the current argument type returning
           -- the remaining list of arguments. We return Nothing for invalid input which


=====================================
compiler/GHC/Stg/Unarise.hs
=====================================
@@ -808,15 +808,13 @@ mapSumIdBinders alt_bndr args rhs rho0
       -- Select only the args which contain parts of the current field.
       id_arg_exprs   = [ args !! i | i <- layout1 ]
       id_vars   = [v | StgVarArg v <- id_arg_exprs]
-      -- Output types for the field binders based on their rep
-      id_tys    = map primRepToType fld_reps
 
-      typed_id_arg_input = assert (equalLength id_vars id_tys) $
-                           zip3 id_vars id_tys uss
+      typed_id_arg_input = assert (equalLength id_vars fld_reps) $
+                           zip3 id_vars fld_reps uss
 
-      mkCastInput :: (Id,Type,UniqSupply) -> ([(PrimOp,Type,Unique)],Id,Id)
-      mkCastInput (id,tar_type,bndr_us) =
-        let (ops,types) = unzip $ getCasts (typePrimRep1 $ idType id) (typePrimRep1 tar_type)
+      mkCastInput :: (Id,PrimRep,UniqSupply) -> ([(PrimOp,Type,Unique)],Id,Id)
+      mkCastInput (id,rep,bndr_us) =
+        let (ops,types) = unzip $ getCasts (typePrimRep1 $ idType id) rep
             cst_opts = zip3 ops types $ uniqsFromSupply bndr_us
             out_id = case cst_opts of
               [] -> id
@@ -834,7 +832,7 @@ mapSumIdBinders alt_bndr args rhs rho0
       typed_id_args = map StgVarArg typed_ids
 
       -- pprTrace "mapSumIdBinders"
-      --           (text "id_tys" <+> ppr id_tys $$
+      --           (text "fld_reps" <+> ppr fld_reps $$
       --           text "id_args" <+> ppr id_arg_exprs $$
       --           text "rhs" <+> ppr rhs $$
       --           text "rhs_with_casts" <+> ppr rhs_with_casts
@@ -925,8 +923,7 @@ mkUbxSum dc ty_args args0 us
       castArg us slot_ty arg
         -- Cast the argument to the type of the slot if required
         | slotPrimRep slot_ty /= stgArgRep1 arg
-        , out_ty <- primRepToType $ slotPrimRep slot_ty
-        , (ops,types) <- unzip $ getCasts (stgArgRep1 arg) $ typePrimRep1 out_ty
+        , (ops,types) <- unzip $ getCasts (stgArgRep1 arg) $ slotPrimRep slot_ty
         , not . null $ ops
         = let (us1,us2) = splitUniqSupply us
               cast_uqs = uniqsFromSupply us1


=====================================
compiler/GHC/StgToByteCode.hs
=====================================
@@ -57,7 +57,9 @@ import GHC.Builtin.Uniques
 import GHC.Data.FastString
 import GHC.Utils.Panic
 import GHC.Utils.Exception (evaluate)
-import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, nonVoidIds )
+import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, idPrimRep,
+                              addIdReps, addArgReps,
+                              nonVoidIds, nonVoidStgArgs )
 import GHC.StgToCmm.Layout
 import GHC.Runtime.Heap.Layout hiding (WordOff, ByteOff, wordsToBytes)
 import GHC.Data.Bitmap
@@ -80,7 +82,6 @@ import Data.Coerce (coerce)
 import Data.ByteString (ByteString)
 import Data.Map (Map)
 import Data.IntMap (IntMap)
-import Data.List.NonEmpty (NonEmpty(..))
 import qualified Data.Map as Map
 import qualified Data.IntMap as IntMap
 import qualified GHC.Data.FiniteMap as Map
@@ -372,7 +373,7 @@ schemeR_wrk fvs nm original_body (args, body)
          p_init    = Map.fromList (zip all_args (mkStackOffsets 0 szsb_args))
 
          -- make the arg bitmap
-         bits = argBits platform (reverse (map (bcIdArgRep platform) all_args))
+         bits = argBits platform (reverse (map (idArgRep platform) all_args))
          bitmap_size = genericLength bits
          bitmap = mkBitmap platform bits
      body_code <- schemeER_wrk sum_szsb_args p_init body
@@ -528,7 +529,7 @@ returnUnboxedTuple
 returnUnboxedTuple d s p es = do
     profile <- getProfile
     let platform = profilePlatform profile
-        arg_ty e = primRepCmmType platform (atomPrimRep e)
+        arg_ty e = primRepCmmType platform (stgArgRep1 e)
         (call_info, tuple_components) = layoutNativeCall profile
                                                          NativeTupleReturn
                                                          d
@@ -544,7 +545,7 @@ returnUnboxedTuple d s p es = do
     ret <- returnUnliftedReps d
                               s
                               (wordsToBytes platform $ nativeCallSize call_info)
-                              (filter non_void $ map atomPrimRep es)
+                              (filter non_void $ map stgArgRep1 es)
     return (mconcat pushes `appOL` ret)
 
 -- Compile code to apply the given expression to the remaining args
@@ -745,11 +746,7 @@ mkConAppCode orig_d _ p con args = app_code
         let platform = profilePlatform profile
 
             non_voids =
-                [ NonVoid (prim_rep, arg)
-                | arg <- args
-                , let prim_rep = atomPrimRep arg
-                , not (isVoidRep prim_rep)
-                ]
+                addArgReps (nonVoidStgArgs args)
             (_, _, args_offsets) =
                 mkVirtHeapOffsetsWithPadding profile StdHeader non_voids
 
@@ -931,7 +928,7 @@ doCase d s p scrut bndr alts
                 rhs_code <- schemeE d_alts s p_alts rhs
                 return (my_discr alt, rhs_code)
            | isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty =
-             let bndr_ty = primRepCmmType platform . bcIdPrimRep
+             let bndr_ty = primRepCmmType platform . idPrimRep
                  tuple_start = d_bndr
                  (call_info, args_offsets) =
                    layoutNativeCall profile
@@ -947,7 +944,7 @@ doCase d s p scrut bndr alts
                                 wordsToBytes platform (nativeCallSize call_info) +
                                 offset)
                         | (arg, offset) <- args_offsets
-                        , not (isVoidRep $ bcIdPrimRep arg)]
+                        , not (isVoidRep $ idPrimRep arg)]
                         p_alts
              in do
                rhs_code <- schemeE stack_bot s p' rhs
@@ -956,9 +953,7 @@ doCase d s p scrut bndr alts
            | otherwise =
              let (tot_wds, _ptrs_wds, args_offsets) =
                      mkVirtHeapOffsets profile NoHeader
-                         [ NonVoid (bcIdPrimRep id, id)
-                         | NonVoid id <- nonVoidIds real_bndrs
-                         ]
+                         (addIdReps (nonVoidIds real_bndrs))
                  size = WordOff tot_wds
 
                  stack_bot = d_alts + wordsToBytes platform size
@@ -1052,7 +1047,7 @@ doCase d s p scrut bndr alts
           rel_slots = IntSet.toAscList $ IntSet.fromList $ Map.elems $ Map.mapMaybeWithKey spread p
           spread id offset | isUnboxedTupleType (idType id) ||
                              isUnboxedSumType (idType id) = Nothing
-                           | isFollowableArg (bcIdArgRep platform id) = Just (fromIntegral rel_offset)
+                           | isFollowableArg (idArgRep platform id) = Just (fromIntegral rel_offset)
                            | otherwise                      = Nothing
                 where rel_offset = bytesToWords platform (d - offset)
 
@@ -1478,7 +1473,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) result_ty args
                  return ((code, AddrRep) : rest)
          pargs d (aa:az) =  do (code_a, sz_a) <- pushAtom d p aa
                                rest <- pargs (d + sz_a) az
-                               return ((code_a, atomPrimRep aa) : rest)
+                               return ((code_a, stgArgRep1 aa) : rest)
 
      code_n_reps <- pargs d0 args_r_to_l
      let
@@ -2126,7 +2121,7 @@ lookupBCEnv_maybe :: Id -> BCEnv -> Maybe ByteOff
 lookupBCEnv_maybe = Map.lookup
 
 idSizeW :: Platform -> Id -> WordOff
-idSizeW platform = WordOff . argRepSizeW platform . bcIdArgRep platform
+idSizeW platform = WordOff . argRepSizeW platform . idArgRep platform
 
 idSizeCon :: Platform -> Id -> ByteOff
 idSizeCon platform var
@@ -2136,17 +2131,7 @@ idSizeCon platform var
     wordsToBytes platform .
     WordOff . sum . map (argRepSizeW platform . toArgRep platform) .
     typePrimRep . idType $ var
-  | otherwise = ByteOff (primRepSizeB platform (bcIdPrimRep var))
-
-bcIdArgRep :: Platform -> Id -> ArgRep
-bcIdArgRep platform = toArgRep platform . bcIdPrimRep
-
-bcIdPrimRep :: Id -> PrimRep
-bcIdPrimRep id
-  | rep :| [] <- typePrimRepArgs (idType id)
-  = rep
-  | otherwise
-  = pprPanic "bcIdPrimRep" (ppr id <+> dcolon <+> ppr (idType id))
+  | otherwise = ByteOff (primRepSizeB platform (idPrimRep var))
 
 repSizeWords :: Platform -> PrimRep -> WordOff
 repSizeWords platform rep = WordOff $ argRepSizeW platform (toArgRep platform rep)
@@ -2185,12 +2170,8 @@ mkSlideW !n !ws
 
 
 
-atomPrimRep :: StgArg -> PrimRep
-atomPrimRep (StgVarArg v) = bcIdPrimRep v
-atomPrimRep (StgLitArg l) = typePrimRep1 (literalType l)
-
 atomRep :: Platform -> StgArg -> ArgRep
-atomRep platform e = toArgRep platform (atomPrimRep e)
+atomRep platform e = toArgRep platform (stgArgRep1 e)
 
 -- | Let szsw be the sizes in bytes of some items pushed onto the stack, which
 -- has initial depth @original_depth at .  Return the values which the stack


=====================================
compiler/GHC/StgToCmm.hs
=====================================
@@ -257,7 +257,7 @@ cgDataCon mn data_con
             arg_reps = [ NonVoid rep_ty
                        | ty <- dataConRepArgTys data_con
                        , rep_ty <- typePrimRep (scaledThing ty)
-                       , not (isVoidRep rep_ty) ]
+                       ]
 
         ; emitClosureAndInfoTable platform dyn_info_tbl NativeDirectCall [] $
             -- NB: the closure pointer is assumed *untagged* on


=====================================
compiler/GHC/StgToCmm/Layout.hs
=====================================
@@ -26,7 +26,7 @@ module GHC.StgToCmm.Layout (
         mkVirtConstrSizes,
         getHpRelOffset,
 
-        ArgRep(..), toArgRep, argRepSizeW, -- re-exported from GHC.StgToCmm.ArgRep
+        ArgRep(..), toArgRep, idArgRep, argRepSizeW, -- re-exported from GHC.StgToCmm.ArgRep
         getArgAmode, getNonVoidArgAmodes
   ) where
 
@@ -328,10 +328,10 @@ getArgRepsAmodes args = do
    platform <- profilePlatform <$> getProfile
    mapM (getArgRepAmode platform) args
   where getArgRepAmode platform arg
-           | V <- rep  = return (V, Nothing)
-           | otherwise = do expr <- getArgAmode (NonVoid arg)
-                            return (rep, Just expr)
-           where rep = toArgRep platform (stgArgRep1 arg)
+           = case stgArgRep1 arg of
+               VoidRep -> return (V, Nothing)
+               rep -> do expr <- getArgAmode (NonVoid arg)
+                         return (toArgRep platform rep, Just expr)
 
 nonVArgs :: [(ArgRep, Maybe CmmExpr)] -> [CmmExpr]
 nonVArgs [] = []
@@ -603,12 +603,7 @@ getArgAmode (NonVoid (StgLitArg lit)) = cgLit lit
 getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr]
 -- NB: Filters out void args,
 --     so the result list may be shorter than the argument list
-getNonVoidArgAmodes [] = return []
-getNonVoidArgAmodes (arg:args)
-  | isVoidRep (stgArgRep1 arg) = getNonVoidArgAmodes args
-  | otherwise = do { amode  <- getArgAmode (NonVoid arg)
-                   ; amodes <- getNonVoidArgAmodes args
-                   ; return ( amode : amodes ) }
+getNonVoidArgAmodes args = mapM getArgAmode (nonVoidStgArgs args)
 
 -------------------------------------------------------------------------
 --


=====================================
compiler/GHC/StgToCmm/Ticky.hs
=====================================
@@ -587,7 +587,7 @@ tickyDirectCall :: RepArity -> [StgArg] -> FCode ()
 tickyDirectCall arity args
   | args `lengthIs` arity = tickyKnownCallExact
   | otherwise = do tickyKnownCallExtraArgs
-                   tickySlowCallPat (map stgArgRep1 (drop arity args))
+                   tickySlowCallPat (drop arity args)
 
 tickyKnownCallTooFewArgs :: FCode ()
 tickyKnownCallTooFewArgs = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_TOO_FEW_ARGS_ctr")
@@ -610,12 +610,12 @@ tickySlowCall lf_info args = do
  if isKnownFun lf_info
    then tickyKnownCallTooFewArgs
    else tickyUnknownCall
- tickySlowCallPat (map stgArgRep1 args)
+ tickySlowCallPat args
 
-tickySlowCallPat :: [PrimRep] -> FCode ()
+tickySlowCallPat :: [StgArg] -> FCode ()
 tickySlowCallPat args = ifTicky $ do
   platform <- profilePlatform <$> getProfile
-  let argReps = map (toArgRep platform) args
+  let argReps = map (toArgRep platform . stgArgRep1) args
       (_, n_matched) = slowCallPattern argReps
   if n_matched > 0 && args `lengthIs` n_matched
      then bumpTickyLbl $ mkRtsSlowFastTickyCtrLabel $ concatMap (map Data.Char.toLower . argRepString) argReps


=====================================
compiler/GHC/Types/Id/Make.hs
=====================================
@@ -1525,11 +1525,10 @@ shouldUnpackArgTy bang_opts prag fam_envs arg_ty
         -- and tells us if they can fit into 8 bytes. See Note [Unpack one-wide fields]
         is_small_rep =
           let -- Neccesary to look through unboxed tuples.
+              -- Note typePrimRep never returns VoidRep
               prim_reps = concatMap (typePrimRep . scaledThing . fst) $ rep_tys
-              -- Void types are erased when unpacked so we
-              nv_prim_reps = filter (not . isVoidRep) prim_reps
               -- And then get the actual size of the unpacked constructor.
-              rep_size = sum $ map primRepSizeW64_B nv_prim_reps
+              rep_size = sum $ map primRepSizeW64_B prim_reps
           in rep_size <= 8
 
     is_sum :: [DataCon] -> Bool


=====================================
compiler/GHC/Types/RepType.hs
=====================================
@@ -160,21 +160,18 @@ dataConRuntimeRepStrictness dc =
      go repMarks repTys []
   where
     go (mark:marks) (ty:types) out_marks
-      -- Zero-width argument, mark is irrelevant at runtime.
-      |  -- pprTrace "VoidTy" (ppr ty) $
-        (isZeroBitTy ty)
-      = go marks types out_marks
-      -- Single rep argument, e.g. Int
-      -- Keep mark as-is
-      | [_] <- reps
-      = go marks types (mark:out_marks)
-      -- Multi-rep argument, e.g. (# Int, Bool #) or (# Int | Bool #)
-      -- Make up one non-strict mark per runtime argument.
-      | otherwise -- TODO: Assert real_reps /= null
-      = go marks types ((replicate (length real_reps) NotMarkedStrict)++out_marks)
+      = case reps of
+          -- Zero-width argument, mark is irrelevant at runtime.
+          [] -> -- pprTrace "VoidTy" (ppr ty) $
+                go marks types out_marks
+          -- Single rep argument, e.g. Int
+          -- Keep mark as-is
+          [_] -> go marks types (mark:out_marks)
+          -- Multi-rep argument, e.g. (# Int, Bool #) or (# Int | Bool #)
+          -- Make up one non-strict mark per runtime argument.
+          _ -> go marks types ((replicate (length reps) NotMarkedStrict)++out_marks)
       where
         reps = typePrimRep ty
-        real_reps = filter (not . isVoidRep) $ reps
     go [] [] out_marks = reverse out_marks
     go _m _t _o = pprPanic "dataConRuntimeRepStrictness2" (ppr dc $$ ppr _m $$ ppr _t $$ ppr _o)
 



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/90ea574e9cdac4c57e91ce7fdae7fbbccf344e24

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/90ea574e9cdac4c57e91ce7fdae7fbbccf344e24
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/20240105/87178a47/attachment-0001.html>


More information about the ghc-commits mailing list