[Git][ghc/ghc][wip/T20155] WIP stuff
sheaf (@sheaf)
gitlab at gitlab.haskell.org
Wed Jul 26 11:54:41 UTC 2023
sheaf pushed to branch wip/T20155 at Glasgow Haskell Compiler / GHC
Commits:
f807c83e by sheaf at 2023-07-26T13:54:31+02:00
WIP stuff
- - - - -
13 changed files:
- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/Core/Lint.hs
- compiler/GHC/Core/Opt/DmdAnal.hs
- compiler/GHC/CoreToStg.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Stg/Lint.hs
- compiler/GHC/StgToJS/Utils.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Types/Id.hs
- compiler/GHC/Types/Id/Make.hs
- libraries/base/Control/Exception/Base.hs
- libraries/ghc-prim/GHC/Prim/Panic.hs
- utils/genprimopcode/Main.hs
Changes:
=====================================
compiler/GHC/Builtin/primops.txt.pp
=====================================
@@ -223,6 +223,7 @@ defaults
-- nor `a_levpoly` and `a_reppoly`, etc.
primtype TYPE
+primtype CONSTRAINT
section "The word size story."
{Haskell98 specifies that signed integers (type 'Int')
=====================================
compiler/GHC/Core/Lint.hs
=====================================
@@ -1774,7 +1774,7 @@ lintIdBndr :: TopLevelFlag -> BindingSite
lintIdBndr top_lvl bind_site id thing_inside
= assertPpr (isId id) (ppr id) $
do { flags <- getLintFlags
- ; checkL (not (lf_check_global_ids flags) || isLocalId id || isWiredIn id)
+ ; checkL (not (lf_check_global_ids flags) || isLocalId id)
(text "Non-local Id binder" <+> ppr id)
-- See Note [Checking for global Ids]
=====================================
compiler/GHC/Core/Opt/DmdAnal.hs
=====================================
@@ -20,12 +20,6 @@ import GHC.Types.Demand -- All of it
import GHC.Core
import GHC.Core.DataCon
-<<<<<<< HEAD
-=======
-import GHC.Types.ForeignCall ( isSafeForeignCall )
-import GHC.Types.Id
-import GHC.Types.Name ( isWiredIn )
->>>>>>> f0e0cfda35 (Rip out hacks surrounding GHC.Prim and primops)
import GHC.Core.Utils
import GHC.Core.TyCon
import GHC.Core.Type
@@ -150,7 +144,7 @@ isInterestingTopLevelFn :: Id -> Bool
-- If there was a gain, that regression might be acceptable.
-- Plus, we could use LetUp for thunks and share some code with local let
-- bindings.
-isInterestingTopLevelFn id = isLocalId id && typeArity (idType id) > 0
+isInterestingTopLevelFn id = typeArity (idType id) > 0
{- Note [Stamp out space leaks in demand analysis]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1021,8 +1015,7 @@ dmdTransform env var sd
= -- pprTrace "dmdTransform:DictSel" (ppr var $$ ppr (idDmdSig var) $$ ppr sd) $
dmdTransformDictSelSig (idDmdSig var) sd
-- Imported functions
- -- N.B. wired-in names may be GlobalIds and yet not imported.
- | isGlobalId var && not (isWiredIn var)
+ | isGlobalId var
, let res = dmdTransformSig (idDmdSig var) sd
= -- pprTrace "dmdTransform:import" (vcat [ppr var, ppr (idDmdSig var), ppr sd, ppr res])
res
@@ -1912,7 +1905,7 @@ along in boxed form and as such dissuade the creation of reboxing workers.
-}
-- | How many registers does this type take after unarisation?
-unariseArity :: Type -> Arity
+unariseArity :: HasDebugCallStack => Type -> Arity
unariseArity ty = length (typePrimRep ty)
data Budgets = MkB !Arity Budgets -- An infinite list of arity budgets
=====================================
compiler/GHC/CoreToStg.hs
=====================================
@@ -547,8 +547,10 @@ 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.
+ -- SLD TODO: I think unsaturated primops are fine now?
PrimOpId op _
| saturated -> StgOpApp (StgPrimOp op) args' res_ty
+ -- | otherwise -> pprPanic "coreToStg unsaturated PrimOp" (ppr op)
-- A call to some primitive Cmm function.
FCallId (CCall (CCallSpec (StaticTarget _ lbl (Just pkgId) True)
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -529,10 +529,7 @@ warnUnusedPackages us dflags mod_graph =
mapMaybe (\(fs, mn) -> lookupModulePackage us (unLoc mn) fs)
$ concatMap ms_imps home_mod_sum
- any_import_ghc_prim = any ms_ghc_prim_import home_mod_sum
-
used_args = Set.fromList (map unitId loadedPackages)
- `Set.union` Set.fromList [ primUnitId | any_import_ghc_prim ]
resolve (u,mflag) = do
-- The units which we depend on via the command line explicitly
=====================================
compiler/GHC/Stg/Lint.hs
=====================================
@@ -110,7 +110,7 @@ import GHC.Types.CostCentre ( isCurrentCCS )
import GHC.Types.Error ( DiagnosticReason(WarningWithoutFlag) )
import GHC.Types.Id
import GHC.Types.Var.Set
-import GHC.Types.Name ( getSrcLoc, nameIsLocalOrFrom )
+import GHC.Types.Name ( getSrcLoc, nameIsLocalOrFrom, isWiredInName )
import GHC.Types.RepType
import GHC.Types.SrcLoc
@@ -561,12 +561,16 @@ getStgPprOpts :: LintM StgPprOpts
getStgPprOpts = LintM $ \_mod _lf _df opts _loc _scope errs -> (opts, errs)
checkInScope :: Id -> LintM ()
-checkInScope id = LintM $ \mod _lf diag_opts _opts loc scope errs
- -> if nameIsLocalOrFrom mod (idName id) && not (id `elemVarSet` scope) then
+checkInScope id
+ = LintM $ \mod _lf diag_opts _opts loc scope errs ->
+ if not (isWiredInName nm) && (nameIsLocalOrFrom mod nm && not (id `elemVarSet` scope)) then
+ -- SLD TODO?
((), addErr diag_opts errs (hsep [ppr id, dcolon, ppr (idType id),
text "is out of scope"]) loc)
else
((), errs)
+ where
+ nm = idName id
mkUnliftedTyMsg :: OutputablePass a => StgPprOpts -> Id -> GenStgRhs a -> SDoc
mkUnliftedTyMsg opts binder rhs
=====================================
compiler/GHC/StgToJS/Utils.hs
=====================================
@@ -233,7 +233,7 @@ stackSlotType i
idPrimReps :: Id -> [PrimRep]
idPrimReps = typePrimReps . idType
-typePrimReps :: Type -> [PrimRep]
+typePrimReps :: HasDebugCallStack => Type -> [PrimRep]
typePrimReps = typePrimRep . unwrapType
primRepSize :: PrimRep -> SlotCount
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -1042,9 +1042,6 @@ tcInferId :: Name -> TcM (HsExpr GhcTc, TcSigmaType)
-- Look up an occurrence of an Id
-- Do not instantiate its type
tcInferId id_name
- -- TODO: Note
- | Just (AnId id) <- wiredInNameTyThing_maybe id_name = do
- return (HsVar noExtField (noLocA id), idType id)
| id_name `hasKey` assertIdKey
= do { dflags <- getDynFlags
; if gopt Opt_IgnoreAsserts dflags
=====================================
compiler/GHC/Types/Id.hs
=====================================
@@ -153,7 +153,6 @@ import GHC.Types.Name
import GHC.Unit.Module
import GHC.Core.Class
import {-# SOURCE #-} GHC.Builtin.PrimOps (PrimOp)
-import {-# SOURCE #-} GHC.Types.TyThing (tyThingId)
import GHC.Types.ForeignCall
import GHC.Data.Maybe
import GHC.Types.SrcLoc
@@ -307,7 +306,6 @@ mkVanillaGlobalWithInfo = mkGlobalId VanillaId
-- | For an explanation of global vs. local 'Id's, see "GHC.Types.Var#globalvslocal"
mkLocalId :: HasDebugCallStack => Name -> Mult -> Type -> Id
-mkLocalId name _ _ | Just thing <- wiredInNameTyThing_maybe name = tyThingId thing
mkLocalId name w ty = mkLocalIdWithInfo name w (assert (not (isCoVarType ty)) ty) vanillaIdInfo
-- | Make a local CoVar
@@ -585,11 +583,13 @@ 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 _ lev_poly -> lev_poly
-
- FCallId _ -> True
- DataConWorkId dc -> isUnboxedTupleDataCon dc || isUnboxedSumDataCon dc
- _ -> isCompulsoryUnfolding (realIdUnfolding id)
+ PrimOpId _ _conc_tvs -> True -- not $ isEmptyNameEnv conc_tvs
+ RepPolyId _conc_tvs -> True
+-- RepPolyId conc_tvs -> not $ isEmptyNameEnv conc_tvs
+-- SLD TODO: not enough, e.g. some lev-poly stuff with no conc tvs have no binding
+ FCallId _ -> True
+ DataConWorkId dc -> isUnboxedTupleDataCon dc || isUnboxedSumDataCon dc
+ _ -> isCompulsoryUnfolding (realIdUnfolding id)
-- Note: this function must be very careful not to force
-- any of the fields that aren't the 'uf_src' field of
-- the 'Unfolding' of the 'Id'. This is because these fields are computed
=====================================
compiler/GHC/Types/Id/Make.hs
=====================================
@@ -27,7 +27,7 @@ module GHC.Types.Id.Make (
unboxedUnitExpr,
-- And some particular Ids; see below for why they are wired in
- wiredInIds, ghcPrimIds,
+ wiredInIds, ghcPrimIds, magicIds,
realWorldPrimId,
voidPrimId, voidArgId,
nullAddrId, seqId, lazyId, lazyIdKey,
@@ -35,6 +35,7 @@ module GHC.Types.Id.Make (
proxyHashId,
nospecId, nospecIdName,
noinlineId, noinlineIdName,
+ oneShotId, oneShotName,
noinlineConstraintId, noinlineConstraintIdName,
coerceName, leftSectionName, rightSectionName,
pcRepPolyId,
=====================================
libraries/base/Control/Exception/Base.hs
=====================================
@@ -426,7 +426,20 @@ typeError s = throw (TypeError (unpackCStringUtf8# s))
impossibleError, impossibleConstraintError :: Addr# -> a
-- These two are used for impossible case alternatives, and lack location info
impossibleError s = errorWithoutStackTrace (unpackCStringUtf8# s)
-impossibleConstraintError s = errorWithoutStackTrace (unpackCStringUtf8# s)
+--impossibleConstraintError s = errorWithoutStackTrace (unpackCStringUtf8# s)
+impossibleConstraintError = impossibleConstraintError -- SLD TODO
+ -- impossibleConstraintError s = errorWithoutStackTrace (unpackCStringUtf8# s)
+{-
+libraries\base\Control\Exception\Base.hs:429:33: error: [GHC-18872]
+ • Couldn't match kind ‘*’ with ‘CONSTRAINT q’
+ When matching types
+ a0 :: *
+ a :: CONSTRAINT q
+ • In the expression: errorWithoutStackTrace (unpackCStringUtf8# s)
+ In an equation for ‘impossibleConstraintError’:
+ impossibleConstraintError s
+ = errorWithoutStackTrace (unpackCStringUtf8# s)
+-}
-- GHC's RTS calls this
=====================================
libraries/ghc-prim/GHC/Prim/Panic.hs
=====================================
@@ -116,4 +116,18 @@ absentConstraintError :: forall (a :: Type). Addr# -> a
-- type; the type in the interface file is never looked at.
-- The only purpose of this definition is to give a function to call,
-- and for that purpose, delegating to absentError is fine.
-absentConstraintError errmsg = absentError errmsg
+absentConstraintError = absentConstraintError -- SLD TODO: errmsg = absentError errmsg
+{-
+libraries\ghc-prim\GHC\Prim\Panic.hs:119:32: error: [GHC-18872]
+ • Couldn't match kind ‘*’ with ‘Constraint’
+ When matching types
+ a0 :: *
+ a :: Constraint
+ • In the expression: absentError errmsg
+ In an equation for ‘absentConstraintError’:
+ absentConstraintError errmsg = absentError errmsg
+ • Relevant bindings include
+ absentConstraintError :: Addr# -=> a
+ (bound at libraries\ghc-prim\GHC\Prim\Panic.hs:119:1)
+
+-}
=====================================
utils/genprimopcode/Main.hs
=====================================
@@ -339,7 +339,7 @@ gen_hs_source (Info defaults entries) =
prim_func :: String -> Ty -> Bool -> [String]
prim_func n t llvm_only
- | not (opTyHasFixedRuntimeRep t) =
+ | tyHasNegativePosRepPoly t =
[ "-- No wrapper due to RuntimeRep polymorphism:"
, "-- " ++ wrapOp n ++ " :: " ++ pprTy t
]
@@ -694,28 +694,30 @@ splitFunTy = go []
go acc (TyC arg res) = go (arg:acc) res
go acc ty = (reverse acc, ty)
--- | This should match the levity polymorphism check in
--- GHC.Builtin.PrimOps.Ids.mkPrimOpId.
-opTyHasFixedRuntimeRep :: Ty -> Bool
-opTyHasFixedRuntimeRep ty =
- let (args, res) = splitFunTy ty
- in all typeHasFixedRuntimeRep args && typeHasFixedRuntimeRep res
-
--- | Is a type representationally monomorphic?
-typeHasFixedRuntimeRep :: Ty -> Bool
-typeHasFixedRuntimeRep (TyF a b) = True
-typeHasFixedRuntimeRep (TyC a b) = True
-typeHasFixedRuntimeRep (TyApp _ as) = True
-typeHasFixedRuntimeRep (TyVar v) = tyVarHasFixedRuntimeRep v
-typeHasFixedRuntimeRep (TyUTup as) = all typeHasFixedRuntimeRep as
-
--- | Does a tyvar have a representationally polymorphic kind?
-tyVarHasFixedRuntimeRep :: TyVar -> Bool
-tyVarHasFixedRuntimeRep "o" = False
-tyVarHasFixedRuntimeRep "p" = False
-tyVarHasFixedRuntimeRep "v" = False
-tyVarHasFixedRuntimeRep "w" = False
-tyVarHasFixedRuntimeRep _ = True
+-- | Does the type have representation-polymorphic type variables
+-- in negative position?
+--
+-- Should match the logic in 'GHC.Builtin.PrimOps.Ids.computePrimOpConcTyVarsFromType',
+-- i.e. this function should return 'True' precisely when 'computePrimOpConcTyVarsFromType'
+-- returns a non-empty collection of concrete type variables.
+tyHasNegativePosRepPoly :: Ty -> Bool
+tyHasNegativePosRepPoly = rep_poly False
+ where
+ rep_poly :: Bool -- True <=> looking for rep-poly in positive position
+ -- False <=> '' ... '' negative position
+ -> Ty
+ -> Bool
+ rep_poly want_pos ty
+ | (args@(_:_), res) <- splitFunTy ty
+ = any (rep_poly $ not want_pos) args || rep_poly want_pos res
+ rep_poly want_pos (TyUTup as)
+ = any (rep_poly want_pos) as
+ rep_poly True (TyVar v)
+ = v `elem` [ "a_reppoly", "b_reppoly", "a_levpoly", "b_levpoly" ]
+ rep_poly _ _
+ = False
+ -- There are no TyCons in GHC.Prim with representation-polymorphic kinds,
+ -- other than unboxed tuples (which use TyUTup instead of TyApp).
ppTyVar :: TyVar -> PrimOpTyVarBinder
ppTyVar "a" = nonDepTyVarBinder "alphaTyVarSpec"
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f807c83edf5de19015bd7fb58e0f26ba16ca5e7a
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f807c83edf5de19015bd7fb58e0f26ba16ca5e7a
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230726/60cabfba/attachment-0001.html>
More information about the ghc-commits
mailing list