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

Commits:

14 changed files:

Changes:

  • compiler/GHC/Cmm/Utils.hs
    ... ... @@ -41,7 +41,7 @@ module GHC.Cmm.Utils(
    41 41
    42 42 
             -- Tagging
    43 43 
             cmmTagMask, cmmPointerMask, cmmUntag, cmmIsTagged, cmmIsNotTagged,
    44 
    -        cmmConstrTag1, mAX_PTR_TAG, tAG_MASK,
    44 
    +        cmmConstrTag1,
    45 45
    46 46 
             -- Overlap and usage
    47 47 
             regsOverlap, globalRegsOverlap, regUsedIn, globalRegUsedIn,
    ... ... @@ -67,6 +67,7 @@ import GHC.Core.TyCon ( PrimRep(..), PrimElemRep(..) )
    67 67 
     import GHC.Types.RepType  ( NvUnaryType, SlotTy (..), typePrimRepU )
    68 68
    69 69 
     import GHC.Platform
    70 
    +import GHC.Platform.Tag (tAG_MASK)
    70 71 
     import GHC.Runtime.Heap.Layout
    71 72 
     import GHC.Cmm
    72 73 
     import GHC.Cmm.BlockId
    ... ... @@ -380,12 +381,6 @@ cmmMkAssign platform expr uq =
    380 381 
     --
    381 382 
     ---------------------------------------------------
    382 383
    383 
    -tAG_MASK :: Platform -> Int
    384 
    -tAG_MASK platform = (1 `shiftL` pc_TAG_BITS (platformConstants platform)) - 1
    385 
    -
    386 
    -mAX_PTR_TAG :: Platform -> Int
    387 
    -mAX_PTR_TAG = tAG_MASK
    388 
    -
    389 384 
     -- Tag bits mask
    390 385 
     cmmTagMask, cmmPointerMask :: Platform -> CmmExpr
    391 386 
     cmmTagMask platform = mkIntExpr platform (tAG_MASK platform)

  • compiler/GHC/Platform/Tag.hs
    1 
    +-- | Dynamic pointer tagging
    2 
    +--
    3 
    +-- See Note [Data constructor dynamic tags]
    4 
    +module GHC.Platform.Tag
    5 
    +  ( DynTag
    6 
    +  , tAG_MASK
    7 
    +  , mAX_PTR_TAG
    8 
    +  , isSmallFamily
    9 
    +  ) where
    10 
    +
    11 
    +import GHC.Prelude
    12 
    +
    13 
    +import GHC.Platform
    14 
    +
    15 
    +-- | The tag on a pointer (from the dynamic-tagging paper)
    16 
    +type DynTag = Int
    17 
    +
    18 
    +{- Note [Data constructor dynamic tags]
    19 
    +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    20 
    +
    21 
    +The family size of a data type (the number of constructors
    22 
    +or the arity of a function) can be either:
    23 
    +   * small, if the family size < 2**tag_bits
    24 
    +   * big, otherwise.
    25 
    +
    26 
    +Small families can have the constructor tag in the tag bits.
    27 
    +Big families always use the tag values 1..mAX_PTR_TAG to represent
    28 
    +evaluatedness, the last one lumping together all overflowing ones.
    29 
    +We don't have very many tag bits: for example, we have 2 bits on
    30 
    +x86-32 and 3 bits on x86-64.
    31 
    +
    32 
    +Also see Note [Tagging big families] in GHC.StgToCmm.Expr
    33 
    +
    34 
    +The interpreter also needs to be updated if we change the
    35 
    +tagging strategy; see tagConstr in rts/Interpreter.c.
    36 
    +-}
    37 
    +
    38 
    +-- | Tag bits mask / maximum pointer tag value, derived from the
    39 
    +-- number of tag bits on the platform.
    40 
    +tAG_MASK, mAX_PTR_TAG :: Platform -> Int
    41 
    +tAG_MASK platform = (1 `shiftL` pc_TAG_BITS (platformConstants platform)) - 1
    42 
    +mAX_PTR_TAG = tAG_MASK
    43 
    +
    44 
    +-- | Is a data type family small enough that each constructor can get
    45 
    +-- its own pointer tag?
    46 
    +isSmallFamily :: Platform -> Int -> Bool
    47 
    +isSmallFamily platform fam_size = fam_size <= mAX_PTR_TAG platform

  • compiler/GHC/StgToCmm/Closure.hs
    ... ... @@ -65,12 +65,12 @@ module GHC.StgToCmm.Closure (
    65 65
    66 66 
     import GHC.Prelude
    67 67 
     import GHC.Platform
    68 
    +import GHC.Platform.Tag (DynTag, mAX_PTR_TAG, isSmallFamily)
    68 69 
     import GHC.Platform.Profile
    69 70
    70 71 
     import GHC.Stg.Syntax
    71 72 
     import GHC.Runtime.Heap.Layout
    72 73 
     import GHC.Cmm
    73 
    -import GHC.Cmm.Utils
    74 74 
     import GHC.StgToCmm.Types
    75 75 
     import GHC.StgToCmm.Sequel
    76 76
    ... ... @@ -319,31 +319,6 @@ mkLFStringLit = LFUnlifted
    319 319 
     --                Dynamic pointer tagging
    320 320 
     -----------------------------------------------------
    321 321
    322 
    -type DynTag = Int       -- The tag on a *pointer*
    323 
    -                        -- (from the dynamic-tagging paper)
    324 
    -
    325 
    --- Note [Data constructor dynamic tags]
    326 
    --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    327 
    ---
    328 
    --- The family size of a data type (the number of constructors
    329 
    --- or the arity of a function) can be either:
    330 
    ---    * small, if the family size < 2**tag_bits
    331 
    ---    * big, otherwise.
    332 
    ---
    333 
    --- Small families can have the constructor tag in the tag bits.
    334 
    --- Big families always use the tag values 1..mAX_PTR_TAG to represent
    335 
    --- evaluatedness, the last one lumping together all overflowing ones.
    336 
    --- We don't have very many tag bits: for example, we have 2 bits on
    337 
    --- x86-32 and 3 bits on x86-64.
    338 
    ---
    339 
    --- Also see Note [Tagging big families] in GHC.StgToCmm.Expr
    340 
    ---
    341 
    --- The interpreter also needs to be updated if we change the
    342 
    --- tagging strategy; see tagConstr in rts/Interpreter.c.
    343 
    -
    344 
    -isSmallFamily :: Platform -> Int -> Bool
    345 
    -isSmallFamily platform fam_size = fam_size <= mAX_PTR_TAG platform
    346 
    -
    347 322 
     tagForCon :: Platform -> DataCon -> DynTag
    348 323 
     tagForCon platform con = min (dataConTag con) (mAX_PTR_TAG platform)
    349 324 
     -- NB: 1-indexed

  • compiler/GHC/StgToCmm/Expr.hs
    ... ... @@ -35,7 +35,8 @@ import GHC.Cmm.Graph
    35 35 
     import GHC.Cmm.BlockId
    36 36 
     import GHC.Cmm hiding ( succ )
    37 37 
     import GHC.Cmm.Info
    38 
    -import GHC.Cmm.Utils ( cmmTagMask, mkWordCLit, mAX_PTR_TAG )
    38 
    +import GHC.Cmm.Utils ( cmmTagMask, mkWordCLit )
    39 
    +import GHC.Platform.Tag ( mAX_PTR_TAG )
    39 40 
     import GHC.Core
    40 41 
     import GHC.Core.DataCon
    41 42 
     import GHC.Types.ForeignCall

  • compiler/GHC/Tc/Instance/Class.hs
    ... ... @@ -52,7 +52,7 @@ import GHC.Core.Class
    52 52 
     import GHC.Core.Utils( mkCast )
    53 53 
     import GHC.Core ( Expr(..), mkConApp )
    54 54
    55 
    -import GHC.StgToCmm.Closure ( isSmallFamily )
    55 
    +import GHC.Platform.Tag ( isSmallFamily )
    56 56
    57 57 
     import GHC.Utils.Outputable
    58 58 
     import GHC.Utils.Panic

  • compiler/GHC/Tc/TyCl/Build.hs
    ... ... @@ -178,6 +178,7 @@ buildDataCon fam_envs dc_bang_opts src_name declared_infix prom_info src_bangs
    178 178 
             -- code, which (for Haskell source anyway) will be in the DataName name
    179 179 
             -- space, and puts it into the VarName name space
    180 180
    181 
    +        ; platform <- getPlatform
    181 182 
             ; traceIf (text "buildDataCon 1" <+> ppr src_name)
    182 183 
             ; us <- newUniqueSupply
    183 184 
             ; let stupid_ctxt = mkDataConStupidTheta rep_tycon (map scaledThing arg_tys) univ_tvs
    ... ... @@ -192,7 +193,7 @@ buildDataCon fam_envs dc_bang_opts src_name declared_infix prom_info src_bangs
    192 193 
                                        stupid_ctxt dc_wrk dc_rep
    193 194 
                   dc_wrk = mkDataConWorkId work_name data_con
    194 195 
                   (dc_rep, impl_bangs, str_marks) =
    195 
    -                 initUs_ us (mkDataConRep dc_bang_opts fam_envs wrap_name data_con)
    196 
    +                 initUs_ us (mkDataConRep platform dc_bang_opts fam_envs wrap_name data_con)
    196 197
    197 198 
             ; traceIf (text "buildDataCon 2" <+> ppr src_name)
    198 199 
             ; return data_con }

  • compiler/GHC/Types/Id/Make.hs
    ... ... @@ -95,6 +95,11 @@ import Data.List ( zipWith4 )
    95 95 
     import GHC.StgToCmm.Types (LambdaFormInfo(..))
    96 96 
     import GHC.Runtime.Heap.Layout (ArgDescr(ArgUnknown))
    97 97
    98 
    +import GHC.Builtin.PrimOps.Ids (primOpId)
    99 
    +import GHC.Builtin.PrimOps (PrimOp(..))
    100 
    +import GHC.Platform (Platform)
    101 
    +import GHC.Platform.Tag (isSmallFamily)
    102 
    +
    98 103 
     {-
    99 104 
     ************************************************************************
    100 105 
     *                                                                      *
    ... ... @@ -783,12 +788,13 @@ data BangOpts = BangOpts
    783 788 
       , bang_opt_unbox_small   :: !Bool -- ^ Unbox small strict fields
    784 789 
       }
    785 790
    786 
    -mkDataConRep :: DataConBangOpts
    791 
    +mkDataConRep :: Platform
    792 
    +             -> DataConBangOpts
    787 793 
                  -> FamInstEnvs
    788 794 
                  -> Name
    789 795 
                  -> DataCon
    790 796 
                  -> UniqSM (DataConRep, [HsImplBang], [StrictnessMark])
    791 
    -mkDataConRep dc_bang_opts fam_envs wrap_name data_con
    797 
    +mkDataConRep platform dc_bang_opts fam_envs wrap_name data_con
    792 798 
       | not wrapper_reqd
    793 799 
       = return (NoDataConRep, arg_ibangs, rep_strs)
    794 800
    ... ... @@ -905,12 +911,12 @@ mkDataConRep dc_bang_opts fam_envs wrap_name data_con
    905 911 
                                             -- detect this later (see test T2334A)
    906 912 
           | otherwise
    907 913 
           = case dc_bang_opts of
    908 
    -          SrcBangOpts bang_opts -> zipWith (dataConSrcToImplBang bang_opts fam_envs)
    914 
    +          SrcBangOpts bang_opts -> zipWith (dataConSrcToImplBang platform bang_opts fam_envs)
    909 915 
                                         orig_arg_tys orig_bangs
    910 916 
               FixedBangOpts bangs   -> bangs
    911 917
    912 918 
         (rep_tys_w_strs, wrappers)
    913 
    -      = unzip (zipWith dataConArgRep all_arg_tys (ev_ibangs ++ arg_ibangs))
    919 
    +      = unzip (zipWith (dataConArgRep platform) all_arg_tys (ev_ibangs ++ arg_ibangs))
    914 920
    915 921 
         (unboxers, boxers) = unzip wrappers
    916 922 
         (rep_tys, rep_strs) = unzip (concat rep_tys_w_strs)
    ... ... @@ -1149,24 +1155,25 @@ newLocal name_stem (Scaled w ty) =
    1149 1155 
     -- never on the field of a newtype constructor.
    1150 1156 
     -- See @Note [HsImplBangs for newtypes]@.
    1151 1157 
     dataConSrcToImplBang
    1152 
    -   :: BangOpts
    1158 
    +   :: Platform
    1159 
    +   -> BangOpts
    1153 1160 
        -> FamInstEnvs
    1154 1161 
        -> Scaled Type
    1155 1162 
        -> HsSrcBang
    1156 1163 
        -> HsImplBang
    1157 1164
    1158 
    -dataConSrcToImplBang bang_opts fam_envs arg_ty
    1165 
    +dataConSrcToImplBang platform bang_opts fam_envs arg_ty
    1159 1166 
                          (HsSrcBang ann unpk NoSrcStrict)
    1160 1167 
       | bang_opt_strict_data bang_opts -- StrictData => strict field
    1161 
    -  = dataConSrcToImplBang bang_opts fam_envs arg_ty
    1168 
    +  = dataConSrcToImplBang platform bang_opts fam_envs arg_ty
    1162 1169 
                       (HsSrcBang ann unpk SrcStrict)
    1163 1170 
       | otherwise -- no StrictData => lazy field
    1164 1171 
       = HsLazy
    1165 1172
    1166 
    -dataConSrcToImplBang _ _ _ (HsSrcBang _ _ SrcLazy)
    1173 
    +dataConSrcToImplBang _ _ _ _ (HsSrcBang _ _ SrcLazy)
    1167 1174 
       = HsLazy
    1168 1175
    1169 
    -dataConSrcToImplBang bang_opts fam_envs arg_ty
    1176 
    +dataConSrcToImplBang platform bang_opts fam_envs arg_ty
    1170 1177 
                          (HsSrcBang _ unpk_prag SrcStrict)
    1171 1178 
       | isUnliftedType (scaledThing arg_ty)
    1172 1179 
         -- NB: non-newtype data constructors can't have representation-polymorphic fields
    ... ... @@ -1179,7 +1186,7 @@ dataConSrcToImplBang bang_opts fam_envs arg_ty
    1179 1186 
             arg_ty' = case mb_co of
    1180 1187 
                         { Just redn -> scaledSet arg_ty (reductionReducedType redn)
    1181 1188 
                         ; Nothing   -> arg_ty }
    1182 
    -  , shouldUnpackArgTy bang_opts unpk_prag fam_envs arg_ty'
    1189 
    +  , shouldUnpackArgTy platform bang_opts unpk_prag fam_envs arg_ty'
    1183 1190 
       = if bang_opt_unbox_disable bang_opts
    1184 1191 
         then HsStrict True -- Not unpacking because of -O0
    1185 1192 
                            -- See Note [Detecting useless UNPACK pragmas] in GHC.Core.DataCon
    ... ... @@ -1193,23 +1200,24 @@ dataConSrcToImplBang bang_opts fam_envs arg_ty
    1193 1200 
     -- | Wrappers/Workers and representation following Unpack/Strictness
    1194 1201 
     -- decisions
    1195 1202 
     dataConArgRep
    1196 
    -  :: Scaled Type
    1203 
    +  :: Platform
    1204 
    +  -> Scaled Type
    1197 1205 
       -> HsImplBang
    1198 1206 
       -> ([(Scaled Type,StrictnessMark)] -- Rep types
    1199 1207 
          ,(Unboxer,Boxer))
    1200 1208
    1201 
    -dataConArgRep arg_ty HsLazy
    1209 
    +dataConArgRep _ arg_ty HsLazy
    1202 1210 
       = ([(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer))
    1203 1211
    1204 
    -dataConArgRep arg_ty (HsStrict _)
    1212 
    +dataConArgRep _ arg_ty (HsStrict _)
    1205 1213 
       = ([(arg_ty, MarkedStrict)], (unitUnboxer, unitBoxer)) -- Seqs are inserted in STG
    1206 1214
    1207 
    -dataConArgRep arg_ty (HsUnpack Nothing)
    1208 
    -  = dataConArgUnpack arg_ty
    1215 
    +dataConArgRep platform arg_ty (HsUnpack Nothing)
    1216 
    +  = dataConArgUnpack platform arg_ty
    1209 1217
    1210 
    -dataConArgRep (Scaled w _) (HsUnpack (Just co))
    1218 
    +dataConArgRep platform (Scaled w _) (HsUnpack (Just co))
    1211 1219 
       | let co_rep_ty = coercionRKind co
    1212 
    -  , (rep_tys, wrappers) <- dataConArgUnpack (Scaled w co_rep_ty)
    1220 
    +  , (rep_tys, wrappers) <- dataConArgUnpack platform (Scaled w co_rep_ty)
    1213 1221 
       = (rep_tys, wrapCo co co_rep_ty wrappers)
    1214 1222
    1215 1223
    ... ... @@ -1334,19 +1342,92 @@ problem entirely by treating sums and products differently here.
    1334 1342 
     -}
    1335 1343
    1336 1344 
     dataConArgUnpack
    1337 
    -   :: Scaled Type
    1345 
    +   :: Platform
    1346 
    +   -> Scaled Type
    1338 1347 
        ->  ( [(Scaled Type, StrictnessMark)]   -- Rep types
    1339 1348 
            , (Unboxer, Boxer) )
    1340 
    -dataConArgUnpack scaledTy@(Scaled _ arg_ty)
    1349 
    +dataConArgUnpack platform scaledTy@(Scaled _ arg_ty)
    1341 1350 
       | Just (tc, tc_args) <- splitTyConApp_maybe arg_ty
    1342 1351 
       = assert (not (isNewTyCon tc)) $
    1343 1352 
         case tyConDataCons tc of
    1344 1353 
           [con] -> dataConArgUnpackProduct scaledTy tc_args con
    1354 
    +      cons | all (null . dataConOrigArgTys) cons
    1355 
    +            -> dataConArgUnpackEnum platform scaledTy tc_args cons
    1345 1356 
           cons  -> dataConArgUnpackSum scaledTy tc_args cons
    1346 1357 
       | otherwise
    1347 1358 
       = pprPanic "dataConArgUnpack" (ppr arg_ty)
    1348 1359 
         -- An interface file specified Unpacked, but we couldn't unpack it
    1349 1360
    1361 
    +{- Note [UNPACK for enum types]
    1362 
    +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    1363 
    +When a strict field has an enumeration type (all constructors are nullary),
    1364 
    +we unpack it to a single narrow primitive word rather than an unboxed sum.
    1365 
    +
    1366 
    +For example, given:
    1367 
    +   data Color = Red | Green | Blue
    1368 
    +   data Foo = MkFoo {-# UNPACK #-} !Color
    1369 
    +
    1370 
    +the worker for MkFoo will have a Word8# field.
    1371 
    +
    1372 
    +Avoiding the intermediate unboxed sum allows us to use branchless conversion
    1373 
    +operations DataToTag and TagToEnum.
    1374 
    +-}
    1375 
    +
    1376 
    +dataConArgUnpackEnum
    1377 
    +  :: Platform
    1378 
    +  -> Scaled Type
    1379 
    +  -> [Type]
    1380 
    +  -> [DataCon]
    1381 
    +  -> ( [(Scaled Type, StrictnessMark)]   -- Rep types
    1382 
    +      , (Unboxer, Boxer) )
    1383 
    +dataConArgUnpackEnum platform (Scaled arg_mult ty) _tc_args cons =
    1384 
    +  ( [ (scaled_enum_ty, MarkedStrict) ] -- See Note [UNPACK for enum types]
    1385 
    +  , ( unboxer, boxer ) )
    1386 
    +  where
    1387 
    +    !enum_sum_arity = length cons
    1388 
    +    conv op e = App (Var (primOpId op)) e
    1389 
    +
    1390 
    +    conv_tag_levpoly op e = App (mkTyApps (Var (primOpId op)) [getLevity ty, ty]) e
    1391 
    +
    1392 
    +    (enum_ty, unbox_convert, box_convert)
    1393 
    +       | enum_sum_arity < 256   = (word8PrimTy, conv WordToWord8Op, conv Word8ToWordOp)
    1394 
    +       | enum_sum_arity < 65536 = (word16PrimTy, conv WordToWord16Op, conv Word16ToWordOp)
    1395 
    +       | otherwise              = (wordPrimTy, id, id)
    1396 
    +    scaled_enum_ty = Scaled arg_mult enum_ty
    1397 
    +
    1398 
    +    datatotag_op
    1399 
    +       | isSmallFamily platform enum_sum_arity = DataToTagSmallOp
    1400 
    +       | otherwise                             = DataToTagLargeOp
    1401 
    +
    1402 
    +    -- Tags are 1-based: add 1 to 0-based DataToTag result
    1403 
    +    add_one e = App (App (Var (primOpId IntAddOp)) e)
    1404 
    +                    (Lit (LitNumber LitNumInt 1))
    1405 
    +    -- Subtract 1 to convert back to 0-based for TagToEnum
    1406 
    +    sub_one e = App (App (Var (primOpId IntSubOp)) e)
    1407 
    +                    (Lit (LitNumber LitNumInt 1))
    1408 
    +
    1409 
    +    unboxer v = do enum_rep_id <- newLocal (fsLit "unbx_enum") scaled_enum_ty
    1410 
    +                   let unbox_fn body
    1411 
    +                              = mkSingleAltCase
    1412 
    +                                    (unbox_convert (App (Var (primOpId IntToWordOp))
    1413 
    +                                                        (add_one (conv_tag_levpoly datatotag_op (Var v)))))
    1414 
    +                                    enum_rep_id
    1415 
    +                                    DEFAULT
    1416 
    +                                    []
    1417 
    +                                    body
    1418 
    +                   return ([enum_rep_id], unbox_fn)
    1419 
    +
    1420 
    +    boxer = Boxer $ \ subst -> do
    1421 
    +                let ty' = TcType.substTyUnchecked subst ty
    1422 
    +                    conv_tag' op e = App (mkTyApps (Var (primOpId op)) [ty']) e
    1423 
    +                enum_rep_id <- newLocal (fsLit "bx_enum")
    1424 
    +                                        (TcType.substScaledTyUnchecked subst scaled_enum_ty)
    1425 
    +                let box_fn = conv_tag'
    1426 
    +                               TagToEnumOp
    1427 
    +                               (sub_one (App (Var (primOpId WordToIntOp))
    1428 
    +                                             (box_convert (Var enum_rep_id))))
    1429 
    +                return ([enum_rep_id], box_fn)
    1430 
    +
    1350 1431 
     dataConArgUnpackProduct
    1351 1432 
       :: Scaled Type
    1352 1433 
       -> [Type]
    ... ... @@ -1452,13 +1533,13 @@ mkUbxSumAltTy :: [Type] -> Type
    1452 1533 
     mkUbxSumAltTy [ty] = ty
    1453 1534 
     mkUbxSumAltTy tys  = mkTupleTy Unboxed tys
    1454 1535
    1455 
    -shouldUnpackArgTy :: BangOpts -> SrcUnpackedness -> FamInstEnvs -> Scaled Type -> Bool
    1536 
    +shouldUnpackArgTy :: Platform -> BangOpts -> SrcUnpackedness -> FamInstEnvs -> Scaled Type -> Bool
    1456 1537 
     -- True if we ought to unpack the UNPACK the argument type
    1457 1538 
     -- See Note [Recursive unboxing]
    1458 1539 
     -- We look "deeply" inside rather than relying on the DataCons
    1459 1540 
     -- we encounter on the way, because otherwise we might well
    1460 1541 
     -- end up relying on ourselves!
    1461 
    -shouldUnpackArgTy bang_opts prag fam_envs arg_ty
    1542 
    +shouldUnpackArgTy platform bang_opts prag fam_envs arg_ty
    1462 1543 
       | Just data_cons <- unpackable_type_datacons (scaledThing arg_ty)
    1463 1544 
       , all ok_con data_cons                -- Returns True only if we can't get a
    1464 1545 
                                             -- loop involving these data cons
    ... ... @@ -1534,7 +1615,7 @@ shouldUnpackArgTy bang_opts prag fam_envs arg_ty
    1534 1615 
                  || (bang_opt_unbox_small bang_opts
    1535 1616 
                      && is_small_rep)  -- See Note [Unpack one-wide fields]
    1536 1617 
           where
    1537 
    -        (rep_tys, _) = dataConArgUnpack arg_ty
    1618 
    +        (rep_tys, _) = dataConArgUnpack platform arg_ty
    1538 1619
    1539 1620 
             -- Takes in the list of reps used to represent the dataCon after it's unpacked
    1540 1621 
             -- and tells us if they can fit into 8 bytes. See Note [Unpack one-wide fields]

  • compiler/GHC/Types/RepType.hs
    ... ... @@ -228,7 +228,7 @@ ubxSumRepType constrs0
    228 228 
           rep :: [PrimRep] -> SortedSlotTys
    229 229 
           rep ty = sort (map primRepSlot ty)
    230 230
    231 
    -      -- constructors start at 1, pick an appropriate slot size for the tag
    231 
    +      -- constructors are 1-based, pick an appropriate slot size for the tag
    232 232 
           tag_slot | length constrs0 < 256        = Word8Slot
    233 233 
                    | length constrs0 < 65536      = Word16Slot
    234 234 
                    -- we use 2147483647 instead of 4294967296 to avoid

  • compiler/ghc.cabal.in
    ... ... @@ -675,6 +675,7 @@ Library
    675 675 
             GHC.Platform.NoRegs
    676 676 
             GHC.Platform.PPC
    677 677 
             GHC.Platform.Profile
    678 
    +        GHC.Platform.Tag
    678 679 
             GHC.Platform.Reg
    679 680 
             GHC.Platform.Reg.Class
    680 681 
             GHC.Platform.Reg.Class.NoVectors

  • testsuite/tests/count-deps/CountDepsAst.stdout
    1 1 
     Found Language.Haskell.Syntax module dependencies
    2 2 
     GHC.Builtin.Names
    3 3 
     GHC.Builtin.PrimOps
    4 
    +GHC.Builtin.PrimOps.Ids
    4 5 
     GHC.Builtin.Types
    5 6 
     GHC.Builtin.Types.Literals
    6 7 
     GHC.Builtin.Types.Prim
    ... ... @@ -8,6 +9,7 @@ GHC.Builtin.Uniques
    8 9 
     GHC.Cmm.BlockId
    9 10 
     GHC.Cmm.CLabel
    10 11 
     GHC.Cmm.Dataflow.Label
    12 
    +GHC.Cmm.MachOp
    11 13 
     GHC.Cmm.Type
    12 14 
     GHC.CmmToAsm.CFG.Weight
    13 15 
     GHC.Core
    ... ... @@ -21,10 +23,12 @@ GHC.Core.FVs
    21 23 
     GHC.Core.FamInstEnv
    22 24 
     GHC.Core.InstEnv
    23 25 
     GHC.Core.Make
    26 
    +GHC.Core.Map.Expr
    24 27 
     GHC.Core.Map.Type
    25 28 
     GHC.Core.Multiplicity
    26 29 
     GHC.Core.Opt.Arity
    27 30 
     GHC.Core.Opt.CallerCC.Types
    31 
    +GHC.Core.Opt.ConstantFold
    28 32 
     GHC.Core.Opt.OccurAnal
    29 33 
     GHC.Core.PatSyn
    30 34 
     GHC.Core.Ppr
    ... ... @@ -118,6 +122,7 @@ GHC.Parser.Errors.Basic
    118 122 
     GHC.Platform
    119 123 
     GHC.Platform.Constants
    120 124 
     GHC.Platform.Profile
    125 
    +GHC.Platform.Tag
    121 126 
     GHC.Platform.Ways
    122 127 
     GHC.Prelude
    123 128 
     GHC.Prelude.Basic

  • testsuite/tests/count-deps/CountDepsParser.stdout
    1 1 
     Found GHC.Parser module dependencies
    2 2 
     GHC.Builtin.Names
    3 3 
     GHC.Builtin.PrimOps
    4 
    +GHC.Builtin.PrimOps.Ids
    4 5 
     GHC.Builtin.Types
    5 6 
     GHC.Builtin.Types.Literals
    6 7 
     GHC.Builtin.Types.Prim
    ... ... @@ -8,6 +9,7 @@ GHC.Builtin.Uniques
    8 9 
     GHC.Cmm.BlockId
    9 10 
     GHC.Cmm.CLabel
    10 11 
     GHC.Cmm.Dataflow.Label
    12 
    +GHC.Cmm.MachOp
    11 13 
     GHC.Cmm.Type
    12 14 
     GHC.CmmToAsm.CFG.Weight
    13 15 
     GHC.Core
    ... ... @@ -26,6 +28,7 @@ GHC.Core.Map.Type
    26 28 
     GHC.Core.Multiplicity
    27 29 
     GHC.Core.Opt.Arity
    28 30 
     GHC.Core.Opt.CallerCC.Types
    31 
    +GHC.Core.Opt.ConstantFold
    29 32 
     GHC.Core.Opt.OccurAnal
    30 33 
     GHC.Core.PatSyn
    31 34 
     GHC.Core.Ppr
    ... ... @@ -137,6 +140,7 @@ GHC.Parser.Types
    137 140 
     GHC.Platform
    138 141 
     GHC.Platform.Constants
    139 142 
     GHC.Platform.Profile
    143 
    +GHC.Platform.Tag
    140 144 
     GHC.Platform.Ways
    141 145 
     GHC.Prelude
    142 146 
     GHC.Prelude.Basic

  • testsuite/tests/simplStg/should_run/all.T
    ... ... @@ -20,4 +20,5 @@ test('T13536a',
    20 20
    21 21 
     test('inferTags001', normal, multimod_compile_and_run, ['inferTags001', 'inferTags001_a'])
    22 22 
     test('T22042', [extra_files(['T22042a.hs']),only_ways('normal'),unless(have_dynamic(), skip)], makefile_test, ['T22042'])
    23 
    -test('T23783', normal, multimod_compile_and_run, ['T23783', '-O -v0'])
    \ No newline at end of file
    23 
    +test('T23783', normal, multimod_compile_and_run, ['T23783', '-O -v0'])
    24 
    +test('unpack_enum', normal, compile_and_run, [''])
    \ No newline at end of file

  • testsuite/tests/simplStg/should_run/unpack_enum.hs
    1 
    +{-# LANGUAGE MagicHash #-}
    2 
    +
    3 
    +-- | Test branchless enum unboxing.
    4 
    +-- See Note [UNPACK for enum types] in GHC.Types.Id.Make.
    5 
    +--
    6 
    +-- When a strict field has an enumeration type (all nullary constructors),
    7 
    +-- it should be unpacked to a single narrow primitive word (Word8#, Word16#,
    8 
    +-- or Word#) rather than an unboxed sum, using dataToTag#/tagToEnum# for
    9 
    +-- branchless conversion.
    10 
    +
    11 
    +module Main where
    12 
    +
    13 
    +import GHC.Exts.Heap.Closures (closureSize, asBox)
    14 
    +import Control.Exception (evaluate)
    15 
    +
    16 
    +------------------------------------------------------------
    17 
    +-- Small enum (2 constructors, like Bool)
    18 
    +------------------------------------------------------------
    19 
    +
    20 
    +data Toggle = Off | On
    21 
    +  deriving (Show, Eq)
    22 
    +
    23 
    +data BoxToggle = BoxToggle {-# UNPACK #-} !Toggle
    24 
    +                           {-# UNPACK #-} !Toggle
    25 
    +  deriving (Show)
    26 
    +
    27 
    +------------------------------------------------------------
    28 
    +-- Medium enum (5 constructors)
    29 
    +------------------------------------------------------------
    30 
    +
    31 
    +data Color = Red | Green | Blue | Yellow | Purple
    32 
    +  deriving (Show, Eq)
    33 
    +
    34 
    +data BoxColor = BoxColor {-# UNPACK #-} !Color
    35 
    +                         {-# UNPACK #-} !Color
    36 
    +  deriving (Show)
    37 
    +
    38 
    +------------------------------------------------------------
    39 
    +-- Phantom type parameter enum
    40 
    +-- Tests that the boxer correctly substitutes type variables.
    41 
    +------------------------------------------------------------
    42 
    +
    43 
    +data Proxy a = PA | PB | PC
    44 
    +  deriving (Show, Eq)
    45 
    +
    46 
    +data BoxProxy = BoxProxy {-# UNPACK #-} !(Proxy Int)
    47 
    +                         {-# UNPACK #-} !(Proxy Char)
    48 
    +  deriving (Show)
    49 
    +
    50 
    +------------------------------------------------------------
    51 
    +-- Enum with exactly 255 constructors (boundary for Word8#)
    52 
    +-- With 1-based tags, 255 constructors have tags 1-255 which
    53 
    +-- fit in Word8#.
    54 
    +------------------------------------------------------------
    55 
    +
    56 
    +data E255
    57 
    +  = E255_0 | E255_1 | E255_2 | E255_3 | E255_4 | E255_5 | E255_6 | E255_7
    58 
    +  | E255_8 | E255_9 | E255_10 | E255_11 | E255_12 | E255_13 | E255_14 | E255_15
    59 
    +  | E255_16 | E255_17 | E255_18 | E255_19 | E255_20 | E255_21 | E255_22 | E255_23
    60 
    +  | E255_24 | E255_25 | E255_26 | E255_27 | E255_28 | E255_29 | E255_30 | E255_31
    61 
    +  | E255_32 | E255_33 | E255_34 | E255_35 | E255_36 | E255_37 | E255_38 | E255_39
    62 
    +  | E255_40 | E255_41 | E255_42 | E255_43 | E255_44 | E255_45 | E255_46 | E255_47
    63 
    +  | E255_48 | E255_49 | E255_50 | E255_51 | E255_52 | E255_53 | E255_54 | E255_55
    64 
    +  | E255_56 | E255_57 | E255_58 | E255_59 | E255_60 | E255_61 | E255_62 | E255_63
    65 
    +  | E255_64 | E255_65 | E255_66 | E255_67 | E255_68 | E255_69 | E255_70 | E255_71
    66 
    +  | E255_72 | E255_73 | E255_74 | E255_75 | E255_76 | E255_77 | E255_78 | E255_79
    67 
    +  | E255_80 | E255_81 | E255_82 | E255_83 | E255_84 | E255_85 | E255_86 | E255_87
    68 
    +  | E255_88 | E255_89 | E255_90 | E255_91 | E255_92 | E255_93 | E255_94 | E255_95
    69 
    +  | E255_96 | E255_97 | E255_98 | E255_99 | E255_100 | E255_101 | E255_102 | E255_103
    70 
    +  | E255_104 | E255_105 | E255_106 | E255_107 | E255_108 | E255_109 | E255_110 | E255_111
    71 
    +  | E255_112 | E255_113 | E255_114 | E255_115 | E255_116 | E255_117 | E255_118 | E255_119
    72 
    +  | E255_120 | E255_121 | E255_122 | E255_123 | E255_124 | E255_125 | E255_126 | E255_127
    73 
    +  | E255_128 | E255_129 | E255_130 | E255_131 | E255_132 | E255_133 | E255_134 | E255_135
    74 
    +  | E255_136 | E255_137 | E255_138 | E255_139 | E255_140 | E255_141 | E255_142 | E255_143
    75 
    +  | E255_144 | E255_145 | E255_146 | E255_147 | E255_148 | E255_149 | E255_150 | E255_151
    76 
    +  | E255_152 | E255_153 | E255_154 | E255_155 | E255_156 | E255_157 | E255_158 | E255_159
    77 
    +  | E255_160 | E255_161 | E255_162 | E255_163 | E255_164 | E255_165 | E255_166 | E255_167
    78 
    +  | E255_168 | E255_169 | E255_170 | E255_171 | E255_172 | E255_173 | E255_174 | E255_175
    79 
    +  | E255_176 | E255_177 | E255_178 | E255_179 | E255_180 | E255_181 | E255_182 | E255_183
    80 
    +  | E255_184 | E255_185 | E255_186 | E255_187 | E255_188 | E255_189 | E255_190 | E255_191
    81 
    +  | E255_192 | E255_193 | E255_194 | E255_195 | E255_196 | E255_197 | E255_198 | E255_199
    82 
    +  | E255_200 | E255_201 | E255_202 | E255_203 | E255_204 | E255_205 | E255_206 | E255_207
    83 
    +  | E255_208 | E255_209 | E255_210 | E255_211 | E255_212 | E255_213 | E255_214 | E255_215
    84 
    +  | E255_216 | E255_217 | E255_218 | E255_219 | E255_220 | E255_221 | E255_222 | E255_223
    85 
    +  | E255_224 | E255_225 | E255_226 | E255_227 | E255_228 | E255_229 | E255_230 | E255_231
    86 
    +  | E255_232 | E255_233 | E255_234 | E255_235 | E255_236 | E255_237 | E255_238 | E255_239
    87 
    +  | E255_240 | E255_241 | E255_242 | E255_243 | E255_244 | E255_245 | E255_246 | E255_247
    88 
    +  | E255_248 | E255_249 | E255_250 | E255_251 | E255_252 | E255_253 | E255_254
    89 
    +  deriving (Show, Eq, Enum, Bounded)
    90 
    +
    91 
    +-- Two E255 fields should fit in a single word (2 x Word8# = 2 bytes),
    92 
    +-- so the closure should be header (1 word) + 1 payload word = size 2.
    93 
    +data BoxE255 = BoxE255 {-# UNPACK #-} !E255
    94 
    +                       {-# UNPACK #-} !E255
    95 
    +  deriving (Show)
    96 
    +
    97 
    +------------------------------------------------------------
    98 
    +-- Enum with exactly 256 constructors (just over Word8# boundary).
    99 
    +-- With 1-based tags, tag 256 does not fit in Word8#,
    100 
    +-- so this should use Word16# instead.
    101 
    +------------------------------------------------------------
    102 
    +
    103 
    +data E256
    104 
    +  = E256_0 | E256_1 | E256_2 | E256_3 | E256_4 | E256_5 | E256_6 | E256_7
    105 
    +  | E256_8 | E256_9 | E256_10 | E256_11 | E256_12 | E256_13 | E256_14 | E256_15
    106 
    +  | E256_16 | E256_17 | E256_18 | E256_19 | E256_20 | E256_21 | E256_22 | E256_23
    107 
    +  | E256_24 | E256_25 | E256_26 | E256_27 | E256_28 | E256_29 | E256_30 | E256_31
    108 
    +  | E256_32 | E256_33 | E256_34 | E256_35 | E256_36 | E256_37 | E256_38 | E256_39
    109 
    +  | E256_40 | E256_41 | E256_42 | E256_43 | E256_44 | E256_45 | E256_46 | E256_47
    110 
    +  | E256_48 | E256_49 | E256_50 | E256_51 | E256_52 | E256_53 | E256_54 | E256_55
    111 
    +  | E256_56 | E256_57 | E256_58 | E256_59 | E256_60 | E256_61 | E256_62 | E256_63
    112 
    +  | E256_64 | E256_65 | E256_66 | E256_67 | E256_68 | E256_69 | E256_70 | E256_71
    113 
    +  | E256_72 | E256_73 | E256_74 | E256_75 | E256_76 | E256_77 | E256_78 | E256_79
    114 
    +  | E256_80 | E256_81 | E256_82 | E256_83 | E256_84 | E256_85 | E256_86 | E256_87
    115 
    +  | E256_88 | E256_89 | E256_90 | E256_91 | E256_92 | E256_93 | E256_94 | E256_95
    116 
    +  | E256_96 | E256_97 | E256_98 | E256_99 | E256_100 | E256_101 | E256_102 | E256_103
    117 
    +  | E256_104 | E256_105 | E256_106 | E256_107 | E256_108 | E256_109 | E256_110 | E256_111
    118 
    +  | E256_112 | E256_113 | E256_114 | E256_115 | E256_116 | E256_117 | E256_118 | E256_119
    119 
    +  | E256_120 | E256_121 | E256_122 | E256_123 | E256_124 | E256_125 | E256_126 | E256_127
    120 
    +  | E256_128 | E256_129 | E256_130 | E256_131 | E256_132 | E256_133 | E256_134 | E256_135
    121 
    +  | E256_136 | E256_137 | E256_138 | E256_139 | E256_140 | E256_141 | E256_142 | E256_143
    122 
    +  | E256_144 | E256_145 | E256_146 | E256_147 | E256_148 | E256_149 | E256_150 | E256_151
    123 
    +  | E256_152 | E256_153 | E256_154 | E256_155 | E256_156 | E256_157 | E256_158 | E256_159
    124 
    +  | E256_160 | E256_161 | E256_162 | E256_163 | E256_164 | E256_165 | E256_166 | E256_167
    125 
    +  | E256_168 | E256_169 | E256_170 | E256_171 | E256_172 | E256_173 | E256_174 | E256_175
    126 
    +  | E256_176 | E256_177 | E256_178 | E256_179 | E256_180 | E256_181 | E256_182 | E256_183
    127 
    +  | E256_184 | E256_185 | E256_186 | E256_187 | E256_188 | E256_189 | E256_190 | E256_191
    128 
    +  | E256_192 | E256_193 | E256_194 | E256_195 | E256_196 | E256_197 | E256_198 | E256_199
    129 
    +  | E256_200 | E256_201 | E256_202 | E256_203 | E256_204 | E256_205 | E256_206 | E256_207
    130 
    +  | E256_208 | E256_209 | E256_210 | E256_211 | E256_212 | E256_213 | E256_214 | E256_215
    131 
    +  | E256_216 | E256_217 | E256_218 | E256_219 | E256_220 | E256_221 | E256_222 | E256_223
    132 
    +  | E256_224 | E256_225 | E256_226 | E256_227 | E256_228 | E256_229 | E256_230 | E256_231
    133 
    +  | E256_232 | E256_233 | E256_234 | E256_235 | E256_236 | E256_237 | E256_238 | E256_239
    134 
    +  | E256_240 | E256_241 | E256_242 | E256_243 | E256_244 | E256_245 | E256_246 | E256_247
    135 
    +  | E256_248 | E256_249 | E256_250 | E256_251 | E256_252 | E256_253 | E256_254 | E256_255
    136 
    +  deriving (Show, Eq, Enum, Bounded)
    137 
    +
    138 
    +data BoxE256 = BoxE256 {-# UNPACK #-} !E256
    139 
    +                       {-# UNPACK #-} !E256
    140 
    +  deriving (Show)
    141 
    +
    142 
    +------------------------------------------------------------
    143 
    +-- Boundary size comparison: 5 fields of E255 (Word8#) vs E256 (Word16#)
    144 
    +-- With 5 fields, Word8# fits in fewer payload words than Word16#
    145 
    +-- on all platforms, so we can verify the packing difference.
    146 
    +------------------------------------------------------------
    147 
    +
    148 
    +data Box5xE255 = Box5xE255 {-# UNPACK #-} !E255
    149 
    +                            {-# UNPACK #-} !E255
    150 
    +                            {-# UNPACK #-} !E255
    151 
    +                            {-# UNPACK #-} !E255
    152 
    +                            {-# UNPACK #-} !E255
    153 
    +
    154 
    +data Box5xE256 = Box5xE256 {-# UNPACK #-} !E256
    155 
    +                            {-# UNPACK #-} !E256
    156 
    +                            {-# UNPACK #-} !E256
    157 
    +                            {-# UNPACK #-} !E256
    158 
    +                            {-# UNPACK #-} !E256
    159 
    +
    160 
    +------------------------------------------------------------
    161 
    +-- Test helpers
    162 
    +------------------------------------------------------------
    163 
    +
    164 
    +test :: Show a => String -> a -> IO ()
    165 
    +test name value = do
    166 
    +    putStrLn $ "### " ++ name
    167 
    +    value' <- evaluate value
    168 
    +    print value'
    169 
    +    putStrLn ("size: " ++ show (closureSize $ asBox value'))
    170 
    +    putStrLn ""
    171 
    +
    172 
    +main :: IO ()
    173 
    +main = do
    174 
    +    -- Small enum: all constructor combinations
    175 
    +    test "toggle_off_off" (BoxToggle Off Off)
    176 
    +    test "toggle_on_on"   (BoxToggle On  On)
    177 
    +    test "toggle_off_on"  (BoxToggle Off On)
    178 
    +
    179 
    +    -- Medium enum: first, last, and middle constructors
    180 
    +    test "color_first"  (BoxColor Red    Red)
    181 
    +    test "color_last"   (BoxColor Purple Purple)
    182 
    +    test "color_mixed"  (BoxColor Green  Yellow)
    183 
    +
    184 
    +    -- Phantom type parameter: tests boxer substitution
    185 
    +    test "proxy" (BoxProxy PB PC)
    186 
    +
    187 
    +    -- 255-constructor enum (boundary): first and last tags
    188 
    +    test "e255_first" (BoxE255 E255_0   E255_0)
    189 
    +    test "e255_last"  (BoxE255 E255_254 E255_254)
    190 
    +    test "e255_mixed" (BoxE255 E255_0   E255_254)
    191 
    +
    192 
    +    -- 256-constructor enum (just over Word8# boundary): first, last, and mixed
    193 
    +    test "e256_first" (BoxE256 E256_0   E256_0)
    194 
    +    test "e256_last"  (BoxE256 E256_255 E256_255)
    195 
    +    test "e256_mixed" (BoxE256 E256_0   E256_255)
    196 
    +
    197 
    +    -- Boundary size comparison: E255 uses Word8# (1 byte per field),
    198 
    +    -- E256 uses Word16# (2 bytes per field). With 5 fields, the Word16#
    199 
    +    -- version needs more payload words than the Word8# version.
    200 
    +    b255 <- evaluate (Box5xE255 E255_0 E255_127 E255_254 E255_0 E255_127)
    201 
    +    b256 <- evaluate (Box5xE256 E256_0 E256_128 E256_255 E256_0 E256_128)
    202 
    +    let s255 = closureSize (asBox b255)
    203 
    +    let s256 = closureSize (asBox b256)
    204 
    +    putStrLn "### boundary_size_check"
    205 
    +    putStrLn $ "e256 (5 x Word16#) larger than e255 (5 x Word8#): " ++ show (s256 > s255)
    206 
    +    putStrLn ""

  • testsuite/tests/simplStg/should_run/unpack_enum.stdout
    1 
    +### toggle_off_off
    2 
    +BoxToggle Off Off
    3 
    +size: 2
    4 
    +
    5 
    +### toggle_on_on
    6 
    +BoxToggle On On
    7 
    +size: 2
    8 
    +
    9 
    +### toggle_off_on
    10 
    +BoxToggle Off On
    11 
    +size: 2
    12 
    +
    13 
    +### color_first
    14 
    +BoxColor Red Red
    15 
    +size: 2
    16 
    +
    17 
    +### color_last
    18 
    +BoxColor Purple Purple
    19 
    +size: 2
    20 
    +
    21 
    +### color_mixed
    22 
    +BoxColor Green Yellow
    23 
    +size: 2
    24 
    +
    25 
    +### proxy
    26 
    +BoxProxy PB PC
    27 
    +size: 2
    28 
    +
    29 
    +### e255_first
    30 
    +BoxE255 E255_0 E255_0
    31 
    +size: 2
    32 
    +
    33 
    +### e255_last
    34 
    +BoxE255 E255_254 E255_254
    35 
    +size: 2
    36 
    +
    37 
    +### e255_mixed
    38 
    +BoxE255 E255_0 E255_254
    39 
    +size: 2
    40 
    +
    41 
    +### e256_first
    42 
    +BoxE256 E256_0 E256_0
    43 
    +size: 2
    44 
    +
    45 
    +### e256_last
    46 
    +BoxE256 E256_255 E256_255
    47 
    +size: 2
    48 
    +
    49 
    +### e256_mixed
    50 
    +BoxE256 E256_0 E256_255
    51 
    +size: 2
    52 
    +
    53 
    +### boundary_size_check
    54 
    +e256 (5 x Word16#) larger than e255 (5 x Word8#): True
    55 
    +

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help