[Git][ghc/ghc][wip/T20155] WIP stuff

sheaf (@sheaf) gitlab at gitlab.haskell.org
Wed Jul 26 11:04:40 UTC 2023



sheaf pushed to branch wip/T20155 at Glasgow Haskell Compiler / GHC


Commits:
3d98d3f9 by sheaf at 2023-07-26T13:04:30+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) =
+      | True = --not (opTyHasFixedRuntimeRep t) =
           [ "-- No wrapper due to RuntimeRep polymorphism:"
           , "-- " ++ wrapOp n ++ " :: " ++ pprTy t
           ]



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3d98d3f9faf124cd87d1a7d972cd7069f8e4459e

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3d98d3f9faf124cd87d1a7d972cd7069f8e4459e
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/5e42155d/attachment-0001.html>


More information about the ghc-commits mailing list