Simon Peyton Jones pushed to branch wip/T26831 at Glasgow Haskell Compiler / GHC

Commits:

12 changed files:

Changes:

  • compiler/GHC/Builtin/PrimOps.hs
    ... ... @@ -807,16 +807,23 @@ the former has an additional type binder. Hmmm....
    807 807
    808 808 
     Note [Eta expanding primops]
    809 809 
     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    810 
    -
    811 810 
     STG requires that primop applications be saturated. This makes code generation
    812 811 
     significantly simpler since otherwise we would need to define a calling
    813 812 
     convention for curried applications that can accommodate representation
    814 813 
     polymorphism.
    815 814
    816 
    -To ensure saturation, CorePrep eta expands all primop applications as
    817 
    -described in Note [Eta expansion of hasNoBinding things in CorePrep] in
    815 
    +To ensure saturation, CorePrep eta expands all primop applications
    816 
    +as described in Note [Eta expansion of unsaturated calls] in
    818 817 
     GHC.Core.Prep.
    819 818
    819 
    +Side note: this decision is somewhat in flux: see comments with `hasNoBinding`.
    820 
    +The question is: do we generate a trivial wrapper for each primop
    821 
    +   (+#) x y = (+#) x y
    822 
    +and now we can call that wrapper unsaturated.  But in practice we
    823 
    +might never call it because in practice Prep eta-expands all partial
    824 
    +applications!
    825 
    +
    826 
    +
    820 827 
     Historical Note:
    821 828
    822 829 
     For a short period around GHC 8.8 we rewrote unsaturated primop applications to

  • compiler/GHC/Core/Tidy.hs
    ... ... @@ -165,6 +165,7 @@ computeCbvInfo fun_id rhs
    165 165 
                     map mkMark val_args
    166 166
    167 167 
         cbv_bndr | any isMarkedCbv cbv_marks
    168 
    +               -- isMarkedCbv: see (CBV2) in Note [CBV Function Ids: overview]
    168 169 
                  = cbv_marks `seqList` setIdCbvMarks fun_id cbv_marks
    169 170 
                    -- seqList: avoid retaining the original rhs
    170 171
    ... ... @@ -176,6 +177,7 @@ computeCbvInfo fun_id rhs
    176 177 
         -- We don't set CBV marks on functions which take unboxed tuples or sums as
    177 178 
         -- arguments.  Doing so would require us to compute the result of unarise
    178 179 
         -- here in order to properly determine argument positions at runtime.
    180 
    +    -- See (CBV1) in Note [CBV Function Ids: overview]
    179 181 
         --
    180 182 
         -- In practice this doesn't matter much. Most "interesting" functions will
    181 183 
         -- get a W/W split which will eliminate unboxed tuple arguments, and unboxed

  • compiler/GHC/CoreToStg/Prep.hs
    ... ... @@ -1566,12 +1566,12 @@ maybeSaturate :: Id -> CpeApp
    1566 1566 
     maybeSaturate fn expr n_args unsat_ticks
    1567 1567 
       | isJoinId fn  -- Never eta-expand a call to a join point
    1568 1568 
                      -- See Note [Do not eta-expand join points]
    1569 
    -  = assertPpr (n_args >= mark_arity) (ppr expr) $
    1569 
    +  = assertPpr (not must_eta_expand) (ppr expr) $
    1570 1570 
         -- assertPpr: check that all arguments that need to be passed cbv
    1571 1571 
         -- are visible, so the backend can evalaute them if required
    1572 1572 
         expr
    1573 1573
    1574 
    -  | hasNoBinding fn || (n_args > 0 && excess_arity > 0)
    1574 
    +  | must_eta_expand || desirable_to_eta_expand
    1575 1575 
         -- n_args > 0: do not eta-expand a naked variable!
    1576 1576 
       = wrapLamBody (mkTicks unsat_ticks) $
    1577 1577 
         cpeEtaExpand excess_arity expr
    ... ... @@ -1580,6 +1580,15 @@ maybeSaturate fn expr n_args unsat_ticks
    1580 1580 
       = expr
    1581 1581
    1582 1582 
       where
    1583 
    +    must_eta_expand
    1584 
    +      =  (hasNoBinding fn && fn_arity > n_args)
    1585 
    +            -- hasNoBinding functions must be saturated
    1586 
    +      || (mark_arity > n_args)
    1587 
    +            -- CBV functions must be CBV-saturated
    1588 
    +
    1589 
    +    desirable_to_eta_expand = fn_arity > n_args && n_args > 0
    1590 
    +       -- n_args > 0: do not eta-expand a naked variable unless we have to
    1591 
    +
    1583 1592 
         mark_arity   = idCbvMarkArity fn
    1584 1593 
         fn_arity     = idArity fn
    1585 1594 
         excess_arity = (max fn_arity mark_arity) - n_args
    ... ... @@ -1623,8 +1632,11 @@ there are three reasons we might want to eta-expand:
    1623 1632
    1624 1633 
     * Must eta-expand: if `f` is a `hasNoBinding` function, we must saturate
    1625 1634 
       it, because the function has no (curried) binding to call. Currently
    1626 
    -  this includes: foreign calls, unboxed tuple/sum constructors, and
    1627 
    -  representation-polymorphic primitives such as 'coerce' and 'unsafeCoerce#'.
    1635 
    +  this includes:
    1636 
    +     - foreign calls,
    1637 
    +     - unboxed tuple/sum constructors
    1638 
    +     - representation-polymorphic primitives such as 'coerce' and 'unsafeCoerce#'
    1639 
    +     - primops (for now anyway; see comments in `hasNoBinding`)
    1628 1640
    1629 1641 
     * Must eta-expand: if `f` has a call-by-value calling convention, we /must/
    1630 1642 
       call it with evaluated arguments.  The back end deals with adding the

  • compiler/GHC/Stg/Lint.hs
    ... ... @@ -105,7 +105,7 @@ import GHC.Core ( AltCon(..) )
    105 105 
     import GHC.Core.Type
    106 106 
     import GHC.Core.Lint        ( lintMessage )
    107 107
    108 
    -import GHC.Types.Basic      ( TopLevelFlag(..), isTopLevel, isMarkedCbv )
    108 
    +import GHC.Types.Basic      ( TopLevelFlag(..), isTopLevel )
    109 109 
     import GHC.Types.CostCentre ( isCurrentCCS )
    110 110 
     import GHC.Types.Id
    111 111 
     import GHC.Types.Var.Set
    ... ... @@ -123,12 +123,9 @@ import GHC.Unit.Module ( Module )
    123 123 
     import GHC.Data.Bag         ( Bag, emptyBag, isEmptyBag, snocBag, bagToList )
    124 124
    125 125 
     import Control.Monad
    126 
    -import Data.Maybe
    127 
    -import GHC.Utils.Misc
    128 126 
     import GHC.Core.Multiplicity (scaledThing)
    129 127 
     import GHC.Settings (Platform)
    130 128 
     import GHC.Core.TyCon (primRepCompatible, primRepsCompatible)
    131 
    -import GHC.Utils.Panic.Plain (panic)
    132 129
    133 130 
     lintStgTopBindings :: forall a . (OutputablePass a, BinderP a ~ Id)
    134 131 
                        => Platform
    ... ... @@ -174,36 +171,37 @@ lintStgTopBindings platform logger diag_opts opts extra_vars this_mod unarised w
    174 171 
         lint_bind (StgTopStringLit v _) = return [v]
    175 172
    176 173 
     lintStgConArg :: StgArg -> LintM ()
    177 
    -lintStgConArg arg = do
    178 
    -  unarised <- lf_unarised <$> getLintFlags
    179 
    -  when unarised $ case stgArgRep_maybe arg of
    180 
    -    -- Note [Post-unarisation invariants], invariant 4
    181 
    -    Just [_] -> pure ()
    182 
    -    badRep   -> addErrL $
    183 
    -      text "Non-unary constructor arg: " <> ppr arg $$
    184 
    -      text "Its PrimReps are: " <> ppr badRep
    185 
    -
    186 
    -  case arg of
    187 
    -    StgLitArg _ -> pure ()
    188 
    -    StgVarArg v -> lintStgVar v
    174 
    +lintStgConArg arg
    175 
    +  = do { lintStgArg arg
    176 
    +
    177 
    +       ; unarised <- lf_unarised <$> getLintFlags
    178 
    +       ; when unarised $ case stgArgRep_maybe arg of
    179 
    +           -- Note [Post-unarisation invariants], invariant 4
    180 
    +           Just [_] -> pure ()
    181 
    +           badRep   -> addErrL $
    182 
    +             text "Non-unary constructor arg: " <> ppr arg $$
    183 
    +             text "Its PrimReps are: " <> ppr badRep }
    189 184
    190 185 
     lintStgFunArg :: StgArg -> LintM ()
    191 
    -lintStgFunArg arg = do
    192 
    -  unarised <- lf_unarised <$> getLintFlags
    193 
    -  when unarised $ case stgArgRep_maybe arg of
    194 
    -    -- Note [Post-unarisation invariants], invariant 3
    195 
    -    Just []  -> pure ()
    196 
    -    Just [_] -> pure ()
    197 
    -    badRep   -> addErrL $
    198 
    -      text "Function arg is not unary or void: " <> ppr arg $$
    199 
    -      text "Its PrimReps are: " <> ppr badRep
    200 
    -
    201 
    -  case arg of
    202 
    -    StgLitArg _ -> pure ()
    203 
    -    StgVarArg v -> lintStgVar v
    204 
    -
    205 
    -lintStgVar :: Id -> LintM ()
    206 
    -lintStgVar id = checkInScope id
    186 
    +lintStgFunArg arg
    187 
    +  = do { lintStgArg arg
    188 
    +
    189 
    +       ; unarised <- lf_unarised <$> getLintFlags
    190 
    +       ; when unarised $ case stgArgRep_maybe arg of
    191 
    +           -- Note [Post-unarisation invariants], invariant 3
    192 
    +           Just []  -> pure ()
    193 
    +           Just [_] -> pure ()
    194 
    +           badRep   -> addErrL $
    195 
    +             text "Function arg is not unary or void: " <> ppr arg $$
    196 
    +             text "Its PrimReps are: " <> ppr badRep }
    197 
    +
    198 
    +lintStgArg :: StgArg -> LintM ()
    199 
    +lintStgArg (StgLitArg _) = pure ()
    200 
    +lintStgArg (StgVarArg v) = do { lintStgVarOcc v
    201 
    +                              ; lintAppCbvMarks v [] }
    202 
    +
    203 
    +lintStgVarOcc :: Id -> LintM ()
    204 
    +lintStgVarOcc id = checkInScope id
    207 205
    208 206 
     lintStgBinds
    209 207 
         :: (OutputablePass a, BinderP a ~ Id)
    ... ... @@ -275,13 +273,11 @@ lintStgExpr :: (OutputablePass a, BinderP a ~ Id) => GenStgExpr a -> LintM ()
    275 273
    276 274 
     lintStgExpr (StgLit _) = return ()
    277 275
    278 
    -lintStgExpr e@(StgApp fun args) = do
    279 
    -  lintStgVar fun
    280 
    -  mapM_ lintStgFunArg args
    281 
    -  lintAppCbvMarks e
    282 
    -  lintStgAppReps fun args
    283 
    -
    284 
    -
    276 
    +lintStgExpr (StgApp fun args)
    277 
    +  = do { lintStgVarOcc fun
    278 
    +       ; mapM_ lintStgFunArg args
    279 
    +       ; lintAppCbvMarks fun args
    280 
    +       ; lintStgAppReps fun args }
    285 281
    286 282 
     lintStgExpr app@(StgConApp con _n args _arg_tys) = do
    287 283 
         -- unboxed sums should vanish during unarise
    ... ... @@ -413,22 +409,20 @@ lintStgAppReps fun args = do
    413 409
    414 410 
       match_args actual_arg_reps fun_arg_tys_reps
    415 411
    416 
    -lintAppCbvMarks :: OutputablePass pass
    417 
    -                => GenStgExpr pass -> LintM ()
    418 
    -lintAppCbvMarks e@(StgApp fun args) = do
    419 
    -  lf <- getLintFlags
    420 
    -  when (lf_unarised lf) $ do
    412 
    +lintAppCbvMarks :: Id -> [StgArg] -> LintM ()
    413 
    +lintAppCbvMarks fun args
    414 
    +  | idCbvMarkArity fun > length args
    421 415 
         -- A function which expects a unlifted argument as n'th argument
    422 416 
         -- always needs to be applied to n arguments.
    423 417 
         -- See Note [CBV Function Ids: overview].
    424 
    -    let marks = fromMaybe [] $ idCbvMarks_maybe fun
    425 
    -    when (length (dropWhileEndLE (not . isMarkedCbv) marks) > length args) $ do
    426 
    -      addErrL $ hang (text "Undersatured cbv marked ID in App" <+> ppr e ) 2 $
    427 
    -        (text "marks" <> ppr marks $$
    428 
    -        text "args" <> ppr args $$
    429 
    -        text "arity" <> ppr (idArity fun) $$
    430 
    -        text "join_arity" <> ppr (idJoinPointHood fun))
    431 
    -lintAppCbvMarks _ = panic "impossible - lintAppCbvMarks"
    418 
    +  = addErrL $ hang (text "Undersatured cbv marked ID in App" <+> ppr fun)
    419 
    +                 2 (vcat [ text "marks" <> ppr (idCbvMarks_maybe fun)
    420 
    +                         , text "args" <> ppr args
    421 
    +                         , text "arity" <> ppr (idArity fun)
    422 
    +                         , text "join_arity" <> ppr (idJoinPointHood fun) ])
    423 
    +
    424 
    +  | otherwise
    425 
    +  = return ()
    432 426
    433 427 
     {-
    434 428 
     ************************************************************************

  • compiler/GHC/Types/Id.hs
    ... ... @@ -852,7 +852,7 @@ idCbvMarks_maybe id = case idDetails id of
    852 852 
       _                    -> Nothing
    853 853
    854 854 
     -- Id must be called with at least this arity in order to allow arguments to
    855 
    --- be passed unlifted.
    855 
    +-- be passed unlifted.  Return 0 if there are no CBV marks.
    856 856 
     idCbvMarkArity :: Id -> Arity
    857 857 
     idCbvMarkArity fn = maybe 0 length (idCbvMarks_maybe fn)
    858 858

  • compiler/GHC/Types/Id/Info.hs
    ... ... @@ -210,6 +210,7 @@ data IdDetails
    210 210 
             -- Can also work as a WorkerLikeId if given `CbvMark`s.
    211 211 
             -- See Note [CBV Function Ids: overview]
    212 212 
             -- The [CbvMark] is always empty (and ignored) until after Tidy.
    213 
    +
    213 214 
       | WorkerLikeId [CbvMark]
    214 215 
             -- ^ An 'Id' for a worker like function, which might expect some arguments to be
    215 216 
             -- passed both evaluated and tagged.
    ... ... @@ -217,8 +218,10 @@ data IdDetails
    217 218 
             -- aren't used unapplied.
    218 219 
             -- See Note [CBV Function Ids: overview]
    219 220 
             -- See Note [EPT enforcement]
    220 
    -        -- The [CbvMark] is always empty (and ignored) until after Tidy for ids from the current
    221 
    -        -- module.
    221 
    +        -- Invariants:
    222 
    +        --   - the [CbvMark] is always empty (and ignored) until after Tidy
    223 
    +        --     for ids from the current module
    224 
    +        --   - If non-empty, at least is isMarkedCbbv; see (CBV2)
    222 225
    223 226 
     data RecSelInfo
    224 227 
       = RSI { rsi_def   :: [ConLike]   -- Record selector defined for these
    ... ... @@ -297,9 +300,7 @@ Here's how it all works:
    297 300 
       to identify strict arguments.  See Note [Call-by-value for worker args] for
    298 301 
       how a worker guarantees to be strict in strict datacon fields.
    299 302
    300 
    -  TODO: We currently don't do this for arguments that are unboxed sums or tuples,
    301 
    -  because then we'd have to predict the result of unarisation. But it would be nice to
    302 
    -  do so. See `computeCbvInfo`.
    303 
    +  See (CBV1) and (CBV2).
    303 304
    304 305 
     * During CorePrep calls to CBV Ids are eta expanded.
    305 306 
       See `GHC.CoreToStg.Prep.maybeSaturate`.
    ... ... @@ -319,6 +320,16 @@ Here's how it all works:
    319 320 
     * Imported functions may be CBV, and then there is no point in eta-reducing
    320 321 
       them; we'll just have to eta-expand later; see GHC.Core.Opt.Arity.cantEtaReduceFun.
    321 322
    323 
    +Wrinkles
    324 
    +
    325 
    +(CBV1) We do not set the CBV-marks for a function that takes an unboxed sum or tuple,
    326 
    +  as an argument, because then we'd have to predict the result of unarisation.
    327 
    +  It would be nice to do so in future. See `computeCbvInfo`.
    328 
    +
    329 
    +(CBV2) We do not set CBV-marks if none of them are `isMarkedCbv`.  Why not?
    330 
    +  Because if none are CBV then there is nothing special to do for this function;
    331 
    +  in particular, we don't need to saturate its calls.  See `computeCbvInfo`.
    332 
    +
    322 333 
     *** SPJ really? Andreas? ****
    323 334 
     We only use this for workers and specialized versions of SpecConstr
    324 335 
     But we also check other functions during tidy and potentially turn some of them into

  • testsuite/tests/arityanal/should_compile/Arity01.stderr
    ... ... @@ -5,19 +5,19 @@ Result size of Tidy Core = {terms: 71, types: 43, coercions: 0, joins: 0/0}
    5 5 
     -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
    6 6 
     F1.f2 :: Integer
    7 7 
     [GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
    8 
    -F1.f2 = GHC.Num.Integer.IS 1#
    8 
    +F1.f2 = GHC.Internal.Bignum.Integer.IS 1#
    9 9
    10 10 
     Rec {
    11 11 
     -- RHS size: {terms: 24, types: 6, coercions: 0, joins: 0/0}
    12 12 
     F1.f1_h1 [Occ=LoopBreaker] :: Integer -> Integer -> Integer -> Integer
    13 13 
     [GblId, Arity=3, Str=<1L><1L><SL>, Unf=OtherCon []]
    14 14 
     F1.f1_h1
    15 
    -  = \ (n :: Integer) (x :: Integer) (eta [OS=OneShot] :: Integer) ->
    15 
    +  = \ (n :: Integer) (x [OS=OneShot] :: Integer) (eta [OS=OneShot] :: Integer) ->
    16 16 
           case x of x1 { __DEFAULT ->
    17 17 
           case n of y1 { __DEFAULT ->
    18 
    -      case GHC.Num.Integer.integerLt# x1 y1 of {
    18 
    +      case GHC.Internal.Bignum.Integer.integerLt# x1 y1 of {
    19 19 
             __DEFAULT -> eta;
    20 
    -        1# -> F1.f1_h1 y1 (GHC.Num.Integer.integerAdd x1 F1.f2) (GHC.Num.Integer.integerAdd x1 eta)
    20 
    +        1# -> F1.f1_h1 y1 (GHC.Internal.Bignum.Integer.integerAdd x1 F1.f2) (GHC.Internal.Bignum.Integer.integerAdd x1 eta)
    21 21 
           }
    22 22 
           }
    23 23 
           }
    ... ... @@ -26,7 +26,7 @@ end Rec }
    26 26 
     -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
    27 27 
     F1.f3 :: Integer
    28 28 
     [GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
    29 
    -F1.f3 = GHC.Num.Integer.IS 5#
    29 
    +F1.f3 = GHC.Internal.Bignum.Integer.IS 5#
    30 30
    31 31 
     -- RHS size: {terms: 4, types: 0, coercions: 0, joins: 0/0}
    32 32 
     f1 :: Integer
    ... ... @@ -36,27 +36,27 @@ f1 = F1.f1_h1 F1.f3 F1.f2 F1.f3
    36 36 
     -- RHS size: {terms: 14, types: 5, coercions: 0, joins: 0/0}
    37 37 
     g :: Integer -> Integer -> Integer -> Integer -> Integer -> Integer
    38 38 
     [GblId, Arity=5, Str=<1L><SL><SL><SL><SL>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [0 0 0 0 0] 120 0}]
    39 
    -g = \ (x1 :: Integer) (x2 :: Integer) (x3 :: Integer) (x4 :: Integer) (x5 :: Integer) -> GHC.Num.Integer.integerAdd (GHC.Num.Integer.integerAdd (GHC.Num.Integer.integerAdd (GHC.Num.Integer.integerAdd x1 x2) x3) x4) x5
    39 
    +g = \ (x1 :: Integer) (x2 :: Integer) (x3 :: Integer) (x4 :: Integer) (x5 :: Integer) -> GHC.Internal.Bignum.Integer.integerAdd (GHC.Internal.Bignum.Integer.integerAdd (GHC.Internal.Bignum.Integer.integerAdd (GHC.Internal.Bignum.Integer.integerAdd x1 x2) x3) x4) x5
    40 40
    41 41 
     -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
    42 42 
     F1.s1 :: Integer
    43 43 
     [GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
    44 
    -F1.s1 = GHC.Num.Integer.IS 3#
    44 
    +F1.s1 = GHC.Internal.Bignum.Integer.IS 3#
    45 45
    46 46 
     -- RHS size: {terms: 8, types: 7, coercions: 0, joins: 0/0}
    47 47 
     s :: forall {t1} {t2}. Num t1 => (t1 -> t2) -> t2
    48 
    -[GblId, Arity=2, Str=<MP(A,A,A,A,A,A,1C(1,L))><1C(1,L)>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [30 60] 50 0}]
    48 
    +[GblId, Arity=2, Str=<MP(A,A,A,A,A,A,1C(1,L))><1C(1,L)>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [90 60] 50 0}]
    49 49 
     s = \ (@t) (@t1) ($dNum :: Num t) (f :: t -> t1) -> f (fromInteger @t $dNum F1.s1)
    50 50
    51 51 
     -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
    52 52 
     F1.h1 :: Integer
    53 53 
     [GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
    54 
    -F1.h1 = GHC.Num.Integer.IS 24#
    54 
    +F1.h1 = GHC.Internal.Bignum.Integer.IS 24#
    55 55
    56 56 
     -- RHS size: {terms: 4, types: 1, coercions: 0, joins: 0/0}
    57 57 
     h :: Integer -> Integer
    58 58 
     [GblId, Arity=1, Str=<SL>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [0] 30 0}]
    59 
    -h = \ (x5 :: Integer) -> GHC.Num.Integer.integerAdd F1.h1 x5
    59 
    +h = \ (x5 :: Integer) -> GHC.Internal.Bignum.Integer.integerAdd F1.h1 x5
    60 60
    61 61
    62 62

  • testsuite/tests/arityanal/should_compile/Arity05.stderr
    ... ... @@ -5,27 +5,27 @@ Result size of Tidy Core = {terms: 42, types: 44, coercions: 0, joins: 0/0}
    5 5 
     -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
    6 6 
     F5.f5g1 :: Integer
    7 7 
     [GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
    8 
    -F5.f5g1 = GHC.Num.Integer.IS 1#
    8 
    +F5.f5g1 = GHC.Internal.Bignum.Integer.IS 1#
    9 9
    10 10 
     -- RHS size: {terms: 12, types: 9, coercions: 0, joins: 0/0}
    11 11 
     f5g :: forall {a} {t}. Num a => (t -> a) -> t -> a
    12 
    -[GblId, Arity=3, Str=<SP(1C(1,C(1,L)),A,A,A,A,A,MC(1,L))><MC(1,L)><L>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [60 60 0] 90 0}]
    12 
    +[GblId, Arity=3, Str=<SP(1C(1,C(1,L)),A,A,A,A,A,MC(1,L))><MC(1,L)><L>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [180 60 0] 90 0}]
    13 13 
     f5g = \ (@a) (@t) ($dNum :: Num a) (h :: t -> a) (z :: t) -> + @a $dNum (h z) (fromInteger @a $dNum F5.f5g1)
    14 14
    15 15 
     -- RHS size: {terms: 17, types: 12, coercions: 0, joins: 0/0}
    16 16 
     f5h :: forall {a} {t}. Num a => (t -> a) -> t -> (t -> a) -> a
    17 
    -[GblId, Arity=4, Str=<SP(SC(S,C(1,L)),A,A,A,A,A,MC(1,L))><MC(1,L)><L><MC(1,L)>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [90 60 0 60] 150 0}]
    17 
    +[GblId, Arity=4, Str=<SP(SC(S,C(1,L)),A,A,A,A,A,MC(1,L))><MC(1,L)><L><MC(1,L)>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [270 60 0 60] 150 0}]
    18 18 
     f5h = \ (@a) (@t) ($dNum :: Num a) (f :: t -> a) (x :: t) (g :: t -> a) -> + @a $dNum (f x) (+ @a $dNum (g x) (fromInteger @a $dNum F5.f5g1))
    19 19
    20 20 
     -- RHS size: {terms: 4, types: 1, coercions: 0, joins: 0/0}
    21 21 
     f5y :: Integer -> Integer
    22 22 
     [GblId, Arity=1, Str=<1L>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [0] 30 0}]
    23 
    -f5y = \ (y :: Integer) -> GHC.Num.Integer.integerAdd y F5.f5g1
    23 
    +f5y = \ (y :: Integer) -> GHC.Internal.Bignum.Integer.integerAdd y F5.f5g1
    24 24
    25 25 
     -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
    26 26 
     f5 :: Integer
    27 27 
     [GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
    28 
    -f5 = GHC.Num.Integer.IS 3#
    28 
    +f5 = GHC.Internal.Bignum.Integer.IS 3#
    29 29
    30 30
    31 31

  • testsuite/tests/arityanal/should_compile/Arity08.stderr
    ... ... @@ -4,7 +4,7 @@ Result size of Tidy Core = {terms: 24, types: 18, coercions: 0, joins: 0/0}
    4 4
    5 5 
     -- RHS size: {terms: 20, types: 10, coercions: 0, joins: 0/0}
    6 6 
     f8f :: forall {p}. Num p => Bool -> p -> p -> p
    7 
    -[GblId, Arity=4, Str=<LP(SC(S,C(1,L)),A,MC(1,C(1,L)),A,A,A,A)><1L><L><L>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [90 30 0 0] 140 0}]
    7 
    +[GblId, Arity=4, Str=<LP(SC(S,C(1,L)),A,MC(1,C(1,L)),A,A,A,A)><1L><L><L>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [270 30 0 0] 140 0}]
    8 8 
     f8f
    9 9 
       = \ (@p) ($dNum :: Num p) (b :: Bool) (x :: p) (y :: p) ->
    10 10 
           case b of {
    ... ... @@ -15,7 +15,7 @@ f8f
    15 15 
     -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
    16 16 
     f8 :: Integer
    17 17 
     [GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
    18 
    -f8 = GHC.Num.Integer.IS 2#
    18 
    +f8 = GHC.Internal.Bignum.Integer.IS 2#
    19 19
    20 20
    21 21

  • testsuite/tests/arityanal/should_compile/Arity11.stderr
    ... ... @@ -5,57 +5,23 @@ Result size of Tidy Core = {terms: 136, types: 75, coercions: 0, joins: 2/7}
    5 5 
     -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
    6 6 
     F11.fib3 :: Integer
    7 7 
     [GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
    8 
    -F11.fib3 = GHC.Num.Integer.IS 1#
    8 
    +F11.fib3 = GHC.Internal.Bignum.Integer.IS 1#
    9 9
    10 10 
     -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
    11 11 
     F11.fib2 :: Integer
    12 12 
     [GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
    13 
    -F11.fib2 = GHC.Num.Integer.IS 2#
    14 
    -
    15 
    -Rec {
    16 
    --- RHS size: {terms: 38, types: 13, coercions: 0, joins: 2/2}
    17 
    -F11.f11_fib [Occ=LoopBreaker] :: Integer -> Integer
    18 
    -[GblId, Arity=1, Str=<SL>, Unf=OtherCon []]
    19 
    -F11.f11_fib
    20 
    -  = \ (ds :: Integer) ->
    21 
    -      join {
    22 
    -        $j [Dmd=ML] :: Integer
    23 
    -        [LclId[JoinId(0)(Nothing)]]
    24 
    -        $j
    25 
    -          = join {
    26 
    -              $j1 [Dmd=ML] :: Integer
    27 
    -              [LclId[JoinId(0)(Nothing)]]
    28 
    -              $j1 = GHC.Num.Integer.integerAdd (F11.f11_fib (GHC.Num.Integer.integerSub ds F11.fib3)) (F11.f11_fib (GHC.Num.Integer.integerSub ds F11.fib2)) } in
    29 
    -            case ds of {
    30 
    -              GHC.Num.Integer.IS x1 ->
    31 
    -                case x1 of {
    32 
    -                  __DEFAULT -> jump $j1;
    33 
    -                  1# -> F11.fib3
    34 
    -                };
    35 
    -              GHC.Num.Integer.IP x1 -> jump $j1;
    36 
    -              GHC.Num.Integer.IN x1 -> jump $j1
    37 
    -            } } in
    38 
    -      case ds of {
    39 
    -        GHC.Num.Integer.IS x1 ->
    40 
    -          case x1 of {
    41 
    -            __DEFAULT -> jump $j;
    42 
    -            0# -> F11.fib3
    43 
    -          };
    44 
    -        GHC.Num.Integer.IP x1 -> jump $j;
    45 
    -        GHC.Num.Integer.IN x1 -> jump $j
    46 
    -      }
    47 
    -end Rec }
    13 
    +F11.fib2 = GHC.Internal.Bignum.Integer.IS 2#
    48 14
    49 15 
     -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
    50 16 
     F11.fib1 :: Integer
    51 17 
     [GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
    52 
    -F11.fib1 = GHC.Num.Integer.IS 0#
    18 
    +F11.fib1 = GHC.Internal.Bignum.Integer.IS 0#
    53 19
    54 20 
     -- RHS size: {terms: 54, types: 27, coercions: 0, joins: 0/5}
    55 
    -fib :: forall {t} {a}. (Eq t, Num t, Num a) => t -> a
    56 
    -[GblId, Arity=4, Str=<SP(SC(S,C(1,L)),A)><LP(A,LC(L,C(1,L)),A,A,A,A,L)><LP(LC(S,C(1,L)),A,A,A,A,A,MC(1,L))><L>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [60 150 60 0] 480 0}]
    21 
    +fib :: forall {t1} {t2}. (Eq t1, Num t1, Num t2) => t1 -> t2
    22 
    +[GblId, Arity=4, Str=<SP(SC(S,C(1,L)),A)><LP(A,LC(L,C(1,L)),A,A,A,A,L)><LP(LC(S,C(1,L)),A,A,A,A,A,MC(1,L))><L>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [180 450 180 0] 480 0}]
    57 23 
     fib
    58 
    -  = \ (@t) (@a) ($dEq :: Eq t) ($dNum :: Num t) ($dNum1 :: Num a) (eta :: t) ->
    24 
    +  = \ (@t) (@t1) ($dEq :: Eq t) ($dNum :: Num t) ($dNum1 :: Num t1) (eta :: t) ->
    59 25 
           let {
    60 26 
             lvl :: t
    61 27 
             [LclId]
    ... ... @@ -65,32 +31,66 @@ fib
    65 31 
             [LclId]
    66 32 
             lvl1 = fromInteger @t $dNum F11.fib2 } in
    67 33 
           let {
    68 
    -        lvl2 :: a
    34 
    +        lvl2 :: t1
    69 35 
             [LclId]
    70 
    -        lvl2 = fromInteger @a $dNum1 F11.fib3 } in
    36 
    +        lvl2 = fromInteger @t1 $dNum1 F11.fib3 } in
    71 37 
           let {
    72 38 
             lvl3 :: t
    73 39 
             [LclId]
    74 40 
             lvl3 = fromInteger @t $dNum F11.fib1 } in
    75 41 
           letrec {
    76 
    -        fib4 [Occ=LoopBreaker, Dmd=SC(S,L)] :: t -> a
    42 
    +        fib4 [Occ=LoopBreaker, Dmd=SC(S,L)] :: t -> t1
    77 43 
             [LclId, Arity=1, Str=<L>, Unf=OtherCon []]
    78 44 
             fib4
    79 45 
               = \ (ds :: t) ->
    80 46 
                   case == @t $dEq ds lvl3 of {
    81 47 
                     False ->
    82 48 
                       case == @t $dEq ds lvl of {
    83 
    -                    False -> + @a $dNum1 (fib4 (- @t $dNum ds lvl)) (fib4 (- @t $dNum ds lvl1));
    49 
    +                    False -> + @t1 $dNum1 (fib4 (- @t $dNum ds lvl)) (fib4 (- @t $dNum ds lvl1));
    84 50 
                         True -> lvl2
    85 51 
                       };
    86 52 
                     True -> lvl2
    87 53 
                   }; } in
    88 54 
           fib4 eta
    89 55
    56 
    +Rec {
    57 
    +-- RHS size: {terms: 38, types: 13, coercions: 0, joins: 2/2}
    58 
    +F11.f11_fib [Occ=LoopBreaker] :: Integer -> Integer
    59 
    +[GblId, Arity=1, Str=<SL>, Unf=OtherCon []]
    60 
    +F11.f11_fib
    61 
    +  = \ (ds :: Integer) ->
    62 
    +      join {
    63 
    +        $j [Dmd=ML] :: Integer
    64 
    +        [LclId[JoinId(0)(Nothing)]]
    65 
    +        $j
    66 
    +          = join {
    67 
    +              $j1 [Dmd=ML] :: Integer
    68 
    +              [LclId[JoinId(0)(Nothing)]]
    69 
    +              $j1 = GHC.Internal.Bignum.Integer.integerAdd (F11.f11_fib (GHC.Internal.Bignum.Integer.integerSub ds F11.fib3)) (F11.f11_fib (GHC.Internal.Bignum.Integer.integerSub ds F11.fib2)) } in
    70 
    +            case ds of {
    71 
    +              GHC.Internal.Bignum.Integer.IS x ->
    72 
    +                case x of {
    73 
    +                  __DEFAULT -> jump $j1;
    74 
    +                  1# -> F11.fib3
    75 
    +                };
    76 
    +              GHC.Internal.Bignum.Integer.IP x -> jump $j1;
    77 
    +              GHC.Internal.Bignum.Integer.IN x -> jump $j1
    78 
    +            } } in
    79 
    +      case ds of {
    80 
    +        GHC.Internal.Bignum.Integer.IS x ->
    81 
    +          case x of {
    82 
    +            __DEFAULT -> jump $j;
    83 
    +            0# -> F11.fib3
    84 
    +          };
    85 
    +        GHC.Internal.Bignum.Integer.IP x -> jump $j;
    86 
    +        GHC.Internal.Bignum.Integer.IN x -> jump $j
    87 
    +      }
    88 
    +end Rec }
    89 
    +
    90 90 
     -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
    91 91 
     F11.f3 :: Integer
    92 92 
     [GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
    93 
    -F11.f3 = GHC.Num.Integer.IS 1000#
    93 
    +F11.f3 = GHC.Internal.Bignum.Integer.IS 1000#
    94 94
    95 95 
     -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
    96 96 
     F11.f11_x :: Integer
    ... ... @@ -100,7 +100,7 @@ F11.f11_x = F11.f11_fib F11.f3
    100 100 
     -- RHS size: {terms: 4, types: 1, coercions: 0, joins: 0/0}
    101 101 
     F11.f11f1 :: Integer -> Integer
    102 102 
     [GblId, Arity=1, Str=<SL>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [0] 30 0}]
    103 
    -F11.f11f1 = \ (y :: Integer) -> GHC.Num.Integer.integerAdd F11.f11_x y
    103 
    +F11.f11f1 = \ (y :: Integer) -> GHC.Internal.Bignum.Integer.integerAdd F11.f11_x y
    104 104
    105 105 
     -- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0}
    106 106 
     f11f :: forall {p}. p -> Integer -> Integer
    ... ... @@ -110,22 +110,22 @@ f11f = \ (@p) _ [Occ=Dead] -> F11.f11f1
    110 110 
     -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
    111 111 
     F11.f5 :: Integer
    112 112 
     [GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
    113 
    -F11.f5 = GHC.Num.Integer.IS 6#
    113 
    +F11.f5 = GHC.Internal.Bignum.Integer.IS 6#
    114 114
    115 115 
     -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
    116 116 
     F11.f4 :: Integer
    117 117 
     [GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=False, ConLike=False, WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 30 0}]
    118 
    -F11.f4 = GHC.Num.Integer.integerAdd F11.f11_x F11.f5
    118 
    +F11.f4 = GHC.Internal.Bignum.Integer.integerAdd F11.f11_x F11.f5
    119 119
    120 120 
     -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
    121 121 
     F11.f2 :: Integer
    122 122 
     [GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
    123 
    -F11.f2 = GHC.Num.Integer.IS 8#
    123 
    +F11.f2 = GHC.Internal.Bignum.Integer.IS 8#
    124 124
    125 125 
     -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
    126 126 
     F11.f1 :: Integer
    127 127 
     [GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=False, ConLike=False, WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 30 0}]
    128 
    -F11.f1 = GHC.Num.Integer.integerAdd F11.f11_x F11.f2
    128 
    +F11.f1 = GHC.Internal.Bignum.Integer.integerAdd F11.f11_x F11.f2
    129 129
    130 130 
     -- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0}
    131 131 
     f11 :: (Integer, Integer)
    ... ... @@ -133,7 +133,4 @@ f11 :: (Integer, Integer)
    133 133 
     f11 = (F11.f4, F11.f1)
    134 134
    135 135
    136 
    ------- Local rules for imported ids --------
    137 
    -"SPEC fib @Integer @Integer" forall ($dEq :: Eq Integer) ($dNum :: Num Integer) ($dNum1 :: Num Integer). fib @Integer @Integer $dEq $dNum $dNum1 = F11.f11_fib
    138 
    -
    139 136

  • testsuite/tests/arityanal/should_compile/Arity14.stderr
    ... ... @@ -3,18 +3,18 @@
    3 3 
     Result size of Tidy Core = {terms: 44, types: 38, coercions: 0, joins: 0/3}
    4 4
    5 5 
     -- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0}
    6 
    -F14.f1 :: forall {t}. t -> t
    6 
    +F14.f1 :: forall t. t -> t
    7 7 
     [GblId, Arity=1, Str=<1L>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=True)}]
    8 8 
     F14.f1 = \ (@t) (y :: t) -> y
    9 9
    10 10 
     -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
    11 11 
     F14.f2 :: Integer
    12 12 
     [GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
    13 
    -F14.f2 = GHC.Num.Integer.IS 1#
    13 
    +F14.f2 = GHC.Internal.Bignum.Integer.IS 1#
    14 14
    15 15 
     -- RHS size: {terms: 36, types: 23, coercions: 0, joins: 0/3}
    16 16 
     f14 :: forall {t}. (Ord t, Num t) => t -> t -> t -> t
    17 
    -[GblId, Arity=4, Str=<SP(A,A,SC(S,C(1,L)),A,A,A,A,A)><LP(LC(L,C(1,L)),A,A,A,A,A,MC(1,L))><L><L>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [30 90 0 0] 310 0}]
    17 
    +[GblId, Arity=4, Str=<SP(A,A,SC(S,C(1,L)),A,A,A,A,A)><LP(LC(L,C(1,L)),A,A,A,A,A,MC(1,L))><L><L>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [90 270 0 0] 310 0}]
    18 18 
     f14
    19 19 
       = \ (@t) ($dOrd :: Ord t) ($dNum :: Num t) (eta :: t) (eta1 :: t) ->
    20 20 
           let {
    ... ... @@ -25,7 +25,7 @@ f14
    25 25 
             f3 [Occ=LoopBreaker, Dmd=SC(S,C(1,L))] :: t -> t -> t -> t
    26 26 
             [LclId, Arity=2, Str=<L><L>, Unf=OtherCon []]
    27 27 
             f3
    28 
    -          = \ (n :: t) (x :: t) ->
    28 
    +          = \ (n :: t) (x [OS=OneShot] :: t) ->
    29 29 
                   case < @t $dOrd x n of {
    30 30 
                     False -> F14.f1 @t;
    31 31 
                     True ->

  • testsuite/tests/wasm/should_run/control-flow/LoadCmmGroup.hs
    ... ... @@ -91,12 +91,17 @@ stgify :: ModSummary -> ModGuts -> Ghc [StgTopBinding]
    91 91 
     stgify summary guts = do
    92 92 
         hsc_env <- getSession
    93 93 
         let dflags = hsc_dflags hsc_env
    94 
    -    prepd_binds <- liftIO $ do
    94 
    +    liftIO $ do
    95 95 
           cp_cfg <- initCorePrepConfig hsc_env
    96 
    -      corePrepPgm (hsc_logger hsc_env) cp_cfg (initCorePrepPgmConfig dflags (interactiveInScope $ hsc_IC hsc_env)) this_mod core_binds
    97 
    -    return $ fstOf3 $ coreToStg (initCoreToStgOpts dflags) (ms_mod summary) (ms_location summary) prepd_binds
    98 
    -  where this_mod = mg_module guts
    99 
    -        core_binds = mg_binds guts
    96 
    +      prepd_binds <- corePrepPgm (hsc_logger hsc_env) cp_cfg
    97 
    +                       (initCorePrepPgmConfig dflags (interactiveInScope $ hsc_IC hsc_env))
    98 
    +                       this_mod core_binds
    99 
    +      (binds, _, _) <- coreToStg (initCoreToStgOpts dflags) (ms_mod summary)
    100 
    +                                 (ms_location summary) prepd_binds
    101 
    +      return binds
    102 
    +  where
    103 
    +    this_mod = mg_module guts
    104 
    +    core_binds = mg_binds guts
    100 105
    101 106 
     slurpCmm :: HscEnv -> FilePath -> IO (CmmGroup)
    102 107 
     slurpCmm hsc_env filename = runHsc hsc_env $ do

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