[Git][ghc/ghc][master] Refactor: introduce stgArgRep

Marge Bot (@marge-bot) gitlab at gitlab.haskell.org
Wed Sep 27 05:20:13 UTC 2023



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


Commits:
1dbdb9d0 by Krzysztof Gogolewski at 2023-09-27T01:19:37-04:00
Refactor: introduce stgArgRep

The function 'stgArgType' returns the type in STG. But this violates
the abstraction: in STG we're supposed to operate on PrimReps.

This introduces
stgArgRep ty = typePrimRep (stgArgType ty)
stgArgRep1 ty = typePrimRep1 (stgArgType ty)
stgArgRep_maybe ty = typePrimRep_maybe (stgArgType ty)

stgArgType is still directly used for unboxed tuples (should be fixable), FFI
and in ticky.

- - - - -


11 changed files:

- compiler/GHC/CoreToStg.hs
- compiler/GHC/Stg/Lint.hs
- compiler/GHC/Stg/Syntax.hs
- compiler/GHC/Stg/Unarise.hs
- compiler/GHC/StgToByteCode.hs
- compiler/GHC/StgToCmm/Closure.hs
- compiler/GHC/StgToCmm/Expr.hs
- compiler/GHC/StgToCmm/Layout.hs
- compiler/GHC/StgToCmm/Ticky.hs
- compiler/GHC/StgToJS/Arg.hs
- compiler/GHC/Types/RepType.hs


Changes:

=====================================
compiler/GHC/CoreToStg.hs
=====================================
@@ -602,7 +602,7 @@ coreToStgArgs (arg : args) = do         -- Non-type argument
         ticks' = map (coreToStgTick arg_ty) (stripTicksT (not . tickishIsCode) arg)
         arg' = getStgArgFromTrivialArg arg
         arg_rep = typePrimRep arg_ty
-        stg_arg_rep = typePrimRep (stgArgType arg')
+        stg_arg_rep = stgArgRep arg'
         bad_args = not (primRepsCompatible platform arg_rep stg_arg_rep)
 
     massertPpr (length ticks' <= 1) (text "More than one Tick in trivial arg:" <+> ppr arg)


=====================================
compiler/GHC/Stg/Lint.hs
=====================================
@@ -178,7 +178,7 @@ lintStgTopBindings platform logger diag_opts opts extra_vars this_mod unarised w
 lintStgConArg :: StgArg -> LintM ()
 lintStgConArg arg = do
   unarised <- lf_unarised <$> getLintFlags
-  when unarised $ case typePrimRep_maybe (stgArgType arg) of
+  when unarised $ case stgArgRep_maybe arg of
     -- Note [Post-unarisation invariants], invariant 4
     Just [_] -> pure ()
     badRep   -> addErrL $
@@ -192,7 +192,7 @@ lintStgConArg arg = do
 lintStgFunArg :: StgArg -> LintM ()
 lintStgFunArg arg = do
   unarised <- lf_unarised <$> getLintFlags
-  when unarised $ case typePrimRep_maybe (stgArgType arg) of
+  when unarised $ case stgArgRep_maybe arg of
     -- Note [Post-unarisation invariants], invariant 3
     Just []  -> pure ()
     Just [_] -> pure ()
@@ -371,7 +371,7 @@ lintStgAppReps fun args = do
       -- and we abort kind checking.
       fun_arg_tys_reps, actual_arg_reps :: [Maybe [PrimRep]]
       fun_arg_tys_reps = map typePrimRep_maybe fun_arg_tys'
-      actual_arg_reps = map (typePrimRep_maybe . stgArgType) args
+      actual_arg_reps = map stgArgRep_maybe args
 
       match_args :: [Maybe [PrimRep]] -> [Maybe [PrimRep]] -> LintM ()
       match_args (Nothing:_) _   = return ()


=====================================
compiler/GHC/Stg/Syntax.hs
=====================================
@@ -56,6 +56,10 @@ module GHC.Stg.Syntax (
         stgRhsArity, freeVarsOfRhs,
         isDllConApp,
         stgArgType,
+        stgArgRep,
+        stgArgRep1,
+        stgArgRep_maybe,
+
         stgCaseBndrInScope,
 
         -- ppr
@@ -86,7 +90,7 @@ import GHC.Types.Name        ( isDynLinkName )
 import GHC.Types.Tickish     ( StgTickish )
 import GHC.Types.Var.Set
 import GHC.Types.Literal     ( Literal, literalType )
-import GHC.Types.RepType ( typePrimRep1, typePrimRep )
+import GHC.Types.RepType ( typePrimRep1, typePrimRep, typePrimRep_maybe )
 
 import GHC.Unit.Module       ( Module )
 import GHC.Utils.Outputable
@@ -181,15 +185,30 @@ isAddrRep _            = False
 -- | Type of an @StgArg@
 --
 -- Very half baked because we have lost the type arguments.
+--
+-- This function should be avoided: in STG we aren't supposed to
+-- look at types, but only PrimReps.
+-- Use 'stgArgRep', 'stgArgRep_maybe', 'stgArgRep1' instaed.
 stgArgType :: StgArg -> Type
 stgArgType (StgVarArg v)   = idType v
 stgArgType (StgLitArg lit) = literalType lit
 
+stgArgRep :: StgArg -> [PrimRep]
+stgArgRep ty = typePrimRep (stgArgType ty)
+
+stgArgRep_maybe :: StgArg -> Maybe [PrimRep]
+stgArgRep_maybe ty = typePrimRep_maybe (stgArgType ty)
+
+-- | Assumes that the argument has one PrimRep, which holds after unarisation.
+-- See Note [Post-unarisation invariants] in GHC.Stg.Unarise.
+stgArgRep1 :: StgArg -> PrimRep
+stgArgRep1 ty = typePrimRep1 (stgArgType ty)
+
 -- | Given an alt type and whether the program is unarised, return whether the
 -- case binder is in scope.
 --
 -- Case binders of unboxed tuple or unboxed sum type always dead after the
--- unariser has run. See Note [Post-unarisation invariants].
+-- unariser has run. See Note [Post-unarisation invariants] in GHC.Stg.Unarise.
 stgCaseBndrInScope :: AltType -> Bool {- ^ unarised? -} -> Bool
 stgCaseBndrInScope alt_ty unarised =
     case alt_ty of


=====================================
compiler/GHC/Stg/Unarise.hs
=====================================
@@ -446,10 +446,10 @@ instance Outputable UnariseVal where
 -- See Note [UnariseEnv]
 extendRho :: UnariseEnv -> Id -> UnariseVal -> UnariseEnv
 extendRho env x (MultiVal args)
-  = assert (all (isNvUnaryType . stgArgType) args)
+  = assert (all (isNvUnaryRep . stgArgRep) args)
     env { ue_rho = extendVarEnv (ue_rho env) x (MultiVal args) }
 extendRho env x (UnaryVal val)
-  = assert (isNvUnaryType (stgArgType val))
+  = assert (isNvUnaryRep (stgArgRep val))
     env { ue_rho = extendVarEnv (ue_rho env) x (UnaryVal val) }
 -- Properly shadow things from an outer scope.
 -- See Note [UnariseEnv]
@@ -745,7 +745,7 @@ mapTupleIdBinders
   -> UnariseEnv
   -> UnariseEnv
 mapTupleIdBinders ids args0 rho0
-  = assert (not (any (isZeroBitTy . stgArgType) args0)) $
+  = assert (not (any (null . stgArgRep) args0)) $
     let
       ids_unarised :: [(Id, [PrimRep])]
       ids_unarised = map (\id -> (id, typePrimRep (idType id))) ids
@@ -779,13 +779,13 @@ mapSumIdBinders
   -> UniqSM (UnariseEnv, OutStgExpr)
 
 mapSumIdBinders alt_bndr args rhs rho0
-  = assert (not (any (isZeroBitTy . stgArgType) args)) $ do
+  = assert (not (any (null . stgArgRep) args)) $ do
     uss <- listSplitUniqSupply <$> getUniqueSupplyM
     let
       fld_reps = typePrimRep (idType alt_bndr)
 
       -- Slots representing the whole sum
-      arg_slots = map primRepSlot $ concatMap (typePrimRep . stgArgType) args
+      arg_slots = map primRepSlot $ concatMap stgArgRep args
       -- The slots representing the field of the sum we bind.
       id_slots  = map primRepSlot $ fld_reps
       layout1   = layoutUbxSum arg_slots id_slots
@@ -879,7 +879,7 @@ mkUbxSum dc ty_args args0 us
   = let
       _ :| sum_slots = ubxSumRepType (map typePrimRep ty_args)
       -- drop tag slot
-      field_slots = (mapMaybe (typeSlotTy . stgArgType) args0)
+      field_slots = (mapMaybe (repSlotTy . stgArgRep) args0)
       tag = dataConTag dc
       layout'  = layoutUbxSum sum_slots field_slots
 
@@ -912,9 +912,9 @@ mkUbxSum dc ty_args args0 us
       castArg :: UniqSupply -> SlotTy -> StgArg -> Maybe (StgArg,UniqSupply,StgExpr -> StgExpr)
       castArg us slot_ty arg
         -- Cast the argument to the type of the slot if required
-        | slotPrimRep slot_ty /= typePrimRep1 (stgArgType arg)
+        | slotPrimRep slot_ty /= stgArgRep1 arg
         , out_ty <- primRepToType $ slotPrimRep slot_ty
-        , (ops,types) <- unzip $ getCasts (typePrimRep1 $ stgArgType arg) $ typePrimRep1 out_ty
+        , (ops,types) <- unzip $ getCasts (stgArgRep1 arg) $ typePrimRep1 out_ty
         , not . null $ ops
         = let (us1,us2) = splitUniqSupply us
               cast_uqs = uniqsFromSupply us1


=====================================
compiler/GHC/StgToByteCode.hs
=====================================
@@ -57,7 +57,7 @@ import GHC.Builtin.Uniques
 import GHC.Data.FastString
 import GHC.Utils.Panic
 import GHC.Utils.Exception (evaluate)
-import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, nonVoidIds, argPrimRep )
+import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, nonVoidIds )
 import GHC.StgToCmm.Layout
 import GHC.Runtime.Heap.Layout hiding (WordOff, ByteOff, wordsToBytes)
 import GHC.Data.Bitmap
@@ -1385,16 +1385,16 @@ generatePrimCall d s p target _mb_unit _result_ty args
          non_void _       = True
 
          nv_args :: [StgArg]
-         nv_args = filter (non_void . argPrimRep) args
+         nv_args = filter (non_void . stgArgRep1) args
 
          (args_info, args_offsets) =
               layoutNativeCall profile
                                NativePrimCall
                                0
-                               (primRepCmmType platform . argPrimRep)
+                               (primRepCmmType platform . stgArgRep1)
                                nv_args
 
-         prim_args_offsets = mapFst argPrimRep args_offsets
+         prim_args_offsets = mapFst stgArgRep1 args_offsets
          shifted_args_offsets = mapSnd (+ d) args_offsets
 
          push_target = PUSH_UBX (LitLabel target Nothing IsFunction) 1


=====================================
compiler/GHC/StgToCmm/Closure.hs
=====================================
@@ -19,7 +19,6 @@ module GHC.StgToCmm.Closure (
         DynTag,  tagForCon, isSmallFamily,
 
         idPrimRep, isVoidRep, isGcPtrRep, addIdReps, addArgReps,
-        argPrimRep,
 
         NonVoid(..), fromNonVoid, nonVoidIds, nonVoidStgArgs,
         assertNonVoidIds, assertNonVoidStgArgs,
@@ -161,13 +160,13 @@ assertNonVoidIds ids = assert (not (any (isZeroBitTy . idType) ids)) $
                        coerce ids
 
 nonVoidStgArgs :: [StgArg] -> [NonVoid StgArg]
-nonVoidStgArgs args = [NonVoid arg | arg <- args, not (isZeroBitTy (stgArgType arg))]
+nonVoidStgArgs args = [NonVoid arg | arg <- args, not (null (stgArgRep arg))]
 
 -- | Used in places where some invariant ensures that all these arguments are
 -- non-void; e.g. constructor arguments.
 -- See Note [Post-unarisation invariants] in "GHC.Stg.Unarise".
 assertNonVoidStgArgs :: [StgArg] -> [NonVoid StgArg]
-assertNonVoidStgArgs args = assert (not (any (isZeroBitTy . stgArgType) args)) $
+assertNonVoidStgArgs args = assert (not (any (null . stgArgRep) args)) $
                             coerce args
 
 
@@ -179,27 +178,22 @@ assertNonVoidStgArgs args = assert (not (any (isZeroBitTy . stgArgType) args)) $
 
 -- | Assumes that there is precisely one 'PrimRep' of the type. This assumption
 -- holds after unarise.
--- See Note [Post-unarisation invariants]
+-- See Note [Post-unarisation invariants] in GHC.Stg.Unarise.
 idPrimRep :: Id -> PrimRep
 idPrimRep id = typePrimRep1 (idType id)
     -- See also Note [VoidRep] in GHC.Types.RepType
 
 -- | Assumes that Ids have one PrimRep, which holds after unarisation.
--- See Note [Post-unarisation invariants]
+-- See Note [Post-unarisation invariants] in GHC.Stg.Unarise.
 addIdReps :: [NonVoid Id] -> [NonVoid (PrimRep, Id)]
 addIdReps = map (\id -> let id' = fromNonVoid id
                          in NonVoid (idPrimRep id', id'))
 
 -- | Assumes that arguments have one PrimRep, which holds after unarisation.
--- See Note [Post-unarisation invariants]
+-- See Note [Post-unarisation invariants] in GHC.Stg.Unarise.
 addArgReps :: [NonVoid StgArg] -> [NonVoid (PrimRep, StgArg)]
 addArgReps = map (\arg -> let arg' = fromNonVoid arg
-                           in NonVoid (argPrimRep arg', arg'))
-
--- | Assumes that the argument has one PrimRep, which holds after unarisation.
--- See Note [Post-unarisation invariants]
-argPrimRep :: StgArg -> PrimRep
-argPrimRep arg = typePrimRep1 (stgArgType arg)
+                           in NonVoid (stgArgRep1 arg', arg'))
 
 ------------------------------------------------------
 --                Building LambdaFormInfo


=====================================
compiler/GHC/StgToCmm/Expr.hs
=====================================
@@ -1001,7 +1001,7 @@ cgIdApp fun_id args = do
         fun            = idInfoToAmode fun_info
         lf_info        = cg_lf         fun_info
         n_args         = length args
-        v_args         = length $ filter (isZeroBitTy . stgArgType) args
+        v_args         = length $ filter (null . stgArgRep) args
     case getCallMethod cfg fun_name fun_id lf_info n_args v_args (cg_loc fun_info) self_loop of
             -- A value in WHNF, so we can just return it.
         ReturnIt


=====================================
compiler/GHC/StgToCmm/Layout.hs
=====================================
@@ -331,7 +331,7 @@ getArgRepsAmodes args = do
            | V <- rep  = return (V, Nothing)
            | otherwise = do expr <- getArgAmode (NonVoid arg)
                             return (rep, Just expr)
-           where rep = toArgRep platform (argPrimRep arg)
+           where rep = toArgRep platform (stgArgRep1 arg)
 
 nonVArgs :: [(ArgRep, Maybe CmmExpr)] -> [CmmExpr]
 nonVArgs [] = []
@@ -605,7 +605,7 @@ getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr]
 --     so the result list may be shorter than the argument list
 getNonVoidArgAmodes [] = return []
 getNonVoidArgAmodes (arg:args)
-  | isVoidRep (argPrimRep arg) = getNonVoidArgAmodes args
+  | isVoidRep (stgArgRep1 arg) = getNonVoidArgAmodes args
   | otherwise = do { amode  <- getArgAmode (NonVoid arg)
                    ; amodes <- getNonVoidArgAmodes args
                    ; return ( amode : amodes ) }


=====================================
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 argPrimRep (drop arity args))
+                   tickySlowCallPat (map stgArgRep1 (drop arity args))
 
 tickyKnownCallTooFewArgs :: FCode ()
 tickyKnownCallTooFewArgs = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_TOO_FEW_ARGS_ctr")
@@ -610,7 +610,7 @@ tickySlowCall lf_info args = do
  if isKnownFun lf_info
    then tickyKnownCallTooFewArgs
    else tickyUnknownCall
- tickySlowCallPat (map argPrimRep args)
+ tickySlowCallPat (map stgArgRep1 args)
 
 tickySlowCallPat :: [PrimRep] -> FCode ()
 tickySlowCallPat args = ifTicky $ do


=====================================
compiler/GHC/StgToJS/Arg.hs
=====================================
@@ -118,7 +118,7 @@ genStaticArg a = case a of
       Nothing -> reg
       Just expr -> unfloated expr
      where
-       r = unaryTypeJSRep . stgArgType $ a
+       r = primRepToJSRep $ stgArgRep1 a
        reg
          | isVoid r            =
              return []
@@ -160,7 +160,7 @@ genArg a = case a of
    where
      -- if our argument is a joinid, it can be an unboxed tuple
      r :: HasDebugCallStack => JSRep
-     r = unaryTypeJSRep . stgArgType $ a
+     r = primRepToJSRep $ stgArgRep1 a
 
      unfloated :: HasDebugCallStack => CgStgExpr -> G [JExpr]
      unfloated = \case


=====================================
compiler/GHC/Types/RepType.hs
=====================================
@@ -4,7 +4,7 @@
 module GHC.Types.RepType
   (
     -- * Code generator views onto Types
-    UnaryType, NvUnaryType, isNvUnaryType,
+    UnaryType, NvUnaryType, isNvUnaryRep,
     unwrapType,
 
     -- * Predicates on types
@@ -19,7 +19,7 @@ module GHC.Types.RepType
     runtimeRepPrimRep_maybe, kindPrimRep_maybe, typePrimRep_maybe,
 
     -- * Unboxed sum representation type
-    ubxSumRepType, layoutUbxSum, typeSlotTy, SlotTy (..),
+    ubxSumRepType, layoutUbxSum, repSlotTy, SlotTy (..),
     slotPrimRep, primRepSlot,
 
     -- * Is this type known to be data?
@@ -76,12 +76,9 @@ type UnaryType   = Type
      --   UnaryType   : never an unboxed tuple or sum;
      --                 can be Void# or (# #)
 
-isNvUnaryType :: Type -> Bool
-isNvUnaryType ty
-  | [_] <- typePrimRep ty
-  = True
-  | otherwise
-  = False
+isNvUnaryRep :: [PrimRep] -> Bool
+isNvUnaryRep [_] = True
+isNvUnaryRep _ = False
 
 -- INVARIANT: the result list is never empty.
 typePrimRepArgs :: HasDebugCallStack => Type -> NonEmpty PrimRep
@@ -307,11 +304,11 @@ instance Outputable SlotTy where
   ppr FloatSlot       = text "FloatSlot"
   ppr (VecSlot n e)   = text "VecSlot" <+> ppr n <+> ppr e
 
-typeSlotTy :: UnaryType -> Maybe SlotTy
-typeSlotTy ty = case typePrimRep ty of
+repSlotTy :: [PrimRep] -> Maybe SlotTy
+repSlotTy reps = case reps of
                   [] -> Nothing
                   [rep] -> Just (primRepSlot rep)
-                  reps -> pprPanic "typeSlotTy" (ppr ty $$ ppr reps)
+                  _ -> pprPanic "repSlotTy" (ppr reps)
 
 primRepSlot :: PrimRep -> SlotTy
 primRepSlot VoidRep     = pprPanic "primRepSlot" (text "No slot for VoidRep")



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1dbdb9d0b58a6145970e11639b970f85df6ce2b4

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1dbdb9d0b58a6145970e11639b970f85df6ce2b4
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/20230927/0f68382c/attachment-0001.html>


More information about the ghc-commits mailing list