Sebastian Graf pushed to branch wip/sg/first-class-strict at Glasgow Haskell Compiler / GHC

Commits:

15 changed files:

Changes:

  • compiler/GHC/Builtin/PrimOps/Casts.hs
    ... ... @@ -53,6 +53,10 @@ getCasts from_rep to_rep
    53 53 
       | -- pprTrace "getCasts" (ppr (from_rep,to_rep)) $
    54 54 
         to_rep == from_rep
    55 55 
       = []
    56 
    +  | from_rep == BoxedRep (Just Lifted) && to_rep == BoxedRep (Just Unlifted)
    57 
    +  = []
    58 
    +  | to_rep == BoxedRep (Just Lifted) && from_rep == BoxedRep (Just Unlifted)
    59 
    +  = []
    56 60
    57 61 
       -- Float <-> Double
    58 62 
       | to_rep == FloatRep =

  • compiler/GHC/Stg/Lint.hs
    ... ... @@ -101,7 +101,7 @@ import GHC.Stg.Syntax
    101 101 
     import GHC.Stg.Utils
    102 102
    103 103 
     import GHC.Core.DataCon
    104 
    -import GHC.Core             ( AltCon(..) )
    104 
    +import GHC.Core             ( AltCon(..), isEvaldUnfolding )
    105 105 
     import GHC.Core.Type
    106 106 
     import GHC.Core.Lint        ( lintMessage )
    107 107
    ... ... @@ -126,6 +126,7 @@ import Control.Monad
    126 126 
     import GHC.Core.Multiplicity (scaledThing)
    127 127 
     import GHC.Settings (Platform)
    128 128 
     import GHC.Core.TyCon (primRepCompatible, primRepsCompatible)
    129 
    +import GHC.Builtin.Types (isStrictTy)
    129 130
    130 131 
     lintStgTopBindings :: forall a . (OutputablePass a, BinderP a ~ Id)
    131 132 
                        => Platform
    ... ... @@ -230,8 +231,23 @@ lint_binds_help top_lvl (binder, rhs)
    230 231 
             -- Check binder doesn't have unlifted type or it's a join point
    231 232 
             checkL ( isJoinId binder
    232 233 
                   || not (isUnliftedType (idType binder))
    234 
    +              || isNiceStrict -- Allow Strict bindings for now. They should be in HNF.
    233 235 
                   || isDataConWorkId binder || isDataConWrapId binder) -- until #17521 is fixed
    234 236 
               (mkUnliftedTyMsg opts binder rhs)
    237 
    +        -- See Note [The Strict type] in GHC.Builtin.Types: a binder known to be
    238 
    +        -- evaluated (an evald unfolding) must not be lowered to an updatable
    239 
    +        -- indirection, which would turn an EPT value into a non-EPT thunk. An
    240 
    +        -- evaluated indirection should have been shortened away instead.
    241 
    +        when (not (isTopLevel top_lvl)) $
    242 
    +          checkL (not (isEvaldUnfolding (idUnfolding binder)) || not (isUpdatableIndirection rhs))
    243 
    +            (mkEvaldUpdatableMsg opts binder rhs)
    244 
    +  where
    245 
    +    isNiceStrict = isStrictTy (idType binder) && not (isRhsUpdatable rhs)
    246 
    +    isRhsUpdatable (StgRhsClosure _ _ flag _ _ _) = isUpdatable flag
    247 
    +    isRhsUpdatable (StgRhsCon {})                 = False
    248 
    +    -- An updatable thunk whose body is just a reference to another variable.
    249 
    +    isUpdatableIndirection (StgRhsClosure _ _ flag [] (StgApp _ []) _) = isUpdatable flag
    250 
    +    isUpdatableIndirection _                                           = False
    235 251
    236 252 
     -- | Top-level bindings can't inherit the cost centre stack from their
    237 253 
     -- (static) allocation site.
    ... ... @@ -566,3 +582,10 @@ mkUnliftedTyMsg opts binder rhs
    566 582 
          text "has unlifted type" <+> quotes (ppr (idType binder)))
    567 583 
         $$
    568 584 
         (text "RHS:" <+> pprStgRhs opts rhs)
    585 
    +
    586 
    +mkEvaldUpdatableMsg :: OutputablePass a => StgPprOpts -> Id -> GenStgRhs a -> SDoc
    587 
    +mkEvaldUpdatableMsg opts binder rhs
    588 
    +  = (text "Let binder" <+> quotes (ppr binder) <+>
    589 
    +     text "has an evaluated unfolding but an updatable indirection RHS")
    590 
    +    $$
    591 
    +    (text "RHS:" <+> pprStgRhs opts rhs)

  • compiler/GHC/Stg/Unarise.hs
    ... ... @@ -416,7 +416,6 @@ import GHC.Builtin.PrimOps.Casts
    416 416 
     import GHC.Platform
    417 417 
     import Data.List (mapAccumL)
    418 418
    419 
    --- import GHC.Utils.Trace
    420 419 
     --------------------------------------------------------------------------------
    421 420
    422 421 
     -- | A mapping from binders to the Ids they were expanded/renamed to.
    ... ... @@ -843,7 +842,7 @@ mapSumIdBinders alt_bndr args rhs rho0
    843 842 
           arg_slots = map primRepSlot $ concatMap stgArgRep args
    844 843 
           -- The slots representing the field of the sum we bind.
    845 844 
           id_slots  = map primRepSlot $ fld_reps
    846 
    -      layout1   = layoutUbxSum arg_slots id_slots
    845 
    +      layout1   = layoutUbxSum arg_slots (map (\s -> (s, True)) id_slots)
    847 846
    848 847 
           -- See Note [Casting slot arguments]
    849 848 
           -- Most of the code here is just to make sure our binders are of the
    ... ... @@ -927,7 +926,7 @@ mkUbxSum platform dc ty_args args0 us
    927 926 
       = let
    928 927 
           tag_slot :| sum_slots = ubxSumRepType ty_args
    929 928 
           -- drop tag slot
    930 
    -      field_slots = (mapMaybe (repSlotTy . stgArgRep) args0)
    929 
    +      field_slots = mapMaybe argToSlotTy args0
    931 930 
           tag = dataConTag dc
    932 931 
           layout'  = layoutUbxSum sum_slots field_slots
    933 932
    ... ... @@ -970,6 +969,10 @@ mkUbxSum platform dc ty_args args0 us
    970 969 
             , Just lit' <- castLiteralArg platform (slotPrimRep slot_ty) lit
    971 970 
             = Just (StgLitArg lit', us, id)
    972 971 
           castArg us slot_ty arg
    972 
    +        -- A lifted pointer stored in an unlifted slot needs no conversion; both
    973 
    +        -- are heap pointers.
    974 
    +        | slot_ty == PtrUnliftedSlot && stgArgRepU arg == BoxedRep (Just Lifted)
    975 
    +        = Nothing
    973 976 
             -- Cast the argument to the type of the slot if required
    974 977 
             | slotPrimRep slot_ty /= stgArgRepU arg
    975 978 
             , (ops,types) <- unzip $ getCasts (stgArgRepU arg) $ slotPrimRep slot_ty
    ... ... @@ -985,12 +988,17 @@ mkUbxSum platform dc ty_args args0 us
    985 988
    986 989 
           tup_args = tag_arg : slot_args
    987 990 
         in
    988 
    -      -- pprTrace "mkUbxSum" (
    989 
    -      --   text "ty_args (slots)" <+> ppr ty_args $$
    990 
    -      --   text "args0" <+> ppr args0 $$
    991 
    -      --   text "wrapper" <+>
    992 
    -      --       (ppr $ wrapper $ StgLit $ LitChar '_'))
    993 991 
           (tup_args, wrapper)
    992 
    +  where
    993 
    +    -- The Bool says whether a lifted pointer may occupy an unlifted slot; we
    994 
    +    -- conservatively allow it for any pointer.  Pointer slots are handled
    995 
    +    -- loosely: this is sound only because 'fitsIn' keeps the lifted and unlifted
    996 
    +    -- pointer slots separate, so an unlifted argument falls back to a lifted slot
    997 
    +    -- (see 'layoutUbxSum') rather than the two being merged.
    998 
    +    argToSlotTy :: StgArg -> Maybe (SlotTy, Bool)
    999 
    +    argToSlotTy arg = do
    1000 
    +      ty <- repSlotTy (stgArgRep arg)
    1001 
    +      return (ty, True)
    994 1002
    995 1003
    996 1004 
     -- | Return a rubbish value for the given slot type.

  • compiler/GHC/StgToCmm/Closure.hs
    ... ... @@ -95,6 +95,7 @@ import Data.Coerce (coerce)
    95 95 
     import qualified Data.ByteString.Char8 as BS8
    96 96 
     import GHC.StgToCmm.Config
    97 97 
     import GHC.Stg.EnforceEpt.TagSig (isTaggedSig)
    98 
    +import GHC.Builtin.Types (isStrictTy)
    98 99
    99 100 
     -----------------------------------------------------------------------------
    100 101 
     --                Data types and synonyms
    ... ... @@ -199,9 +200,9 @@ addArgReps = map (\arg -> let arg' = fromNonVoid arg
    199 200
    200 201 
     mkLFArgument :: Id -> LambdaFormInfo
    201 202 
     mkLFArgument id
    202 
    -  | isUnliftedType ty      = LFUnlifted
    203 
    -  | mightBeFunTy ty = LFUnknown True
    204 
    -  | otherwise              = LFUnknown False
    203 
    +  | isUnliftedType ty = LFUnlifted
    204 
    +  | mightBeFunTy ty   = LFUnknown True
    205 
    +  | otherwise         = LFUnknown False
    205 206 
       where
    206 207 
         ty = idType id
    207 208
    ... ... @@ -224,7 +225,10 @@ mkLFReEntrant top fvs args arg_descr
    224 225 
     -------------
    225 226 
     mkLFThunk :: Type -> TopLevelFlag -> [Id] -> UpdateFlag -> LambdaFormInfo
    226 227 
     mkLFThunk thunk_ty top fvs upd_flag
    227 
    -  = assert (not (isUpdatable upd_flag) || not (isUnliftedType thunk_ty)) $
    228 
    +  | isUpdatable upd_flag && isUnliftedType thunk_ty && not (isStrictTy thunk_ty)
    229 
    +  = pprPanic "mkLFThunk" (ppr thunk_ty <+> ppr top <+> ppr fvs <+> ppr upd_flag)
    230 
    +mkLFThunk thunk_ty top fvs upd_flag
    231 
    +  = assert (not (isUpdatable upd_flag) || not (isUnliftedType thunk_ty) || (isStrictTy thunk_ty)) $
    228 232 
         LFThunk top (null fvs)
    229 233 
                 (isUpdatable upd_flag)
    230 234 
                 NonStandardThunk
    ... ... @@ -542,8 +546,12 @@ getCallMethod cfg name id (LFReEntrant _ arity _ _) n_args _cg_loc _self_loop_in
    542 546 
       | n_args < arity = SlowCall        -- Not enough args
    543 547 
       | otherwise      = DirectEntry (enterIdLabel (stgToCmmPlatform cfg) name (idCafInfo id)) arity
    544 548
    545 
    -getCallMethod _ _name _ LFUnlifted n_args _cg_loc _self_loop_info
    546 
    -  = assert (n_args == 0) ReturnIt
    549 
    +getCallMethod cfg name id LFUnlifted n_args cg_loc self_loop_info
    550 
    +  -- A value of unlifted type is already evaluated, so we can just return it,
    551 
    +  -- unless it is also a function (e.g. @Strict (a -> b)@) that is being
    552 
    +  -- applied, in which case we must call it.
    553 
    +  | n_args > 0 = getCallMethod cfg name id (LFUnknown True) n_args cg_loc self_loop_info
    554 
    +  | otherwise  = ReturnIt
    547 555
    548 556 
     getCallMethod _ _name _ (LFCon _) n_args _cg_loc _self_loop_info
    549 557 
       = assert (n_args == 0) ReturnIt
    ... ... @@ -552,7 +560,6 @@ getCallMethod _ _name _ (LFCon _) n_args _cg_loc _self_loop_info
    552 560
    553 561 
     getCallMethod cfg name id (LFThunk _ _ updatable std_form_info is_fun)
    554 562 
                   n_args _cg_loc _self_loop_info
    555 
    -
    556 563 
       | Just sig <- idTagSig_maybe id
    557 564 
       , isTaggedSig sig -- Infered to be already evaluated by EPT analysis
    558 565 
       , n_args == 0     -- See Note [EPT enforcement]

  • compiler/GHC/StgToCmm/Expr.hs
    ... ... @@ -41,9 +41,10 @@ import GHC.Core
    41 41 
     import GHC.Core.DataCon
    42 42 
     import GHC.Types.ForeignCall
    43 43 
     import GHC.Types.Id
    44 
    +import GHC.Types.Unique ( hasKey )
    44 45 
     import GHC.Builtin.PrimOps
    45 46 
     import GHC.Core.TyCon
    46 
    -import GHC.Core.Type        ( isUnliftedType )
    47 
    +import GHC.Core.Type        ( isUnliftedType, splitTyConApp_maybe )
    47 48 
     import GHC.Types.RepType    ( isZeroBitTy, countConRepArgs, mightBeFunTy )
    48 49 
     import GHC.Types.CostCentre ( CostCentreStack, currentCCS )
    49 50 
     import GHC.Types.Tickish
    ... ... @@ -58,6 +59,8 @@ import Control.Arrow ( first )
    58 59 
     import Data.List     ( partition )
    59 60 
     import GHC.Stg.EnforceEpt.TagSig (isTaggedSig)
    60 61 
     import GHC.Platform.Profile (profileIsProfiling)
    62 
    +import GHC.Builtin.Names (strictTyConKey, strictDataConKey)
    63 
    +import GHC.Plugins (varUnique)
    61 64
    62 65 
     ------------------------------------------------------------------------
    63 66 
     --              cgExpr: the main function
    ... ... @@ -1037,6 +1040,10 @@ cgConApp con mn stg_args
    1037 1040 
             ; emitReturn [idInfoToAmode idinfo] }
    1038 1041
    1039 1042 
     cgIdApp :: Id -> [StgArg] -> FCode ReturnKind
    1043 
    +cgIdApp fun_id _
    1044 
    +  -- MkStrict is erased in CorePrep, so it must never reach the code generator.
    1045 
    +  | varUnique fun_id == strictDataConKey
    1046 
    +  = pprPanic "cgIdApp: MkStrict survived to StgToCmm" (ppr fun_id)
    1040 1047 
     cgIdApp fun_id args = do
    1041 1048 
         platform       <- getPlatform
    1042 1049 
         fun_info       <- getCgIdInfo fun_id
    ... ... @@ -1051,15 +1058,32 @@ cgIdApp fun_id args = do
    1051 1058 
         case getCallMethod cfg fun_name fun_id lf_info n_args (cg_loc fun_info) self_loop of
    1052 1059 
                 -- A value in WHNF, so we can just return it.
    1053 1060 
             ReturnIt
    1054 
    -          | isZeroBitTy (idType fun_id) -> emitReturn []
    1055 
    -          | otherwise                -> emitReturn [fun]
    1061 
    +          | isZeroBitTy (idType fun_id) -> do
    1062 
    +            emitReturn []
    1063 
    +          | otherwise                -> do
    1064 
    +            if strict then
    1065 
    +              assertTag >> emitReturn [fun]
    1066 
    +            else
    1067 
    +              emitReturn [fun]
    1068 
    +          where
    1069 
    +            tcSplitMaybe = splitTyConApp_maybe (idType fun_id)
    1070 
    +            strict = case tcSplitMaybe of
    1071 
    +              Nothing      -> False
    1072 
    +              Just (tc, _) -> tc `hasKey` strictTyConKey
    1073 
    +            assertTag = whenCheckTags $ do
    1074 
    +              mod <- getModuleName
    1075 
    +              emitTagAssertionStrict (showPprUnsafe
    1076 
    +                (text "TagCheck failed on entry in" <+> ppr mod <+> text "- value:" <> ppr fun_id <+> pdoc platform fun))
    1077 
    +                fun
    1056 1078
    1057 1079 
             -- A value infered to be in WHNF, so we can just return it.
    1058 1080 
             -- See (EPT-codegen) in Note [EPT enforcement] in GHC.Stg.EnforceEpt
    1059 1081 
             InferedReturnIt
    1060 
    -          | isZeroBitTy (idType fun_id) -> trace >> emitReturn []
    1061 
    -          | otherwise                   -> trace >> assertTag >>
    1062 
    -                                                    emitReturn [fun]
    1082 
    +          | isZeroBitTy (idType fun_id) -> do
    1083 
    +            trace >> emitReturn []
    1084 
    +          | otherwise                   ->  do
    1085 
    +            trace >> assertTag >>
    1086 
    +              emitReturn [fun]
    1063 1087 
                 where
    1064 1088 
                   trace = do
    1065 1089 
                     tickyTagged
    ... ... @@ -1074,12 +1098,11 @@ cgIdApp fun_id args = do
    1074 1098 
                           (text "TagCheck failed on entry in" <+> ppr mod <+> text "- value:" <> ppr fun_id <+> pdoc platform fun))
    1075 1099 
                           fun
    1076 1100
    1077 
    -        EnterIt -> assertPpr (null args) (ppr fun_id $$ ppr args) $  -- Discarding arguments
    1101 
    +        EnterIt -> assertPpr (null args) (ppr fun_id $$ ppr args) $ do  -- Discarding arguments
    1078 1102 
                        emitEnter fun
    1079 1103
    1080 1104 
             SlowCall -> do      -- A slow function call via the RTS apply routines
    1081 1105 
                     { tickySlowCall lf_info args
    1082 
    -                ; emitComment $ mkFastString "slowCall"
    1083 1106 
                     ; slowCall fun args }
    1084 1107
    1085 1108 
             -- A direct function call (possibly with some left-over arguments)

  • compiler/GHC/StgToCmm/TagCheck.hs
    ... ... @@ -10,7 +10,8 @@
    10 10
    11 11 
     module GHC.StgToCmm.TagCheck
    12 12 
       ( emitTagAssertion, emitArgTagCheck, checkArg, whenCheckTags,
    13 
    -    checkArgStatic, checkFunctionArgTags,checkConArgsStatic,checkConArgsDyn) where
    13 
    +    checkArgStatic, checkFunctionArgTags,checkConArgsStatic,checkConArgsDyn
    14 
    +  , emitTagAssertionStrict) where
    14 15
    15 16 
     #include "ClosureTypes.h"
    16 17
    ... ... @@ -71,6 +72,51 @@ whenCheckTags act = do
    71 72 
       check_tags <- stgToCmmDoTagCheck <$> getStgToCmmConfig
    72 73 
       when check_tags act
    73 74
    75 
    +emitTagAssertionStrict :: String -> CmmExpr -> FCode ()
    76 
    +emitTagAssertionStrict onWhat fun = do
    77 
    +  { platform <- getPlatform
    78 
    +  ; lret <- newBlockId
    79 
    +  ; lno_tag <- newBlockId
    80 
    +  ; lbarf <- newBlockId
    81 
    +  -- Check for presence of any tag.
    82 
    +  ; emit $ mkCbranch (cmmIsTagged platform fun)
    83 
    +                     lret lno_tag (Just True)
    84 
    +  -- If there is no tag check if we are dealing with an untagged object
    85 
    +  ; emitLabel lno_tag
    86 
    +  ; needsTaggedPointer fun lbarf lret
    87 
    +
    88 
    +  ; emitLabel lbarf
    89 
    +  ; emitBarf ("Tag eval failed on:" ++ onWhat)
    90 
    +  ; emitLabel lret
    91 
    +  }
    92 
    +
    93 
    +-- | Jump to the first block if the argument is subject
    94 
    +--   to tagging requirements. Otherwise jump to the 2nd one.
    95 
    +needsTaggedPointer :: CmmExpr -> BlockId -> BlockId -> FCode ()
    96 
    +needsTaggedPointer val fail lpass = do
    97 
    +  profile <- getProfile
    98 
    +  align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig
    99 
    +  let clo_ty_e = cmmGetClosureType profile align_check val
    100 
    +  -- The ENTER macro doesn't evaluate FUN/PAP/BCO objects. So we
    101 
    +  -- have to accept them not being tagged. See #21193
    102 
    +  -- See Note [TagInfo of functions]
    103 
    +  let targets = mkSwitchTargets
    104 
    +        False
    105 
    +        (INVALID_OBJECT, N_CLOSURE_TYPES)
    106 
    +        (Just lpass)
    107 
    +        (M.fromList [(THUNK, fail),
    108 
    +                    (THUNK_1_0, fail),
    109 
    +                    (THUNK_0_1, fail),
    110 
    +                    (THUNK_2_0, fail),
    111 
    +                    (THUNK_1_1, fail),
    112 
    +                    (THUNK_0_2, fail),
    113 
    +                    (THUNK_STATIC, fail),
    114 
    +                    (THUNK_SELECTOR, fail)])
    115 
    +
    116 
    +  emit $ mkSwitch clo_ty_e targets
    117 
    +
    118 
    +  emit $ mkBranch lpass
    119 
    +
    74 120 
     -- | Call barf if we failed to predict a tag correctly.
    75 121 
     -- This is immensely useful when debugging issues in tag inference
    76 122 
     -- as it will result in a program abort when we encounter an invalid
    ... ... @@ -112,15 +158,15 @@ needsArgTag closure fail lpass = do
    112 158 
             False
    113 159 
             (INVALID_OBJECT, N_CLOSURE_TYPES)
    114 160 
             (Just fail)
    115 
    -        (M.fromList [(PAP,lpass)
    116 
    -                    ,(BCO,lpass)
    117 
    -                    ,(FUN,lpass)
    118 
    -                    ,(FUN_1_0,lpass)
    119 
    -                    ,(FUN_0_1,lpass)
    120 
    -                    ,(FUN_2_0,lpass)
    121 
    -                    ,(FUN_1_1,lpass)
    122 
    -                    ,(FUN_0_2,lpass)
    123 
    -                    ,(FUN_STATIC,lpass)
    161 
    +        (M.fromList [(PAP,lpass)        -- 25
    162 
    +                    ,(BCO,lpass)        -- 23
    163 
    +                    ,(FUN,lpass)        -- 8
    164 
    +                    ,(FUN_1_0,lpass)    -- 9
    165 
    +                    ,(FUN_0_1,lpass)    -- 10
    166 
    +                    ,(FUN_2_0,lpass)    -- 11
    167 
    +                    ,(FUN_1_1,lpass)    -- 12
    168 
    +                    ,(FUN_0_2,lpass)    -- 13
    169 
    +                    ,(FUN_STATIC,lpass) -- 14
    124 170 
                         ])
    125 171
    126 172 
       emit $ mkSwitch clo_ty_e targets

  • compiler/GHC/Types/RepType.hs
    ... ... @@ -29,6 +29,7 @@ module GHC.Types.RepType
    29 29 
     import GHC.Prelude
    30 30
    31 31 
     import GHC.Types.Basic (Arity, RepArity)
    32 
    +import GHC.Builtin.Names (strictTyConKey)
    32 33 
     import GHC.Core.DataCon
    33 34 
     import GHC.Core.Coercion
    34 35 
     import GHC.Core.TyCon
    ... ... @@ -100,6 +101,10 @@ unwrapType ty
    100 101 
         go t | Just t' <- coreView t = go t'
    101 102 
         go (ForAllTy _ t)            = go t
    102 103 
         go (CastTy t _)              = go t
    104 
    +    -- Look through Strict types
    105 
    +    go (TyConApp tc [t])
    106 
    +      | tyConUnique tc == strictTyConKey
    107 
    +      = go t
    103 108 
         go t                         = t
    104 109
    105 110 
         -- cf. GHC.Core.Coercion.unwrapNewTypeStepper
    ... ... @@ -248,29 +253,46 @@ ubxSumRepType constrs0
    248 253 
     layoutUbxSum :: HasDebugCallStack
    249 254 
                  => SortedSlotTys -- Layout of sum. Does not include tag.
    250 255 
                                   -- We assume that they are in increasing order
    251 
    -             -> [SlotTy]      -- Slot types of things we want to map to locations in the
    252 
    -                              -- sum layout
    256 
    +             -> [(SlotTy, Bool)] -- Slot types of things we want to map to locations in
    257 
    +                                 -- the sum layout.  The Bool says whether a lifted
    258 
    +                                 -- pointer may occupy an unlifted slot, i.e. it is
    259 
    +                                 -- already evaluated.
    253 260 
                  -> [Int]         -- Where to map 'things' in the sum layout
    254 261 
     layoutUbxSum sum_slots0 arg_slots0 =
    255 262 
         go arg_slots0 IS.empty
    256 263 
       where
    257 
    -    go :: [SlotTy] -> IS.IntSet -> [Int]
    264 
    +    go :: [(SlotTy, Bool)] -> IS.IntSet -> [Int]
    258 265 
         go [] _
    259 266 
           = []
    260 267 
         go (arg : args) used
    261 
    -      = let slot_idx = findSlot arg 0 sum_slots0 used
    262 
    -         in slot_idx : go args (IS.insert slot_idx used)
    263 
    -
    264 
    -    findSlot :: SlotTy -> Int -> SortedSlotTys -> IS.IntSet -> Int
    268 
    +      = let slot_idx
    269 
    +              | Just slot_idx <- findSlot (fst arg) 0 sum_slots0 used
    270 
    +              = Just slot_idx
    271 
    +              -- All pointer slots hold a heap pointer, so an unlifted pointer can
    272 
    +              -- occupy a lifted slot.  This bridges the gap left by 'unwrapType'
    273 
    +              -- looking through Strict: the sum layout may have a lifted slot
    274 
    +              -- where the argument is an (unlifted) Strict box.
    275 
    +              | PtrUnliftedSlot <- fst arg
    276 
    +              = findSlot PtrLiftedSlot 0 sum_slots0 used
    277 
    +              -- An already-evaluated lifted pointer can occupy an unlifted slot.
    278 
    +              | PtrLiftedSlot <- fst arg, snd arg
    279 
    +              = findSlot PtrUnliftedSlot 0 sum_slots0 used
    280 
    +              | otherwise
    281 
    +              = Nothing
    282 
    +         in case slot_idx of
    283 
    +              Just slot_idx -> slot_idx : go args (IS.insert slot_idx used)
    284 
    +              Nothing -> pprPanic "layoutUbxSum" (  text "Can't find slot for arg" <+> ppr arg
    285 
    +                                                 $$ text "sum_slots:" <> ppr sum_slots0
    286 
    +                                                 $$ text "arg_slots:" <> ppr arg_slots0)
    287 
    +
    288 
    +    findSlot :: SlotTy -> Int -> SortedSlotTys -> IS.IntSet -> Maybe Int
    265 289 
         findSlot arg slot_idx (slot : slots) useds
    266 290 
           | not (IS.member slot_idx useds)
    267 291 
           , Just slot == arg `fitsIn` slot
    268 
    -      = slot_idx
    292 
    +      = Just slot_idx
    269 293 
           | otherwise
    270 294 
           = findSlot arg (slot_idx + 1) slots useds
    271 
    -    findSlot _ _ [] _
    272 
    -      = pprPanic "findSlot" (text "Can't find slot" $$ text "sum_slots:" <> ppr sum_slots0
    273 
    -                                                    $$ text "arg_slots:" <> ppr arg_slots0 )
    295 
    +    findSlot _ _ [] _ = Nothing
    274 296
    275 297 
     --------------------------------------------------------------------------------
    276 298
    ... ... @@ -730,10 +752,6 @@ mightBeFunTy :: Type -> Bool
    730 752 
     -- In particular, 'isFunTy' returns @False@ for @IO ()@ as well as for all
    731 753 
     -- type family applications.
    732 754 
     mightBeFunTy ty
    733 
    -  -- GHC (currently) has no unlifted functions, so an unlifted type is
    734 
    -  -- definitely not a function type.
    735 
    -  | definitelyUnliftedType ty
    736 
    -  = False
    737 755 
       | Just tc <- tyConAppTyCon_maybe (unwrap_type ty)
    738 756 
       -- A proper datatype (such as 'Int' or 'Maybe Bool') is definitely not
    739 757 
       -- a function type. (This does not include newtypes nor type families.)

  • testsuite/tests/codeGen/should_run/StrictBox.hs
    1 
    +{-# LANGUAGE BangPatterns #-}
    2 
    +
    3 
    +-- | Exercises the strict-field/Strict# machinery end to end:
    4 
    +--
    5 
    +--   * a strict value field built from a thunk, which must be forced to a
    6 
    +--     properly-tagged value (EPT) when the constructor is built;
    7 
    +--   * a strict field of /function/ type, whose box is unlifted but is applied
    8 
    +--     as a function (the "might be a function" call path);
    9 
    +--   * worker/wrapper unboxing a strict argument through Strict#;
    10 
    +--   * a strict field holding another boxed value, passed around by value.
    11 
    +--
    12 
    +-- Run with -dtag-inference-checks so that any strict field that is not
    13 
    +-- evaluated-and-properly-tagged aborts at runtime.
    14 
    +module Main (main) where
    15 
    +
    16 
    +-- Strict value field + strict function field
    17 
    +data Box a = Box !a !(Int -> Int)
    18 
    +
    19 
    +{-# NOINLINE mkBox #-}
    20 
    +mkBox :: Int -> Box Int
    21 
    +mkBox n = Box (sum [1..n]) (\x -> x + n)   -- field 1 from a thunk; field 2 a closure
    22 
    +
    23 
    +{-# NOINLINE useBox #-}
    24 
    +useBox :: Box Int -> Int
    25 
    +useBox (Box a f) = a + f 100               -- applies the strict function field
    26 
    +
    27 
    +-- A strict field holding another boxed value
    28 
    +data Wrap = Wrap !(Box Int)
    29 
    +
    30 
    +{-# NOINLINE useWrap #-}
    31 
    +useWrap :: Wrap -> Int
    32 
    +useWrap (Wrap b) = useBox b
    33 
    +
    34 
    +-- Worker/wrapper unboxes the strict argument through Strict#
    35 
    +{-# NOINLINE strictArg #-}
    36 
    +strictArg :: Int -> Int -> Int
    37 
    +strictArg !x y = x * 1000 + y
    38 
    +
    39 
    +main :: IO ()
    40 
    +main = do
    41 
    +  print (useBox (mkBox 5))               -- 15 + (100+5)        = 120
    42 
    +  print (strictArg (3 + 4) 9)            -- 7*1000 + 9          = 7009
    43 
    +  print (useWrap (Wrap (mkBox 3)))       -- 6 + (100+3)         = 109
    44 
    +  print (map (useBox . mkBox) [1, 2, 3]) -- [102, 105, 109]

  • testsuite/tests/codeGen/should_run/StrictBox.stdout
    1 
    +120
    2 
    +7009
    3 
    +109
    4 
    +[102,105,109]

  • testsuite/tests/codeGen/should_run/all.T
    ... ... @@ -289,3 +289,7 @@ test('T27072w', [req_c, js_skip, when(opsys('darwin'), skip)],
    289 289 
     # AArch64-specific runtime tests
    290 290 
     test('aarch64-ushr-subword-run', [unless(arch('aarch64'), skip)], compile_and_run, ['-O'])
    291 291 
     test('aarch64-subword-ops', [unless(arch('aarch64'), skip)], compile_and_run, ['-O'])
    292 
    +
    293 
    +# Strict# / strict-field machinery, with runtime tag-inference checks
    294 
    +test('StrictBox', normal, compile_and_run,
    295 
    +     ['-O -dtag-inference-checks -fmax-simplifier-iterations=20'])

  • testsuite/tests/core-to-stg/T24124.stderr
    1 1
    2 2 
     ==================== Final STG: ====================
    3 
    -T24124.MkStrictPair [InlPrag=CONLIKE]
    3 
    +T24124.$WMkStrictPair [InlPrag=INLINE[final] CONLIKE]
    4 4 
       :: forall a b. a %1 -> b %1 -> T24124.StrictPair a b
    5 
    -[GblId[DataCon],
    5 
    +[GblId[DataConWrapper],
    6 6 
      Arity=2,
    7 7 
      Caf=NoCafRefs,
    8 8 
      Str=<SL><SL>,
    9 9 
      Unf=OtherCon []] =
    10 
    -    {} \r [eta eta]
    11 
    -        case eta of eta {
    10 
    +    {} \r [conrep conrep]
    11 
    +        case conrep of $WMkStrictPair_sat {
    12 
    +        __DEFAULT ->
    13 
    +        case $WMkStrictPair_sat<TagProper> of conrep_ubx {
    14 
    +        __DEFAULT ->
    15 
    +        case conrep of $WMkStrictPair_sat {
    12 16 
             __DEFAULT ->
    13 
    -        case eta of eta { __DEFAULT -> T24124.MkStrictPair [eta eta]; };
    17 
    +        case $WMkStrictPair_sat<TagProper> of conrep_ubx {
    18 
    +        __DEFAULT -> T24124.MkStrictPair [conrep_ubx conrep_ubx];
    14 19 
             };
    20 
    +        };
    21 
    +        };
    22 
    +        };
    23 
    +
    24 
    +T24124.MkStrictPair [InlPrag=CONLIKE]
    25 
    +  :: forall {a} {b}.
    26 
    +     GHC.Internal.Types.Strict# a
    27 
    +     %1 -> GHC.Internal.Types.Strict# b %1 -> T24124.StrictPair a b
    28 
    +[GblId[DataCon],
    29 
    + Arity=2,
    30 
    + Caf=NoCafRefs,
    31 
    + Str=<SL><SL>,
    32 
    + Unf=OtherCon []] =
    33 
    +    {} \r [eta eta] T24124.MkStrictPair [eta eta];
    15 34
    16 35 
     T24124.testFun1
    17 36 
       :: forall a b.
    ... ... @@ -20,13 +39,18 @@ T24124.testFun1
    20 39 
          -> GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld
    21 40 
          -> (# GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld,
    22 41 
                T24124.StrictPair a b #)
    23 
    -[GblId, Arity=3, Str=<L><L><L>, Cpr=1, Unf=OtherCon []] =
    42 
    +[GblId, Arity=3, Str=<L><ML><L>, Cpr=1, Unf=OtherCon []] =
    24 43 
         {} \r [x y void]
    25 44 
             case x of testFun1_sat {
    26 45 
             __DEFAULT ->
    46 
    +        case y of wild {
    47 
    +        __DEFAULT ->
    27 48 
             case
    28 
    -            case y of y [OS=OneShot] {
    29 
    -            __DEFAULT -> T24124.MkStrictPair [testFun1_sat y];
    49 
    +            case wild<TagProper> of testFun1_sat {
    50 
    +            __DEFAULT ->
    51 
    +            case testFun1_sat<TagProper> of testFun1_sat {
    52 
    +            __DEFAULT -> T24124.MkStrictPair [testFun1_sat testFun1_sat];
    53 
    +            };
    30 54 
                 }
    31 55 
             of
    32 56 
             testFun1_sat
    ... ... @@ -34,11 +58,12 @@ T24124.testFun1
    34 58 
             __DEFAULT -> GHC.Internal.Types.MkSolo# [testFun1_sat];
    35 59 
             };
    36 60 
             };
    61 
    +        };
    37 62
    38 63 
     T24124.testFun
    39 64 
       :: forall a b.
    40 65 
          a -> b -> GHC.Internal.Types.IO (T24124.StrictPair a b)
    41 
    -[GblId, Arity=3, Str=<L><L><L>, Cpr=1, Unf=OtherCon []] =
    66 
    +[GblId, Arity=3, Str=<L><ML><L>, Cpr=1, Unf=OtherCon []] =
    42 67 
         {} \r [eta eta void]
    43 68 
             T24124.testFun1 eta eta GHC.Internal.Prim.void#;
    44 69

  • testsuite/tests/ghci.debugger/scripts/T13825-debugger.stdout
    1 1 
     Packed1 12.34# 56.78# 42# 99.99#
    2 2 
     packed1 = Packed1 12.34 56.78 42 99.99
    3 3 
     Packed2 12.34 56.78 42 99.99
    4 
    -packed2 = Packed2 12.34 56.78 42 99.99
    4 
    +packed2 = Packed2 (F# 12.34) (F# 56.78) (I# 42) (F# 99.99)
    5 5 
     Packed3 1 2 3 4 5 6 7.8 9.0
    6 6 
     packed3 = Packed3
    7 7 
                 (GHC.Internal.Word.W8# 1) (GHC.Internal.Int.I8# 2)
    8 8 
                 (GHC.Internal.Int.I64# 3) (GHC.Internal.Word.W16# 4)
    9 
    -            (GHC.Internal.Word.W64# 5) (GHC.Internal.Word.W32# 6) 7.8 9.0
    9 
    +            (GHC.Internal.Word.W64# 5) (GHC.Internal.Word.W32# 6) (F# 7.8)
    10 
    +            (D# 9.0)

  • testsuite/tests/ghci.debugger/scripts/print007.stdout
    1 1 
     ()
    2 
    -s = S2 'a' 'b'
    2 
    +s = S2 'a' (GHC.Internal.Types.C# 'b')
    3 3 
     ()
    4 
    -s = S2 'a' 'b'
    4 
    +s = S2 'a' (GHC.Internal.Types.C# 'b')
    5 5 
     ()
    6 6 
     s = S2 'a' 'b'

  • testsuite/tests/ghci.debugger/scripts/print022.stdout
    ... ... @@ -4,5 +4,5 @@ Breakpoint 0 activated at print022.hs:11:7
    4 4 
     Stopped in Main.f, print022.hs:11:7
    5 5 
     _result :: p = _
    6 6 
     x :: p = _
    7 
    -x = C2 1 (W# 32) (TwoFields 'a' 3)
    7 
    +x = C2 (I# 1) (W# 32) (TwoFields 'a' 3)
    8 8 
     x :: T2

  • testsuite/tests/simplStg/should_compile/T15226b.stderr
    1 1
    2 2 
     ==================== Final STG: ====================
    3 
    -T15226b.Str [InlPrag=CONLIKE] :: forall a. a %1 -> T15226b.Str a
    3 
    +T15226b.$WStr [InlPrag=INLINE[final] CONLIKE]
    4 
    +  :: forall a. a %1 -> T15226b.Str a
    5 
    +[GblId[DataConWrapper],
    6 
    + Arity=1,
    7 
    + Caf=NoCafRefs,
    8 
    + Str=<SL>,
    9 
    + Unf=OtherCon []] =
    10 
    +    {} \r [conrep]
    11 
    +        case conrep of $WStr_sat {
    12 
    +        __DEFAULT ->
    13 
    +        case $WStr_sat<TagProper> of conrep_ubx {
    14 
    +        __DEFAULT -> T15226b.Str [conrep_ubx];
    15 
    +        };
    16 
    +        };
    17 
    +
    18 
    +T15226b.Str [InlPrag=CONLIKE]
    19 
    +  :: forall {a}. GHC.Internal.Types.Strict# a %1 -> T15226b.Str a
    4 20 
     [GblId[DataCon],
    5 21 
      Arity=1,
    6 22 
      Caf=NoCafRefs,
    7 23 
      Str=<SL>,
    8 24 
      Unf=OtherCon []] =
    9 
    -    {} \r [eta] case eta of eta { __DEFAULT -> T15226b.Str [eta]; };
    25 
    +    {} \r [eta] T15226b.Str [eta];
    10 26
    11 27 
     T15226b.bar1
    12 28 
       :: forall a.
    ... ... @@ -20,8 +36,11 @@ T15226b.bar1
    20 36 
             __DEFAULT ->
    21 37 
             let {
    22 38 
               bar1_sat [Occ=Once1] :: T15226b.Str (GHC.Internal.Maybe.Maybe a)
    23 
    -          [LclId, Unf=OtherCon []] =
    24 
    -              T15226b.Str! [bar1_sat];
    39 
    +          [LclId] =
    40 
    +              {bar1_sat} \u []
    41 
    +                  case bar1_sat<TagProper> of bar1_sat {
    42 
    +                  __DEFAULT -> T15226b.Str [bar1_sat];
    43 
    +                  };
    25 44 
             } in  GHC.Internal.Types.MkSolo# [bar1_sat];
    26 45 
             };
    27 46

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