diff options
author | Simon Peyton Jones <simonpj@microsoft.com> | 2021-07-23 23:35:21 +0100 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2022-05-30 13:44:14 -0400 |
commit | 0079171bae7271dc44f81c3bf26505941ee92d7e (patch) | |
tree | 1d177f118726e1b739d5859be8f4547d70126977 | |
parent | 80ba50c7f589c3a1ee95619d24f350368c9b9759 (diff) | |
download | haskell-0079171bae7271dc44f81c3bf26505941ee92d7e.tar.gz |
Make PrimOpId record levity
This patch concerns #20155, part (1)
The general idea is that since primops have curried bindings
(currently in PrimOpWrappers.hs) we don't need to eta-expand
them. But we /do/ need to eta-expand the levity-polymorphic ones,
because they /don't/ have bindings.
This patch makes a start in that direction, by identifying the
levity-polymophic primops in the PrimOpId IdDetails constructor.
For the moment, I'm still eta-expanding all primops (by saying
that hasNoBinding returns True for all primops), because of the
bug reported in #20155. But I hope that before long we can
tidy that up too, and remove the TEMPORARILY stuff in hasNoBinding.
-rw-r--r-- | compiler/GHC/Core/Type.hs | 18 | ||||
-rw-r--r-- | compiler/GHC/Core/Unfold.hs | 8 | ||||
-rw-r--r-- | compiler/GHC/Core/Utils.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/CoreToStg.hs | 13 | ||||
-rw-r--r-- | compiler/GHC/Types/Id.hs | 15 | ||||
-rw-r--r-- | compiler/GHC/Types/Id/Info.hs | 7 | ||||
-rw-r--r-- | compiler/GHC/Types/Id/Make.hs | 1 |
7 files changed, 43 insertions, 23 deletions
diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs index d9d8b41f33..419c0c8806 100644 --- a/compiler/GHC/Core/Type.hs +++ b/compiler/GHC/Core/Type.hs @@ -150,7 +150,7 @@ module GHC.Core.Type ( Kind, -- ** Finding the kind of a type - typeKind, tcTypeKind, typeHasFixedRuntimeRep, + typeKind, tcTypeKind, typeHasFixedRuntimeRep, argsHaveFixedRuntimeRep, tcIsLiftedTypeKind, tcIsConstraintKind, tcReturnsConstraintKind, tcIsBoxedTypeKind, tcIsRuntimeTypeKind, @@ -294,8 +294,7 @@ import GHC.Data.Pair import GHC.Data.List.SetOps import GHC.Types.Unique ( nonDetCmpUnique ) -import GHC.Data.Maybe ( orElse, expectJust ) -import Data.Maybe ( isJust ) +import GHC.Data.Maybe ( orElse, expectJust, isJust ) import Control.Monad ( guard ) -- import GHC.Utils.Trace @@ -3201,6 +3200,19 @@ typeHasFixedRuntimeRep = go go (ForAllTy _ ty) = go ty go ty = isFixedRuntimeRepKind (typeKind ty) +argsHaveFixedRuntimeRep :: Type -> Bool +-- ^ True if the argument types of this function type +-- all have a fixed-runtime-rep +argsHaveFixedRuntimeRep ty + = all ok bndrs + where + ok :: TyCoBinder -> Bool + ok (Anon _ ty) = typeHasFixedRuntimeRep (scaledThing ty) + ok _ = True + + bndrs :: [TyCoBinder] + (bndrs, _) = splitPiTys ty + {- ********************************************************************** * * Occurs check expansion diff --git a/compiler/GHC/Core/Unfold.hs b/compiler/GHC/Core/Unfold.hs index 0ff846d79e..6316e321d4 100644 --- a/compiler/GHC/Core/Unfold.hs +++ b/compiler/GHC/Core/Unfold.hs @@ -528,9 +528,9 @@ sizeExpr opts !bOMB_OUT_SIZE top_args expr is_inline_scrut scrut | (Var f, _) <- collectArgs scrut = case idDetails f of - FCallId fc -> not (isSafeForeignCall fc) - PrimOpId op -> not (primOpOutOfLine op) - _other -> False + FCallId fc -> not (isSafeForeignCall fc) + PrimOpId op _ -> not (primOpOutOfLine op) + _other -> False | otherwise = False @@ -564,7 +564,7 @@ sizeExpr opts !bOMB_OUT_SIZE top_args expr = case idDetails fun of FCallId _ -> sizeN (callSize (length val_args) voids) DataConWorkId dc -> conSize dc (length val_args) - PrimOpId op -> primOpSize op (length val_args) + PrimOpId op _ -> primOpSize op (length val_args) ClassOpId _ -> classOpSize opts top_args val_args _ -> funSize opts top_args fun (length val_args) voids diff --git a/compiler/GHC/Core/Utils.hs b/compiler/GHC/Core/Utils.hs index 33999c5070..2d287a1b3d 100644 --- a/compiler/GHC/Core/Utils.hs +++ b/compiler/GHC/Core/Utils.hs @@ -1422,7 +1422,7 @@ isCheapApp fn n_val_args DataConWorkId {} -> True -- Actually handled by isWorkFreeApp RecSelId {} -> n_val_args == 1 -- See Note [Record selection] ClassOpId {} -> n_val_args == 1 - PrimOpId op -> primOpIsCheap op + PrimOpId op _ -> primOpIsCheap op _ -> False -- In principle we should worry about primops -- that return a type variable, since the result @@ -1629,7 +1629,7 @@ app_ok primop_ok fun args -- been expressed by its "wrapper", so we don't need -- to take the arguments into account - PrimOpId op + PrimOpId op _ | primOpIsDiv op , [arg1, Lit lit] <- args -> not (isZeroLit lit) && expr_ok primop_ok arg1 diff --git a/compiler/GHC/CoreToStg.hs b/compiler/GHC/CoreToStg.hs index d6fd70e8db..5ba4decd4f 100644 --- a/compiler/GHC/CoreToStg.hs +++ b/compiler/GHC/CoreToStg.hs @@ -51,7 +51,7 @@ import GHC.Types.SrcLoc ( mkGeneralSrcSpan ) import GHC.Unit.Module import GHC.Data.FastString import GHC.Platform.Ways -import GHC.Builtin.PrimOps ( PrimCall(..) ) +import GHC.Builtin.PrimOps ( PrimCall(..), primOpWrapperId ) import GHC.Utils.Outputable import GHC.Utils.Monad @@ -548,7 +548,7 @@ coreToStgApp f args ticks = do -- Some primitive operator that might be implemented as a library call. -- As noted by Note [Eta expanding primops] in GHC.Builtin.PrimOps -- we require that primop applications be saturated. - PrimOpId op -> assert saturated $ + PrimOpId op _ -> -- assertPpr saturated (ppr f <+> ppr args) $ StgOpApp (StgPrimOp op) args' res_ty -- A call to some primitive Cmm function. @@ -600,10 +600,11 @@ coreToStgArgs (arg : args) = do -- Non-type argument let (aticks, arg'') = stripStgTicksTop tickishFloatable arg' stg_arg = case arg'' of - StgApp v [] -> StgVarArg v - StgConApp con _ [] _ -> StgVarArg (dataConWorkId con) - StgLit lit -> StgLitArg lit - _ -> pprPanic "coreToStgArgs" (ppr arg) + StgApp v [] -> StgVarArg v + StgConApp con _ [] _ -> StgVarArg (dataConWorkId con) + StgOpApp (StgPrimOp op) [] _ -> StgVarArg (primOpWrapperId op) + StgLit lit -> StgLitArg lit + _ -> pprPanic "coreToStgArgs" (ppr arg $$ pprStgExpr panicStgPprOpts arg' $$ pprStgExpr panicStgPprOpts arg'') -- WARNING: what if we have an argument like (v `cast` co) -- where 'co' changes the representation type? diff --git a/compiler/GHC/Types/Id.hs b/compiler/GHC/Types/Id.hs index d5b308a550..01ad94172a 100644 --- a/compiler/GHC/Types/Id.hs +++ b/compiler/GHC/Types/Id.hs @@ -500,16 +500,16 @@ isClassOpId_maybe id = case Var.idDetails id of _other -> Nothing isPrimOpId id = case Var.idDetails id of - PrimOpId _ -> True - _ -> False + PrimOpId {} -> True + _ -> False isDFunId id = case Var.idDetails id of DFunId {} -> True _ -> False isPrimOpId_maybe id = case Var.idDetails id of - PrimOpId op -> Just op - _ -> Nothing + PrimOpId op _ -> Just op + _ -> Nothing isFCallId id = case Var.idDetails id of FCallId _ -> True @@ -575,7 +575,12 @@ hasNoBinding :: Id -> Bool -- exception to this is unboxed tuples and sums datacons, which definitely have -- no binding hasNoBinding id = case Var.idDetails id of - PrimOpId _ -> True -- See Note [Eta expanding primops] in GHC.Builtin.PrimOps + +-- TEMPORARILY make all primops hasNoBinding, to avoid #20155 +-- The goal is to understand #20155 and revert to the commented out version + PrimOpId _ _ -> True -- See Note [Eta expanding primops] in GHC.Builtin.PrimOps +-- PrimOpId _ lev_poly -> lev_poly -- TEMPORARILY commented out + FCallId _ -> True DataConWorkId dc -> isUnboxedTupleDataCon dc || isUnboxedSumDataCon dc _ -> isCompulsoryUnfolding (realIdUnfolding id) diff --git a/compiler/GHC/Types/Id/Info.hs b/compiler/GHC/Types/Id/Info.hs index 1b4ee7ae1c..ee7708baa8 100644 --- a/compiler/GHC/Types/Id/Info.hs +++ b/compiler/GHC/Types/Id/Info.hs @@ -153,7 +153,10 @@ data IdDetails | ClassOpId Class -- ^ The 'Id' is a superclass selector, -- or class operation of a class - | PrimOpId PrimOp -- ^ The 'Id' is for a primitive operator + | PrimOpId PrimOp Bool -- ^ The 'Id' is for a primitive operator + -- True <=> is representation-polymorphic, + -- and hence has no binding + | FCallId ForeignCall -- ^ The 'Id' is for a foreign call. -- Type will be simple: no type families, newtypes, etc @@ -274,7 +277,7 @@ pprIdDetails other = brackets (pp other) pp (DataConWorkId _) = text "DataCon" pp (DataConWrapId _) = text "DataConWrapper" pp (ClassOpId {}) = text "ClassOp" - pp (PrimOpId _) = text "PrimOp" + pp (PrimOpId {}) = text "PrimOp" pp (FCallId _) = text "ForeignCall" pp (TickBoxOpId _) = text "TickBoxOp" pp (DFunId nt) = text "DFunId" <> ppWhen nt (text "(nt)") diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs index 3089c6533f..e46a3279fa 100644 --- a/compiler/GHC/Types/Id/Make.hs +++ b/compiler/GHC/Types/Id/Make.hs @@ -81,7 +81,6 @@ import GHC.Utils.Panic.Plain import GHC.Data.FastString import GHC.Data.List.SetOps - {- ************************************************************************ * * |