09 May '25
Cheng Shao pushed new branch wip/wasm-minor-improvements at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/wasm-minor-improvements
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/fendor/ghci-multiple-home-units] 2 commits: Make GHCi commands compatible with multiple home units
by Hannes Siebenhandl (＠fendor) 09 May '25
by Hannes Siebenhandl (＠fendor) 09 May '25
09 May '25
Hannes Siebenhandl pushed to branch wip/fendor/ghci-multiple-home-units at Glasgow Haskell Compiler / GHC
Commits:
8e4120d5 by fendor at 2025-05-09T17:24:50+02:00
Make GHCi commands compatible with multiple home units
=== Design
We enable all GHCi features that were previously guarded by the `inMulti`
option.
GHCi supported multiple home units up to a certain degree for quite a while now.
The supported feature set was limited, due to a design impasse:
One of the home units must be "active", e.g., there must be one `HomeUnit`
whose `UnitId` is "active" which is returned when calling
```haskell
do
hscActiveUnitId <$> getSession
```
This makes sense in a GHC session, since you are always compiling a particular
Module, but it makes less intuitive sense in an interactive session.
Given an expression to evaluate, we can`t easily tell in which "context" the expression
should be parsed, typechecked and evaluated.
That`s why initially, most of GHCi features, except for `:reload`ing were disabled
if the GHCi session had more than one `HomeUnitEnv`.
We lift this restriction, enabling all features of GHCi for the multiple home unit case.
To do this, we fundamentally change the `HomeUnitEnv` graph to be multiple home unit first.
Instead of differentiating the case were we have a single home unit and multiple,
we now always set up a multiple home unit session that scales seamlessly to an arbitrary
amount of home units.
We introduce two new `HomeUnitEnv`s that are always added to the `HomeUnitGraph`.
They are:
The "interactive-ghci", called the `interactiveGhciUnit`, contains the same
`DynFlags` that are used by the `InteractiveContext` for interactive evaluation
of expressions.
This `HomeUnitEnv` is only used on the prompt of GHCi, so we may refer to it as
"interactive-prompt" unit.
See Note [Relation between the `InteractiveContext` and `interactiveGhciUnitId`]
for discussing its role.
And the `interactive-session`, called `interactiveSessionUnit` or
`interactiveSessionUnitId`, which is used for loading Scripts into
GHCi that are not `Target`s of any home unit, via `:load` or `:add`.
Both of these "interactive" home units depend on all other `HomeUnitEnv`s that
are passed as arguments on the cli.
Additionally, the "interactive-ghci" unit depends on `interactive-session`.
We always evaluate expressions in the context of the
"interactive-ghci" session.
Since "interactive-ghci" depends on all home units, we can import any `Module`
from the other home units with ease.
As we have a clear `HomeUnitGraph` hierarchy, we can set `interactiveGhciUnitId`
as the active home unit for the full duration of the GHCi session.
In GHCi, we always set `interactiveGhciUnitId` to be the currently active home unit.
=== Implementation Details
Given this design idea, the implementation is relatively straight
forward.
The core insight is that a `ModuleName` is not sufficient to identify a
`Module` in the `HomeUnitGraph`. Thus, large parts of the PR is simply
about refactoring usages of `ModuleName` to prefer `Module`, which has a
`Unit` attached and is unique over the `HomeUnitGraph`.
Consequentially, most usages of `lookupHPT` are likely to be incorrect and have
been replaced by `lookupHugByModule` which is keyed by a `Module`.
In GHCi/UI.hs, we make sure there is only one location where we are
actually translating `ModuleName` to a `Module`:
* `lookupQualifiedModuleName`
If a `ModuleName` is ambiguous, we detect this and report it to the
user.
To avoid repeated lookups of `ModuleName`s, we store the `Module` in the
`InteractiveImport`, which additionally simplifies the interface
loading.
A subtle detail is that the `DynFlags` of the `InteractiveContext` are
now stored both in the `HomeUnitGraph` and in the `InteractiveContext`.
In UI.hs, there are multiple code paths where we are careful to update
the `DynFlags` in both locations.
Most importantly in `addToProgramDynFlags`.
---
There is one metric increase in this commit:
-------------------------
Metric Increase:
T4029
-------------------------
It is an increase from 14.4 MB to 16.1 MB (+11.8%) which sounds like a
pretty big regression at first.
However, we argue this increase is solely caused by using more data
structures for managing multiple home units in the GHCi session.
In particular, due to the design decision of using three home units, the
base memory usage increases... but by how much?
A big contributor is the `UnitState`, of which we have three now, which
on its own 260 KB per instance. That makes an additional memory usage of
520 KB, already explaining a third of the overall memory usage increase.
Then we store more elements in the `HomeUnitGraph`, we have more
`HomeUnitEnv` entries, etc...
While we didn't chase down each byte, we looked at the memory usage over time
for both `-hi` and `-hT` profiles and can say with confidence while the memory
usage increased slightly, we did not introduce any space leak, as
the graph looks almost identical as the memory usage graph of GHC HEAD.
- - - - -
798408f3 by fendor at 2025-05-09T17:24:50+02:00
FIXUP: Multiple Home Units is no longer a special case
- - - - -
20 changed files:
- compiler/GHC.hs
- compiler/GHC/Driver/Downsweep.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Rename/Unbound.hs
- compiler/GHC/Runtime/Context.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/StgToByteCode.hs
- compiler/GHC/StgToJS/Linker/Linker.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Types/Name/Ppr.hs
- compiler/GHC/Unit/Env.hs
- compiler/GHC/Unit/Home/Graph.hs
- compiler/GHC/Unit/Types.hs
- ghc/GHCi/UI.hs
- ghc/GHCi/UI/Exception.hs
- ghc/GHCi/UI/Info.hs
- ghc/GHCi/UI/Monad.hs
- ghc/Main.hs
- testsuite/tests/linters/notes.stdout
Changes:
=====================================
compiler/GHC.hs
=====================================
@@ -38,7 +38,9 @@ module GHC (
setSessionDynFlags,
setUnitDynFlags,
getProgramDynFlags, setProgramDynFlags,
+ setProgramHUG, setProgramHUG_,
getInteractiveDynFlags, setInteractiveDynFlags,
+ normaliseInteractiveDynFlags, initialiseInteractiveDynFlags,
interpretPackageEnv,
-- * Logging
@@ -55,6 +57,7 @@ module GHC (
addTarget,
removeTarget,
guessTarget,
+ guessTargetId,
-- * Loading\/compiling the program
depanal, depanalE,
@@ -83,6 +86,7 @@ module GHC (
getModuleGraph,
isLoaded,
isLoadedModule,
+ isLoadedHomeModule,
topSortModuleGraph,
-- * Inspecting modules
@@ -155,6 +159,7 @@ module GHC (
getBindings, getInsts, getNamePprCtx,
findModule, lookupModule,
findQualifiedModule, lookupQualifiedModule,
+ lookupLoadedHomeModuleByModuleName, lookupAllQualifiedModuleNames,
renamePkgQualM, renameRawPkgQualM,
isModuleTrusted, moduleTrustReqs,
getNamesInScope,
@@ -443,6 +448,7 @@ import Control.Concurrent
import Control.Monad
import Control.Monad.Catch as MC
import Data.Foldable
+import Data.Function ((&))
import Data.IORef
import Data.List (isPrefixOf)
import Data.Typeable ( Typeable )
@@ -458,7 +464,7 @@ import System.Environment ( getEnv, getProgName )
import System.Exit ( exitWith, ExitCode(..) )
import System.FilePath
import System.IO.Error ( isDoesNotExistError )
-import GHC.Unit.Home.PackageTable
+
-- %************************************************************************
-- %* *
@@ -861,6 +867,113 @@ setProgramDynFlags_ invalidate_needed dflags = do
when invalidate_needed $ invalidateModSummaryCache
return changed
+-- | Sets the program 'HomeUnitGraph'.
+--
+-- Sets the given 'HomeUnitGraph' as the 'HomeUnitGraph' of the current
+-- session. If the package flags change, we reinitialise the 'UnitState'
+-- of all 'HomeUnitEnv's in the current session.
+--
+-- This function unconditionally invalidates the module graph cache.
+--
+-- Precondition: the given 'HomeUnitGraph' must have the same keys as the 'HomeUnitGraph'
+-- of the current session. I.e., assuming the new 'HomeUnitGraph' is called
+-- 'new_hug', then:
+--
+-- @
+-- do
+-- hug <- hsc_HUG \<$\> getSession
+-- pure $ unitEnv_keys new_hug == unitEnv_keys hug
+-- @
+--
+-- If this precondition is violated, the function will crash.
+--
+-- Conceptually, similar to 'setProgramDynFlags', but performs the same check
+-- for all 'HomeUnitEnv's.
+setProgramHUG :: GhcMonad m => HomeUnitGraph -> m Bool
+setProgramHUG =
+ setProgramHUG_ True
+
+-- | Same as 'setProgramHUG', but gives you control over whether you want to
+-- invalidate the module graph cache.
+setProgramHUG_ :: GhcMonad m => Bool -> HomeUnitGraph -> m Bool
+setProgramHUG_ invalidate_needed new_hug0 = do
+ logger <- getLogger
+
+ hug0 <- hsc_HUG <$> getSession
+ (changed, new_hug1) <- checkNewHugDynFlags logger hug0 new_hug0
+
+ if changed
+ then do
+ unit_env0 <- hsc_unit_env <$> getSession
+ home_unit_graph <- HUG.unitEnv_traverseWithKey
+ (updateHomeUnit logger unit_env0 new_hug1)
+ (ue_home_unit_graph unit_env0)
+
+ let dflags1 = homeUnitEnv_dflags $ HUG.unitEnv_lookup (ue_currentUnit unit_env0) home_unit_graph
+ let unit_env = UnitEnv
+ { ue_platform = targetPlatform dflags1
+ , ue_namever = ghcNameVersion dflags1
+ , ue_home_unit_graph = home_unit_graph
+ , ue_current_unit = ue_currentUnit unit_env0
+ , ue_eps = ue_eps unit_env0
+ }
+ modifySession $ \h ->
+ -- hscSetFlags takes care of updating the logger as well.
+ hscSetFlags dflags1 h{ hsc_unit_env = unit_env }
+ else do
+ modifySession (\env ->
+ env
+ -- Set the new 'HomeUnitGraph'.
+ & hscUpdateHUG (const new_hug1)
+ -- hscSetActiveUnitId makes sure that the 'hsc_dflags'
+ -- are up-to-date.
+ & hscSetActiveUnitId (hscActiveUnitId env)
+ -- Make sure the logger is also updated.
+ & hscUpdateLoggerFlags)
+
+ when invalidate_needed $ invalidateModSummaryCache
+ pure changed
+ where
+ checkNewHugDynFlags :: GhcMonad m => Logger -> HomeUnitGraph -> HomeUnitGraph -> m (Bool, HomeUnitGraph)
+ checkNewHugDynFlags logger old_hug new_hug = do
+ -- Traverse the new HUG and check its 'DynFlags'.
+ -- The old 'HUG' is used to check whether package flags have changed.
+ hugWithCheck <- HUG.unitEnv_traverseWithKey
+ (\unitId homeUnit -> do
+ let newFlags = homeUnitEnv_dflags homeUnit
+ oldFlags = homeUnitEnv_dflags (HUG.unitEnv_lookup unitId old_hug)
+ checkedFlags <- checkNewDynFlags logger newFlags
+ pure
+ ( packageFlagsChanged oldFlags checkedFlags
+ , homeUnit { homeUnitEnv_dflags = checkedFlags }
+ )
+ )
+ new_hug
+ let
+ -- Did any of the package flags change?
+ changed = or $ fmap fst hugWithCheck
+ hug = fmap snd hugWithCheck
+ pure (changed, hug)
+
+ updateHomeUnit :: GhcMonad m => Logger -> UnitEnv -> HomeUnitGraph -> (UnitId -> HomeUnitEnv -> m HomeUnitEnv)
+ updateHomeUnit logger unit_env updates = \uid homeUnitEnv -> do
+ let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv
+ dflags = case HUG.unitEnv_lookup_maybe uid updates of
+ Nothing -> homeUnitEnv_dflags homeUnitEnv
+ Just env -> homeUnitEnv_dflags env
+ old_hpt = homeUnitEnv_hpt homeUnitEnv
+ home_units = HUG.allUnits (ue_home_unit_graph unit_env)
+
+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags cached_unit_dbs home_units
+
+ updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants
+ pure HomeUnitEnv
+ { homeUnitEnv_units = unit_state
+ , homeUnitEnv_unit_dbs = Just dbs
+ , homeUnitEnv_dflags = updated_dflags
+ , homeUnitEnv_hpt = old_hpt
+ , homeUnitEnv_home_unit = Just home_unit
+ }
-- When changing the DynFlags, we want the changes to apply to future
-- loads, but without completely discarding the program. But the
@@ -900,24 +1013,8 @@ getProgramDynFlags = getSessionDynFlags
setInteractiveDynFlags :: GhcMonad m => DynFlags -> m ()
setInteractiveDynFlags dflags = do
logger <- getLogger
- dflags' <- checkNewDynFlags logger dflags
- dflags'' <- checkNewInteractiveDynFlags logger dflags'
- modifySessionM $ \hsc_env0 -> do
- let ic0 = hsc_IC hsc_env0
-
- -- Initialise (load) plugins in the interactive environment with the new
- -- DynFlags
- plugin_env <- liftIO $ initializePlugins $ mkInteractiveHscEnv $
- hsc_env0 { hsc_IC = ic0 { ic_dflags = dflags'' }}
-
- -- Update both plugins cache and DynFlags in the interactive context.
- return $ hsc_env0
- { hsc_IC = ic0
- { ic_plugins = hsc_plugins plugin_env
- , ic_dflags = hsc_dflags plugin_env
- }
- }
-
+ icdflags <- normaliseInteractiveDynFlags logger dflags
+ modifySessionM (initialiseInteractiveDynFlags icdflags)
-- | Get the 'DynFlags' used to evaluate interactive expressions.
getInteractiveDynFlags :: GhcMonad m => m DynFlags
@@ -1022,6 +1119,36 @@ normalise_hyp fp
-----------------------------------------------------------------------------
+-- | Normalise the 'DynFlags' for us in an interactive context.
+--
+-- Makes sure unsupported Flags and other incosistencies are reported and removed.
+normaliseInteractiveDynFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags
+normaliseInteractiveDynFlags logger dflags = do
+ dflags' <- checkNewDynFlags logger dflags
+ checkNewInteractiveDynFlags logger dflags'
+
+-- | Given a set of normalised 'DynFlags' (see 'normaliseInteractiveDynFlags')
+-- for the interactive context, initialize the 'InteractiveContext'.
+--
+-- Initialized plugins and sets the 'DynFlags' as the 'ic_dflags' of the
+-- 'InteractiveContext'.
+initialiseInteractiveDynFlags :: GhcMonad m => DynFlags -> HscEnv -> m HscEnv
+initialiseInteractiveDynFlags dflags hsc_env0 = do
+ let ic0 = hsc_IC hsc_env0
+
+ -- Initialise (load) plugins in the interactive environment with the new
+ -- DynFlags
+ plugin_env <- liftIO $ initializePlugins $ mkInteractiveHscEnv $
+ hsc_env0 { hsc_IC = ic0 { ic_dflags = dflags }}
+
+ -- Update both plugins cache and DynFlags in the interactive context.
+ return $ hsc_env0
+ { hsc_IC = ic0
+ { ic_plugins = hsc_plugins plugin_env
+ , ic_dflags = hsc_dflags plugin_env
+ }
+ }
+
-- | Checks the set of new DynFlags for possibly erroneous option
-- combinations when invoking 'setSessionDynFlags' and friends, and if
-- found, returns a fixed copy (if possible).
@@ -1084,7 +1211,7 @@ removeTarget target_id
where
filter targets = [ t | t@Target { targetId = id } <- targets, id /= target_id ]
--- | Attempts to guess what Target a string refers to. This function
+-- | Attempts to guess what 'Target' a string refers to. This function
-- implements the @--make@/GHCi command-line syntax for filenames:
--
-- - if the string looks like a Haskell source filename, then interpret it
@@ -1093,27 +1220,52 @@ removeTarget target_id
-- - if adding a .hs or .lhs suffix yields the name of an existing file,
-- then use that
--
--- - otherwise interpret the string as a module name
+-- - If it looks like a module name, interpret it as such
--
+-- - otherwise, this function throws a 'GhcException'.
guessTarget :: GhcMonad m => String -> Maybe UnitId -> Maybe Phase -> m Target
guessTarget str mUnitId (Just phase)
= do
tuid <- unitIdOrHomeUnit mUnitId
return (Target (TargetFile str (Just phase)) True tuid Nothing)
-guessTarget str mUnitId Nothing
+guessTarget str mUnitId Nothing = do
+ targetId <- guessTargetId str
+ toTarget targetId
+ where
+ obj_allowed
+ | '*':_ <- str = False
+ | otherwise = True
+ toTarget tid = do
+ tuid <- unitIdOrHomeUnit mUnitId
+ pure $ Target tid obj_allowed tuid Nothing
+
+-- | Attempts to guess what 'TargetId' a string refers to. This function
+-- implements the @--make@/GHCi command-line syntax for filenames:
+--
+-- - if the string looks like a Haskell source filename, then interpret it
+-- as such
+--
+-- - if adding a .hs or .lhs suffix yields the name of an existing file,
+-- then use that
+--
+-- - If it looks like a module name, interpret it as such
+--
+-- - otherwise, this function throws a 'GhcException'.
+guessTargetId :: GhcMonad m => String -> m TargetId
+guessTargetId str
| isHaskellSrcFilename file
- = target (TargetFile file Nothing)
+ = pure (TargetFile file Nothing)
| otherwise
= do exists <- liftIO $ doesFileExist hs_file
if exists
- then target (TargetFile hs_file Nothing)
+ then pure (TargetFile hs_file Nothing)
else do
exists <- liftIO $ doesFileExist lhs_file
if exists
- then target (TargetFile lhs_file Nothing)
+ then pure (TargetFile lhs_file Nothing)
else do
if looksLikeModuleName file
- then target (TargetModule (mkModuleName file))
+ then pure (TargetModule (mkModuleName file))
else do
dflags <- getDynFlags
liftIO $ throwGhcExceptionIO
@@ -1121,16 +1273,12 @@ guessTarget str mUnitId Nothing
text "target" <+> quotes (text file) <+>
text "is not a module name or a source file"))
where
- (file,obj_allowed)
- | '*':rest <- str = (rest, False)
- | otherwise = (str, True)
+ file
+ | '*':rest <- str = rest
+ | otherwise = str
- hs_file = file <.> "hs"
- lhs_file = file <.> "lhs"
-
- target tid = do
- tuid <- unitIdOrHomeUnit mUnitId
- pure $ Target tid obj_allowed tuid Nothing
+ hs_file = file <.> "hs"
+ lhs_file = file <.> "lhs"
-- | Unwrap 'UnitId' or retrieve the 'UnitId'
-- of the current 'HomeUnit'.
@@ -1251,11 +1399,11 @@ type TypecheckedSource = LHsBinds GhcTc
--
-- This function ignores boot modules and requires that there is only one
-- non-boot module with the given name.
-getModSummary :: GhcMonad m => ModuleName -> m ModSummary
+getModSummary :: GhcMonad m => Module -> m ModSummary
getModSummary mod = do
mg <- liftM hsc_mod_graph getSession
let mods_by_name = [ ms | ms <- mgModSummaries mg
- , ms_mod_name ms == mod
+ , ms_mod ms == mod
, isBootSummary ms == NotBoot ]
case mods_by_name of
[] -> do dflags <- getDynFlags
@@ -1286,7 +1434,9 @@ typecheckModule pmod = do
liftIO $ do
let ms = modSummary pmod
let lcl_dflags = ms_hspp_opts ms -- take into account pragmas (OPTIONS_GHC, etc.)
- let lcl_hsc_env = hscSetFlags lcl_dflags hsc_env
+ let lcl_hsc_env =
+ hscSetFlags lcl_dflags $
+ hscSetActiveUnitId (toUnitId $ moduleUnit $ ms_mod ms) hsc_env
let lcl_logger = hsc_logger lcl_hsc_env
(tc_gbl_env, rn_info) <- hscTypecheckRename lcl_hsc_env ms $
HsParsedModule { hpm_module = parsedSource pmod,
@@ -1431,14 +1581,24 @@ getModuleGraph = liftM hsc_mod_graph getSession
-- | Return @True@ \<==> module is loaded.
isLoaded :: GhcMonad m => ModuleName -> m Bool
isLoaded m = withSession $ \hsc_env -> liftIO $ do
- hmi <- lookupHpt (hsc_HPT hsc_env) m
- return $! isJust hmi
+ hmis <- HUG.lookupAllHug (hsc_HUG hsc_env) m
+ return $! not (null hmis)
+-- | Check whether a 'ModuleName' is found in the 'HomePackageTable'
+-- for the given 'UnitId'.
isLoadedModule :: GhcMonad m => UnitId -> ModuleName -> m Bool
isLoadedModule uid m = withSession $ \hsc_env -> liftIO $ do
hmi <- HUG.lookupHug (hsc_HUG hsc_env) uid m
return $! isJust hmi
+-- | Check whether 'Module' is part of the 'HomeUnitGraph'.
+--
+-- Similar to 'isLoadedModule', but for 'Module's.
+isLoadedHomeModule :: GhcMonad m => Module -> m Bool
+isLoadedHomeModule m = withSession $ \hsc_env -> liftIO $ do
+ hmi <- HUG.lookupHugByModule m (hsc_HUG hsc_env)
+ return $! isJust hmi
+
-- | Return the bindings for the current interactive session.
getBindings :: GhcMonad m => m [TyThing]
getBindings = withSession $ \hsc_env ->
@@ -1470,7 +1630,7 @@ data ModuleInfo = ModuleInfo {
-- | Request information about a loaded 'Module'
getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo) -- XXX: Maybe X
getModuleInfo mdl = withSession $ \hsc_env -> do
- if moduleUnitId mdl `S.member` hsc_all_home_unit_ids hsc_env
+ if HUG.memberHugUnit (moduleUnit mdl) (hsc_HUG hsc_env)
then liftIO $ getHomeModuleInfo hsc_env mdl
else liftIO $ getPackageModuleInfo hsc_env mdl
@@ -1826,6 +1986,50 @@ lookupLoadedHomeModule uid mod_name = withSession $ \hsc_env -> liftIO $ do
Just mod_info -> return (Just (mi_module (hm_iface mod_info)))
_not_a_home_module -> return Nothing
+-- | Lookup the given 'ModuleName' in the 'HomeUnitGraph'.
+--
+-- Returns 'Nothing' if no 'Module' has the given 'ModuleName'.
+-- Otherwise, returns all 'Module's that have the given 'ModuleName'.
+--
+-- A 'ModuleName' is generally not enough to uniquely identify a 'Module', since
+-- there can be multiple units exposing the same 'ModuleName' in the case of
+-- multiple home units.
+-- Thus, this function may return more than one possible 'Module'.
+-- We leave it up to the caller to decide how to handle the ambiguity.
+-- For example, GHCi may prompt the user to clarify which 'Module' is the correct one.
+--
+lookupLoadedHomeModuleByModuleName :: GhcMonad m => ModuleName -> m (Maybe [Module])
+lookupLoadedHomeModuleByModuleName mod_name = withSession $ \hsc_env -> liftIO $ do
+ trace_if (hsc_logger hsc_env) (text "lookupLoadedHomeModuleByModuleName" <+> ppr mod_name)
+ HUG.lookupAllHug (hsc_HUG hsc_env) mod_name >>= \case
+ [] -> return Nothing
+ mod_infos -> return (Just (mi_module . hm_iface <$> mod_infos))
+
+-- | Given a 'ModuleName' and 'PkgQual', lookup all 'Module's that may fit the criteria.
+--
+-- Identically to 'lookupLoadedHomeModuleByModuleName', there may be more than one
+-- 'Module' in the 'HomeUnitGraph' that has the given 'ModuleName'.
+--
+-- The result is guaranteed to be non-empty, if no 'Module' can be found,
+-- this function throws an error.
+lookupAllQualifiedModuleNames :: GhcMonad m => PkgQual -> ModuleName -> m [Module]
+lookupAllQualifiedModuleNames NoPkgQual mod_name = withSession $ \hsc_env -> do
+ home <- lookupLoadedHomeModuleByModuleName mod_name
+ case home of
+ Just m -> return m
+ Nothing -> liftIO $ do
+ let fc = hsc_FC hsc_env
+ let units = hsc_units hsc_env
+ let dflags = hsc_dflags hsc_env
+ let fopts = initFinderOpts dflags
+ res <- findExposedPackageModule fc fopts units mod_name NoPkgQual
+ case res of
+ Found _ m -> return [m]
+ err -> throwOneError $ noModError hsc_env noSrcSpan mod_name err
+lookupAllQualifiedModuleNames pkgqual mod_name = do
+ m <- findQualifiedModule pkgqual mod_name
+ pure [m]
+
-- | Check that a module is safe to import (according to Safe Haskell).
--
-- We return True to indicate the import is safe and False otherwise
=====================================
compiler/GHC/Driver/Downsweep.hs
=====================================
@@ -281,7 +281,7 @@ downsweepInteractiveImports hsc_env ic = unsafeInterleaveIO $ do
-- A simple edge to a module from the same home unit
mkEdge (IIModule n) =
let unitId = homeUnitId $ hsc_home_unit hsc_env
- in (unitId, NormalLevel, NoPkgQual, GWIB (noLoc n) NotBoot)
+ in (unitId, NormalLevel, NoPkgQual, GWIB (noLoc $ moduleName n) NotBoot)
-- A complete import statement
mkEdge (IIDecl i) =
let lvl = convImportLevel (ideclLevelSpec i)
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -162,6 +162,7 @@ module GHC.Driver.Session (
updOptLevel,
setTmpDir,
setUnitId,
+ setHomeUnitId,
TurnOnFlag,
turnOn,
@@ -3114,6 +3115,9 @@ parseUnitArg =
setUnitId :: String -> DynFlags -> DynFlags
setUnitId p d = d { homeUnitId_ = stringToUnitId p }
+setHomeUnitId :: UnitId -> DynFlags -> DynFlags
+setHomeUnitId p d = d { homeUnitId_ = p }
+
setWorkingDirectory :: String -> DynFlags -> DynFlags
setWorkingDirectory p d = d { workingDirectory = Just p }
=====================================
compiler/GHC/Iface/Load.hs
=====================================
@@ -918,12 +918,10 @@ findAndReadIface hsc_env doc_str mod wanted_mod hi_boot_file = do
case mb_found of
InstalledFound loc -> do
-- See Note [Home module load error]
- case mhome_unit of
- Just home_unit
- | isHomeInstalledModule home_unit mod
- , not (isOneShot (ghcMode dflags))
- -> return (Failed (HomeModError mod loc))
- _ -> do
+ if HUG.memberHugUnitId (moduleUnit mod) (hsc_HUG hsc_env)
+ && not (isOneShot (ghcMode dflags))
+ then return (Failed (HomeModError mod loc))
+ else do
r <- read_file logger name_cache unit_state dflags wanted_mod (ml_hi_file loc)
case r of
Failed err
=====================================
compiler/GHC/Rename/Unbound.hs
=====================================
@@ -364,7 +364,7 @@ importSuggestions looking_for ic currMod imports rdr_name
pick_interactive :: InteractiveImport -> Bool
pick_interactive (IIDecl d) | mod_name == Just (unLoc (ideclName d)) = True
| mod_name == fmap unLoc (ideclAs d) = True
- pick_interactive (IIModule m) | mod_name == Just m = True
+ pick_interactive (IIModule m) | mod_name == Just (moduleName m) = True
pick_interactive _ = False
-- We want to keep only one for each original module; preferably one with an
=====================================
compiler/GHC/Runtime/Context.hs
=====================================
@@ -115,6 +115,51 @@ The details are a bit tricky though:
modules.
+Note [Relation between the 'InteractiveContext' and 'interactiveGhciUnitId']
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The 'InteractiveContext' is used to store 'DynFlags', 'Plugins' and similar
+information about the so-called interactive "home unit". We are using
+quotes here, since, originally, GHC wasn't aware of more than one 'HomeUnitEnv's.
+So the 'InteractiveContext' was a hack/solution to have 'DynFlags' and 'Plugins'
+independent of the 'DynFlags' and 'Plugins' stored in 'HscEnv'.
+Nowadays, GHC has support for multiple home units via the 'HomeUnitGraph', thus,
+this part of the 'InteractiveContext' is strictly speaking redundant, as we
+can simply manage one 'HomeUnitEnv' for the 'DynFlags' and 'Plugins' that are
+currently stored in the 'InteractiveContext'.
+
+As a matter of fact, that's exactly what we do nowadays.
+That means, we can also lift other restrictions in the future, for example
+allowing @:seti@ commands to modify the package-flags, since we now have a
+separate 'UnitState' for the interactive session.
+However, we did not rip out 'ic_dflags' and 'ic_plugins', yet, as it makes
+it easier to access them for functions that want to use the interactive 'DynFlags',
+such as 'runInteractiveHsc' and 'mkInteractiveHscEnv', without having to look that
+information up in the 'HomeUnitGraph'.
+It is reasonable to change this in the future, and remove 'ic_dflags' and 'ic_plugins'.
+
+We keep 'ic_dflags' and 'ic_plugins' around, but we also store a 'HomeUnitEnv'
+for the 'DynFlags' and 'Plugins' of the interactive session.
+
+It is important to keep the 'DynFlags' in these two places consistent.
+
+In other words, whenever you update the 'DynFlags' of the 'interactiveGhciUnitId'
+in the 'HscEnv', then you also need to update the 'DynFlags' of the
+'InteractiveContext'.
+The easiest way to update them is via 'setInteractiveDynFlags'.
+However, careful, footgun! It is very easy to call 'setInteractiveDynFlags'
+and forget to call 'normaliseInteractiveDynFlags' on the 'DynFlags' in the
+'HscEnv'! This is important, because you may, accidentally, have enabled
+Language Extensions that are not supported in the interactive ghc session,
+which we do not want.
+
+To summarise, the 'ic_dflags' and 'ic_plugins' are currently used to
+conveniently cache them for easy access.
+The 'ic_dflags' must be identical to the 'DynFlags' stored in the 'HscEnv'
+for the 'HomeUnitEnv' identified by 'interactiveGhciUnitId'.
+
+See Note [Multiple Home Units aware GHCi] for the design and rationale for
+the current 'interactiveGhciUnitId'.
+
Note [Interactively-bound Ids in GHCi]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The Ids bound by previous Stmts in GHCi are currently
@@ -296,7 +341,7 @@ data InteractiveImport
-- ^ Bring the exports of a particular module
-- (filtered by an import decl) into scope
- | IIModule ModuleName
+ | IIModule Module
-- ^ Bring into scope the entire top-level envt of
-- of this module, including the things imported
-- into it.
=====================================
compiler/GHC/Runtime/Eval.hs
=====================================
@@ -119,7 +119,6 @@ import GHC.Unit
import GHC.Unit.Module.Graph
import GHC.Unit.Module.ModIface
import GHC.Unit.Home.ModInfo
-import GHC.Unit.Home.PackageTable
import GHC.Tc.Module ( runTcInteractive, tcRnTypeSkolemising, loadUnqualIfaces )
import GHC.Tc.Solver (simplifyWantedsTcM)
@@ -823,16 +822,17 @@ findGlobalRdrEnv hsc_env imports
idecls :: [LImportDecl GhcPs]
idecls = [noLocA d | IIDecl d <- imports]
- imods :: [ModuleName]
+ imods :: [Module]
imods = [m | IIModule m <- imports]
- mkEnv mod = mkTopLevEnv hsc_env mod >>= \case
- Left err -> pure $ Left (mod, err)
- Right env -> pure $ Right env
+ mkEnv mod = do
+ mkTopLevEnv hsc_env mod >>= \case
+ Left err -> pure $ Left (moduleName mod, err)
+ Right env -> pure $ Right env
-mkTopLevEnv :: HscEnv -> ModuleName -> IO (Either String GlobalRdrEnv)
+mkTopLevEnv :: HscEnv -> Module -> IO (Either String GlobalRdrEnv)
mkTopLevEnv hsc_env modl
- = lookupHpt hpt modl >>= \case
+ = HUG.lookupHugByModule modl hug >>= \case
Nothing -> pure $ Left "not a home module"
Just details ->
case mi_top_env (hm_iface details) of
@@ -857,7 +857,7 @@ mkTopLevEnv hsc_env modl
let exports_env = mkGlobalRdrEnv $ gresFromAvails hsc_env Nothing (getDetOrdAvails exports)
pure $ Right $ plusGlobalRdrEnv imports_env exports_env
where
- hpt = hsc_HPT hsc_env
+ hug = hsc_HUG hsc_env
-- | Get the interactive evaluation context, consisting of a pair of the
-- set of modules from which we take the full top-level scope, and the set
@@ -870,11 +870,9 @@ getContext = withSession $ \HscEnv{ hsc_IC=ic } ->
-- its full top-level scope available.
moduleIsInterpreted :: GhcMonad m => Module -> m Bool
moduleIsInterpreted modl = withSession $ \h ->
- if notHomeModule (hsc_home_unit h) modl
- then return False
- else liftIO (HUG.lookupHugByModule modl (hsc_HUG h)) >>= \case
- Just hmi -> return (isJust $ homeModInfoByteCode hmi)
- _not_a_home_module -> return False
+ liftIO (HUG.lookupHugByModule modl (hsc_HUG h)) >>= \case
+ Just hmi -> return (isJust $ homeModInfoByteCode hmi)
+ _not_a_home_module -> return False
-- | Looks up an identifier in the current interactive context (for :info)
-- Filter the instances by the ones whose tycons (or classes resp)
=====================================
compiler/GHC/StgToByteCode.hs
=====================================
@@ -78,7 +78,7 @@ import Control.Monad
import Data.Char
import GHC.Unit.Module
-import GHC.Unit.Home.PackageTable (lookupHpt)
+import qualified GHC.Unit.Home.Graph as HUG
import Data.Array
import Data.Coerce (coerce)
@@ -458,8 +458,7 @@ schemeER_wrk d p rhs = schemeE d 0 p rhs
-- If that is 'Nothing', consider breakpoints to be disabled and skip the
-- instruction.
--
--- If the breakpoint is inlined from another module, look it up in the home
--- package table.
+-- If the breakpoint is inlined from another module, look it up in the HUG (home unit graph).
-- If the module doesn't exist there, or its module pointer is null (which means
-- that the 'ModBreaks' value is uninitialized), skip the instruction.
break_info ::
@@ -472,7 +471,7 @@ break_info hsc_env mod current_mod current_mod_breaks
| mod == current_mod
= pure $ check_mod_ptr =<< current_mod_breaks
| otherwise
- = ioToBc (lookupHpt (hsc_HPT hsc_env) (moduleName mod)) >>= \case
+ = ioToBc (HUG.lookupHugByModule mod (hsc_HUG hsc_env)) >>= \case
Just hp -> pure $ check_mod_ptr (getModBreaks hp)
Nothing -> pure Nothing
where
=====================================
compiler/GHC/StgToJS/Linker/Linker.hs
=====================================
@@ -461,7 +461,7 @@ computeLinkDependencies cfg unit_env link_spec finder_opts finder_cache ar_cache
-- all the units we want to link together, without their dependencies
let root_units = filter (/= ue_currentUnit unit_env)
- $ filter (/= interactiveUnitId)
+ $ filter (/= interactiveUnitId) -- TODO @fendor: what does this do?
$ nub
$ rts_wired_units ++ reverse obj_units ++ reverse units
=====================================
compiler/GHC/Tc/Module.hs
=====================================
@@ -150,7 +150,6 @@ import GHC.Types.Basic hiding( SuccessFlag(..) )
import GHC.Types.Annotations
import GHC.Types.SrcLoc
import GHC.Types.SourceFile
-import GHC.Types.PkgQual
import qualified GHC.LanguageExtensions as LangExt
import GHC.Unit.Env as UnitEnv
@@ -2119,15 +2118,18 @@ runTcInteractive hsc_env thing_inside
, let local_gres = filter isLocalGRE gres
, not (null local_gres) ]) ]
- ; let getOrphans m mb_pkg = fmap (\iface -> mi_module iface
- : dep_orphs (mi_deps iface))
- (loadSrcInterface (text "runTcInteractive") m
- NotBoot mb_pkg)
+ ; let getOrphansForModuleName m mb_pkg = do
+ iface <- loadSrcInterface (text "runTcInteractive") m NotBoot mb_pkg
+ pure $ mi_module iface : dep_orphs (mi_deps iface)
+
+ getOrphansForModule m = do
+ iface <- loadModuleInterface (text "runTcInteractive") m
+ pure $ mi_module iface : dep_orphs (mi_deps iface)
; !orphs <- fmap (force . concat) . forM (ic_imports icxt) $ \i ->
case i of -- force above: see #15111
- IIModule n -> getOrphans n NoPkgQual
- IIDecl i -> getOrphans (unLoc (ideclName i))
+ IIModule n -> getOrphansForModule n
+ IIDecl i -> getOrphansForModuleName (unLoc (ideclName i))
(renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName i) (ideclPkgQual i))
=====================================
compiler/GHC/Types/Name/Ppr.hs
=====================================
@@ -13,6 +13,7 @@ import GHC.Data.FastString
import GHC.Unit
import GHC.Unit.Env
+import qualified GHC.Unit.Home.Graph as HUG
import GHC.Types.Name
import GHC.Types.Name.Reader
@@ -72,12 +73,11 @@ mkNamePprCtx :: Outputable info => PromotionTickContext -> UnitEnv -> GlobalRdrE
mkNamePprCtx ptc unit_env env
= QueryQualify
(mkQualName env)
- (mkQualModule unit_state home_unit)
+ (mkQualModule unit_state unit_env)
(mkQualPackage unit_state)
(mkPromTick ptc env)
where
unit_state = ue_homeUnitState unit_env
- home_unit = ue_homeUnit unit_env
mkQualName :: Outputable info => GlobalRdrEnvX info -> QueryQualifyName
mkQualName env = qual_name where
@@ -215,10 +215,12 @@ Side note (int-index):
-- | Creates a function for formatting modules based on two heuristics:
-- (1) if the module is the current module, don't qualify, and (2) if there
-- is only one exposed package which exports this module, don't qualify.
-mkQualModule :: UnitState -> Maybe HomeUnit -> QueryQualifyModule
-mkQualModule unit_state mhome_unit mod
- | Just home_unit <- mhome_unit
- , isHomeModule home_unit mod = False
+mkQualModule :: UnitState -> UnitEnv -> QueryQualifyModule
+mkQualModule unit_state unitEnv mod
+ -- Check whether the unit of the module is in the HomeUnitGraph.
+ -- If it is, then we consider this 'mod' to be "local" and don't
+ -- want to qualify it.
+ | HUG.memberHugUnit (moduleUnit mod) (ue_home_unit_graph unitEnv) = False
| [(_, pkgconfig)] <- lookup,
mkUnit pkgconfig == moduleUnit mod
=====================================
compiler/GHC/Unit/Env.hs
=====================================
@@ -241,7 +241,7 @@ isUnitEnvInstalledModule ue m = maybe False (`isHomeInstalledModule` m) hu
-- -------------------------------------------------------
ue_findHomeUnitEnv :: HasDebugCallStack => UnitId -> UnitEnv -> HomeUnitEnv
-ue_findHomeUnitEnv uid e = case HUG.lookupHugUnit uid (ue_home_unit_graph e) of
+ue_findHomeUnitEnv uid e = case HUG.lookupHugUnitId uid (ue_home_unit_graph e) of
Nothing -> pprPanic "Unit unknown to the internal unit environment"
$ text "unit (" <> ppr uid <> text ")"
$$ ppr (HUG.allUnits (ue_home_unit_graph e))
@@ -311,7 +311,7 @@ ue_unitHomeUnit uid = expectJust . ue_unitHomeUnit_maybe uid
ue_unitHomeUnit_maybe :: UnitId -> UnitEnv -> Maybe HomeUnit
ue_unitHomeUnit_maybe uid ue_env =
- HUG.homeUnitEnv_home_unit =<< HUG.lookupHugUnit uid (ue_home_unit_graph ue_env)
+ HUG.homeUnitEnv_home_unit =<< HUG.lookupHugUnitId uid (ue_home_unit_graph ue_env)
-- -------------------------------------------------------
-- Query and modify the currently active unit
@@ -319,7 +319,7 @@ ue_unitHomeUnit_maybe uid ue_env =
ue_currentHomeUnitEnv :: HasDebugCallStack => UnitEnv -> HomeUnitEnv
ue_currentHomeUnitEnv e =
- case HUG.lookupHugUnit (ue_currentUnit e) (ue_home_unit_graph e) of
+ case HUG.lookupHugUnitId (ue_currentUnit e) (ue_home_unit_graph e) of
Just unitEnv -> unitEnv
Nothing -> pprPanic "packageNotFound" $
(ppr $ ue_currentUnit e) $$ ppr (HUG.allUnits (ue_home_unit_graph e))
@@ -389,7 +389,7 @@ ue_transitiveHomeDeps uid e =
-- FIXME: Shouldn't this be a proper assertion only used in debug mode?
assertUnitEnvInvariant :: HasDebugCallStack => UnitEnv -> UnitEnv
assertUnitEnvInvariant u =
- case HUG.lookupHugUnit (ue_current_unit u) (ue_home_unit_graph u) of
+ case HUG.lookupHugUnitId (ue_current_unit u) (ue_home_unit_graph u) of
Just _ -> u
Nothing ->
pprPanic "invariant" (ppr (ue_current_unit u) $$ ppr (HUG.allUnits (ue_home_unit_graph u)))
=====================================
compiler/GHC/Unit/Home/Graph.hs
=====================================
@@ -34,7 +34,10 @@ module GHC.Unit.Home.Graph
, lookupHug
, lookupHugByModule
, lookupHugUnit
-
+ , lookupHugUnitId
+ , lookupAllHug
+ , memberHugUnit
+ , memberHugUnitId
-- ** Reachability
, transitiveHomeDeps
@@ -62,6 +65,8 @@ module GHC.Unit.Home.Graph
, unitEnv_insert
, unitEnv_new
, unitEnv_lookup
+ , unitEnv_traverseWithKey
+ , unitEnv_assocs
) where
import GHC.Prelude
@@ -73,6 +78,7 @@ import GHC.Unit.Home.PackageTable
import GHC.Unit.Module
import GHC.Unit.Module.ModIface
import GHC.Unit.State
+import GHC.Utils.Monad (mapMaybeM)
import GHC.Utils.Outputable
import GHC.Utils.Panic
@@ -222,7 +228,7 @@ updateUnitFlags uid f = unitEnv_adjust update uid
-- | Compute the transitive closure of a unit in the 'HomeUnitGraph'.
-- If the argument unit is not present in the graph returns Nothing.
transitiveHomeDeps :: UnitId -> HomeUnitGraph -> Maybe [UnitId]
-transitiveHomeDeps uid hug = case lookupHugUnit uid hug of
+transitiveHomeDeps uid hug = case lookupHugUnitId uid hug of
Nothing -> Nothing
Just hue -> Just $
Set.toList (loop (Set.singleton uid) (homeUnitDepends (homeUnitEnv_units hue)))
@@ -234,7 +240,7 @@ transitiveHomeDeps uid hug = case lookupHugUnit uid hug of
let hue = homeUnitDepends
. homeUnitEnv_units
. expectJust
- $ lookupHugUnit uid hug
+ $ lookupHugUnitId uid hug
in loop (Set.insert uid acc) (hue ++ uids)
--------------------------------------------------------------------------------
@@ -246,21 +252,47 @@ transitiveHomeDeps uid hug = case lookupHugUnit uid hug of
lookupHug :: HomeUnitGraph -> UnitId -> ModuleName -> IO (Maybe HomeModInfo)
lookupHug hug uid mod = do
case unitEnv_lookup_maybe uid hug of
- -- Really, here we want "lookup HPT" rather than unitEnvLookup
Nothing -> pure Nothing
Just hue -> lookupHpt (homeUnitEnv_hpt hue) mod
-- | Lookup the 'HomeModInfo' of a 'Module' in the 'HomeUnitGraph' (via the 'HomePackageTable' of the corresponding unit)
lookupHugByModule :: Module -> HomeUnitGraph -> IO (Maybe HomeModInfo)
-lookupHugByModule mod hug
- | otherwise = do
- case unitEnv_lookup_maybe (toUnitId $ moduleUnit mod) hug of
- Nothing -> pure Nothing
- Just env -> lookupHptByModule (homeUnitEnv_hpt env) mod
+lookupHugByModule mod hug =
+ case lookupHugUnit (moduleUnit mod) hug of
+ Nothing -> pure Nothing
+ Just env -> lookupHptByModule (homeUnitEnv_hpt env) mod
+
+-- | Lookup all 'HomeModInfo' that have the same 'ModuleName' as the given 'ModuleName'.
+-- 'ModuleName's are not unique in the case of multiple home units, so there can be
+-- more than one possible 'HomeModInfo'.
+--
+-- You should always prefer 'lookupHug' and 'lookupHugByModule' when possible.
+lookupAllHug :: HomeUnitGraph -> ModuleName -> IO [HomeModInfo]
+lookupAllHug hug mod = mapMaybeM (\uid -> lookupHug hug uid mod) (Set.toList $ unitEnv_keys hug)
-- | Lookup a 'HomeUnitEnv' by 'UnitId' in a 'HomeUnitGraph'
-lookupHugUnit :: UnitId -> HomeUnitGraph -> Maybe HomeUnitEnv
-lookupHugUnit = unitEnv_lookup_maybe
+lookupHugUnitId :: UnitId -> HomeUnitGraph -> Maybe HomeUnitEnv
+lookupHugUnitId = unitEnv_lookup_maybe
+
+-- | Check whether the 'UnitId' is present in the 'HomeUnitGraph'
+memberHugUnitId :: UnitId -> HomeUnitGraph -> Bool
+memberHugUnitId u = isJust . lookupHugUnitId u
+
+-- | Lookup up the 'HomeUnitEnv' by the 'Unit' in the 'HomeUnitGraph'.
+-- If the 'Unit' can be turned into a 'UnitId', we behave identical to 'lookupHugUnitId'.
+--
+-- A 'HoleUnit' is never part of the 'HomeUnitGraph', only instantiated 'Unit's
+lookupHugUnit :: Unit -> HomeUnitGraph -> Maybe HomeUnitEnv
+lookupHugUnit unit hug =
+ if isHoleUnit unit
+ then Nothing
+ else lookupHugUnitId (toUnitId unit) hug
+
+-- | Check whether the 'Unit' is present in the 'HomeUnitGraph'
+--
+-- A 'HoleUnit' is never part of the 'HomeUnitGraph', only instantiated 'Unit's
+memberHugUnit :: Unit -> HomeUnitGraph -> Bool
+memberHugUnit u = isJust . lookupHugUnit u
--------------------------------------------------------------------------------
-- * Internal representation map
@@ -313,6 +345,13 @@ unitEnv_foldWithKey f z (UnitEnvGraph g)= Map.foldlWithKey' f z g
unitEnv_lookup :: UnitEnvGraphKey -> UnitEnvGraph v -> v
unitEnv_lookup u env = expectJust $ unitEnv_lookup_maybe u env
+unitEnv_traverseWithKey :: Applicative f => (UnitEnvGraphKey -> a -> f b) -> UnitEnvGraph a -> f (UnitEnvGraph b)
+unitEnv_traverseWithKey f unitEnv =
+ UnitEnvGraph <$> Map.traverseWithKey f (unitEnv_graph unitEnv)
+
+unitEnv_assocs :: UnitEnvGraph a -> [(UnitEnvGraphKey, a)]
+unitEnv_assocs (UnitEnvGraph x) = Map.assocs x
+
--------------------------------------------------------------------------------
-- * Utilities
--------------------------------------------------------------------------------
=====================================
compiler/GHC/Unit/Types.hs
=====================================
@@ -63,12 +63,16 @@ module GHC.Unit.Types
, mainUnitId
, thisGhcUnitId
, interactiveUnitId
+ , interactiveGhciUnitId
+ , interactiveSessionUnitId
, ghcInternalUnit
, rtsUnit
, mainUnit
, thisGhcUnit
, interactiveUnit
+ , interactiveGhciUnit
+ , interactiveSessionUnit
, isInteractiveModule
, wiredInUnitIds
@@ -588,20 +592,24 @@ Make sure you change 'GHC.Unit.State.findWiredInUnits' if you add an entry here.
-}
ghcInternalUnitId, rtsUnitId,
- mainUnitId, thisGhcUnitId, interactiveUnitId :: UnitId
+ mainUnitId, thisGhcUnitId, interactiveUnitId, interactiveGhciUnitId, interactiveSessionUnitId :: UnitId
ghcInternalUnit, rtsUnit,
- mainUnit, thisGhcUnit, interactiveUnit :: Unit
+ mainUnit, thisGhcUnit, interactiveUnit, interactiveGhciUnit, interactiveSessionUnit :: Unit
ghcInternalUnitId = UnitId (fsLit "ghc-internal")
rtsUnitId = UnitId (fsLit "rts")
thisGhcUnitId = UnitId (fsLit cProjectUnitId) -- See Note [GHC's Unit Id]
interactiveUnitId = UnitId (fsLit "interactive")
+interactiveGhciUnitId = UnitId (fsLit "interactive-ghci")
+interactiveSessionUnitId = UnitId (fsLit "interactive-session")
ghcInternalUnit = RealUnit (Definite ghcInternalUnitId)
rtsUnit = RealUnit (Definite rtsUnitId)
thisGhcUnit = RealUnit (Definite thisGhcUnitId)
interactiveUnit = RealUnit (Definite interactiveUnitId)
+interactiveGhciUnit = RealUnit (Definite interactiveGhciUnitId)
+interactiveSessionUnit = RealUnit (Definite interactiveSessionUnitId)
-- | This is the package Id for the current program. It is the default
-- package Id if you don't specify a package name. We don't add this prefix
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -113,6 +113,7 @@ import GHC.Utils.Misc
import qualified GHC.LanguageExtensions as LangExt
import qualified GHC.Data.Strict as Strict
import GHC.Types.Error
+import qualified GHC.Unit.Home.Graph as HUG
-- Haskell Libraries
import System.Console.Haskeline as Haskeline
@@ -129,6 +130,7 @@ import Data.Array
import qualified Data.ByteString.Char8 as BS
import Data.Char
import Data.Function
+import qualified Data.Foldable as Foldable
import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef )
import Data.List ( find, intercalate, intersperse,
isPrefixOf, isSuffixOf, nub, partition, sort, sortBy, (\\) )
@@ -204,31 +206,31 @@ ghciCommands = map mkCmd [
-- Hugs users are accustomed to :e, so make sure it doesn't overlap
("?", keepGoing help, noCompletion),
("add", keepGoingPaths addModule, completeFilename),
- ("abandon", keepGoing abandonCmd, noCompletion),
- ("break", keepGoing breakCmd, completeBreakpoint),
- ("back", keepGoing backCmd, noCompletion),
+ ("abandon", keepGoing abandonCmd, noCompletion),
+ ("break", keepGoing breakCmd, completeBreakpoint),
+ ("back", keepGoing backCmd, noCompletion),
("browse", keepGoing' (browseCmd False), completeModule),
("browse!", keepGoing' (browseCmd True), completeModule),
- ("cd", keepGoingMulti' changeDirectory, completeFilename),
- ("continue", keepGoing continueCmd, noCompletion),
+ ("cd", keepGoing' changeDirectory, completeFilename),
+ ("continue", keepGoing' continueCmd, noCompletion),
("cmd", keepGoing cmdCmd, completeExpression),
("def", keepGoing (defineMacro False), completeExpression),
("def!", keepGoing (defineMacro True), completeExpression),
("delete", keepGoing deleteCmd, noCompletion),
("disable", keepGoing disableCmd, noCompletion),
("doc", keepGoing' docCmd, completeIdentifier),
- ("edit", keepGoingMulti' editFile, completeFilename),
+ ("edit", keepGoing' editFile, completeFilename),
("enable", keepGoing enableCmd, noCompletion),
("force", keepGoing forceCmd, completeExpression),
("forward", keepGoing forwardCmd, noCompletion),
- ("help", keepGoingMulti help, noCompletion),
- ("history", keepGoingMulti historyCmd, noCompletion),
- ("info", keepGoingMulti' (info False), completeIdentifier),
- ("info!", keepGoingMulti' (info True), completeIdentifier),
+ ("help", keepGoing help, noCompletion),
+ ("history", keepGoing historyCmd, noCompletion),
+ ("info", keepGoing' (info False), completeIdentifier),
+ ("info!", keepGoing' (info True), completeIdentifier),
("issafe", keepGoing' isSafeCmd, completeModule),
("ignore", keepGoing ignoreCmd, noCompletion),
- ("kind", keepGoingMulti' (kindOfType False), completeIdentifier),
- ("kind!", keepGoingMulti' (kindOfType True), completeIdentifier),
+ ("kind", keepGoing' (kindOfType False), completeIdentifier),
+ ("kind!", keepGoing' (kindOfType True), completeIdentifier),
("load", keepGoingPaths loadModule_, completeHomeModuleOrFile),
("load!", keepGoingPaths loadModuleDefer, completeHomeModuleOrFile),
("list", keepGoing' listCmd, noCompletion),
@@ -236,19 +238,19 @@ ghciCommands = map mkCmd [
("main", keepGoing runMain, completeFilename),
("print", keepGoing printCmd, completeExpression),
("quit", quit, noCompletion),
- ("reload", keepGoingMulti' reloadModule, noCompletion),
- ("reload!", keepGoingMulti' reloadModuleDefer, noCompletion),
- ("run", keepGoing runRun, completeFilename),
+ ("reload", keepGoing' reloadModule, noCompletion),
+ ("reload!", keepGoing' reloadModuleDefer, noCompletion),
+ ("run", keepGoing' runRun, completeFilename),
("script", keepGoing' scriptCmd, completeFilename),
- ("set", keepGoingMulti setCmd, completeSetOptions),
- ("seti", keepGoingMulti setiCmd, completeSeti),
- ("show", keepGoingMulti' showCmd, completeShowOptions),
- ("showi", keepGoing showiCmd, completeShowiOptions),
+ ("set", keepGoing setCmd, completeSetOptions),
+ ("seti", keepGoing setiCmd, completeSeti),
+ ("show", keepGoing' showCmd, completeShowOptions),
+ ("showi", keepGoing showiCmd, completeShowiOptions),
("sprint", keepGoing sprintCmd, completeExpression),
("step", keepGoing stepCmd, completeIdentifier),
("steplocal", keepGoing stepLocalCmd, completeIdentifier),
("stepmodule",keepGoing stepModuleCmd, completeIdentifier),
- ("type", keepGoingMulti' typeOfExpr, completeExpression),
+ ("type", keepGoing' typeOfExpr, completeExpression),
("trace", keepGoing traceCmd, completeExpression),
("unadd", keepGoingPaths unAddModule, completeFilename),
("undef", keepGoing undefineMacro, completeMacro),
@@ -316,24 +318,11 @@ showSDocForUserQualify doc = do
keepGoing :: (String -> GHCi ()) -> (String -> InputT GHCi CmdExecOutcome)
keepGoing a str = keepGoing' (lift . a) str
-keepGoingMulti :: (String -> GHCi ()) -> (String -> InputT GHCi CmdExecOutcome)
-keepGoingMulti a str = keepGoingMulti' (lift . a) str
-
keepGoing' :: GhciMonad m => (a -> m ()) -> a -> m CmdExecOutcome
keepGoing' a str = do
- in_multi <- inMultiMode
- if in_multi
- then reportError GhciCommandNotSupportedInMultiMode
- else a str
+ a str
return CmdSuccess
--- For commands which are actually support in multi-mode, initially just :reload
-keepGoingMulti' :: GhciMonad m => (String -> m ()) -> String -> m CmdExecOutcome
-keepGoingMulti' a str = a str >> return CmdSuccess
-
-inMultiMode :: GhciMonad m => m Bool
-inMultiMode = multiMode <$> getGHCiState
-
keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi CmdExecOutcome)
keepGoingPaths a str
= do case toArgsNoLoc str of
@@ -489,9 +478,6 @@ default_args = []
interactiveUI :: GhciSettings -> [(FilePath, Maybe UnitId, Maybe Phase)] -> Maybe [String]
-> Ghc ()
interactiveUI config srcs maybe_exprs = do
- -- This is a HACK to make sure dynflags are not overwritten when setting
- -- options. When GHCi is made properly multi component it should be removed.
- modifySession (\env -> hscSetActiveUnitId (hscActiveUnitId env) env)
-- HACK! If we happen to get into an infinite loop (eg the user
-- types 'let x=x in x' at the prompt), then the thread will block
-- on a blackhole, and become unreachable during GC. The GC will
@@ -507,21 +493,7 @@ interactiveUI config srcs maybe_exprs = do
-- Initialise buffering for the *interpreted* I/O system
(nobuffering, flush) <- runInternal initInterpBuffering
- -- The initial set of DynFlags used for interactive evaluation is the same
- -- as the global DynFlags, plus -XExtendedDefaultRules and
- -- -XNoMonomorphismRestriction.
- -- See Note [Changing language extensions for interactive evaluation] #10857
- dflags <- getDynFlags
- let dflags' = (xopt_set_unlessExplSpec
- LangExt.ExtendedDefaultRules xopt_set)
- . (xopt_set_unlessExplSpec
- LangExt.MonomorphismRestriction xopt_unset)
- $ dflags
- GHC.setInteractiveDynFlags dflags'
- _ <- GHC.setProgramDynFlags
- -- Set Opt_KeepGoing so that :reload loads as much as
- -- possible
- (gopt_set dflags Opt_KeepGoing)
+ installInteractiveHomeUnit
-- Update the LogAction. Ensure we don't override the user's log action lest
-- we break -ddump-json (#14078)
@@ -553,9 +525,6 @@ interactiveUI config srcs maybe_exprs = do
case simpleImportDecl preludeModuleName of
-- Set to True because Prelude is implicitly imported.
impDecl@ImportDecl{ideclExt=ext} -> impDecl{ideclExt = ext{ideclImplicit=True}}
- hsc_env <- GHC.getSession
- let !in_multi = length (hsc_all_home_unit_ids hsc_env) > 1
- -- We force this to make sure we don't retain the hsc_env when reloading
empty_cache <- liftIO newIfaceCache
startGHCi (runGHCi srcs maybe_exprs)
GHCiState{ progname = default_progname,
@@ -566,7 +535,6 @@ interactiveUI config srcs maybe_exprs = do
stop = default_stop,
editor = default_editor,
options = [],
- multiMode = in_multi,
localConfig = SourceLocalConfig,
-- We initialize line number as 0, not 1, because we use
-- current line number while reporting errors which is
@@ -595,6 +563,243 @@ interactiveUI config srcs maybe_exprs = do
return ()
+{-
+Note [Multiple Home Units aware GHCi]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+GHCi supported multiple home units up to a certain degree for quite a while now.
+The supported feature set was limited, due to a design impasse:
+One of the home units must be "active", e.g., there must be one 'HomeUnit'
+whose 'UnitId' is "active" which is returned when calling
+
+@'hscActiveUnitId' \<$\> 'getSession'@
+
+This makes sense in a GHC session, since you are always compiling a particular
+Module, but it makes less intuitive sense in an interactive session.
+Given an expression to evaluate, we can't easily tell in which "context" the expression
+should be parsed, typechecked and evaluated.
+That's why initially, most of GHCi features, except for `:reload`ing were disabled
+if the GHCi session had more than one 'HomeUnitEnv'.
+
+We lift this restriction, enabling all features of GHCi for the multiple home unit case.
+To do this, we fundamentally change the 'HomeUnitEnv' graph to be multiple home unit first.
+Instead of differentiating the case were we have a single home unit and multiple,
+we now always set up a multiple home unit session that scales seamlessly to an arbitrary
+amount of home units.
+
+We introduce two new 'HomeUnitEnv's that are always added to the 'HomeUnitGraph'.
+They are:
+
+The "interactive-ghci", called the 'interactiveGhciUnit', contains the same
+'DynFlags' that are used by the 'InteractiveContext' for interactive evaluation
+of expressions.
+This 'HomeUnitEnv' is only used on the prompt of GHCi, so we may refer to it as
+"interactive-prompt" unit.
+See Note [Relation between the 'InteractiveContext' and 'interactiveGhciUnitId']
+for discussing its role.
+
+And the 'interactive-session', called 'interactiveSessionUnit' or
+'interactiveSessionUnitId', which is used for loading Scripts into
+GHCi that are not 'Target's of any home unit, via `:load` or `:add`.
+
+Both of these "interactive" home units depend on all other 'HomeUnitEnv's that
+are passed as arguments on the cli.
+Additionally, the "interactive-ghci" unit depends on 'interactive-session'.
+
+We always evaluate expressions in the context of the
+"interactive-ghci" session.
+Since "interactive-ghci" depends on all home units, we can import any 'Module'
+from the other home units with ease.
+
+As we have a clear 'HomeUnitGraph' hierarchy, we can set 'interactiveGhciUnitId'
+as the active home unit for the full duration of the GHCi session.
+In GHCi, we always set 'interactiveGhciUnitId' to be the currently active home unit.
+
+=== Single Home Unit Case Diagram
+
+ Example: ghci -this-unit-id main ...
+ Equivalent to: ghci -unit @unitA
+
+ ┌───────────────────┐ ┌─────────────────────┐
+ │ Interactive Prompt│ │ Interactive Session │
+ │ │───────►│ │
+ │ interactive-ghci │ │ interactive-session │
+ └────────┬──────────┘ └──────────┬──────────┘
+ │ │
+ └───────────────┬──────────────┘
+ │
+ │
+ ┌────▼───┐
+ │ Unit A │
+ │ main │
+ └────────┘
+
+
+=== Multi Home Unit Case Diagram
+
+ Example: ghci -unit @unitA -unit @unitB -unit @unitC
+
+ ┌───────────────────┐ ┌─────────────────────┐
+ │ Interactive Prompt│ │ Interactive Session │
+ │ │───────►│ │
+ │ interactive-ghci │ │ interactive-session │
+ └────────┬──────────┘ └──────────┬──────────┘
+ │ │
+ └───────────────┬──────────────┘
+ │
+ ┌─────────────┼─────────────┐
+ ┌────▼───┐ ┌────▼───┐ ┌────▼───┐
+ │ Unit A │ │ Unit B │ │ Unit C │
+ │ a-0.0 │ │ b-0.0 │ │ c-0.0 │
+ └────────┘ └────────┘ └────────┘
+
+As we can see, this design can be scaled to an arbitrary number of Home Units.
+
+=== 'interactiveGhciUnit' Home Unit
+
+The 'interactiveGhciUnit' home unit is used for storing the 'DynFlags' of
+the interactive context.
+There is considerable overlap with the 'InteractiveContext,
+see Note [Relation between the 'InteractiveContext' and 'interactiveGhciUnitId']
+for details.
+
+The 'DynFlags' of the 'interactiveGhciUnit' can be modified by using `:seti`
+commands in the GHCi session.
+
+=== 'interactiveSessionUnit' Home Unit
+
+The 'interactiveSessionUnit' home unit is used as a kitchen sink for Modules that
+are not part of a home unit already.
+When the user types ":load", it is not trivial to figure to which home unit the module
+should be added to.
+Especially, when there is more than home unit. Thus, we always ":load"ed modules
+to this home unit.
+
+The 'DynFlags' of the 'interactiveSessionUnit' can be modified via the ':set'
+commands in the GHCi session.
+-}
+
+-- | Set up the multiple home unit session.
+-- Installs a 'HomeUnitEnv' for the ghci-prompt and one for the ghci-session in the
+-- current 'HscEnv'.
+--
+-- Installs the two home units 'interactiveGhciUnit' and 'interactiveSessionUnit', which
+-- both depend on any other 'HomeUnitEnv' that is already present in the current
+-- 'HomeUnitGraph'.
+--
+-- In other words, in each GHCi session, there are always at least three 'HomeUnitEnv's:
+--
+-- * 'interactiveGhciUnit'
+-- * 'interactiveSessionUnit'
+-- * 'mainUnit' (by default)
+--
+-- The 'interactiveGhciUnit' is the currently active unit, i.e. @hscActiveUnit hsc_env == 'interactiveGhciUnitId'@,
+-- and it stays as the active unit for the entire duration of GHCi.
+-- Within GHCi, you can rely on this property.
+--
+-- For motivation and design, see Note [Multiple Home Units aware GHCi]
+installInteractiveHomeUnit :: GHC.GhcMonad m => m ()
+installInteractiveHomeUnit = do
+ logger <- getLogger
+ hsc_env <- GHC.getSession
+ -- The initial set of DynFlags used for interactive evaluation is the same
+ -- as the global DynFlags, plus:
+ -- * -XExtendedDefaultRules and
+ -- * -XNoMonomorphismRestriction.
+ -- See Note [Changing language extensions for interactive evaluation] #10857
+ dflags <- getDynFlags
+ let
+ dflags0' =
+ (xopt_set_unlessExplSpec LangExt.ExtendedDefaultRules xopt_set) .
+ (xopt_set_unlessExplSpec LangExt.MonomorphismRestriction xopt_unset) $
+ dflags
+ -- Disable warnings about unused packages
+ -- It doesn't matter for the interactive session.
+ -- See Note [No unused package warnings for the interactive session]
+ dflags0 = wopt_unset dflags0' Opt_WarnUnusedPackages
+
+ -- Trivial '-package-id <uid>' flag
+ homeUnitPkgFlag uid =
+ ExposePackage
+ (unitIdString uid)
+ (UnitIdArg $ RealUnit (Definite uid))
+ (ModRenaming False [])
+
+ sessionUnitExposedFlag =
+ homeUnitPkgFlag interactiveSessionUnitId
+
+ -- Explicitly depend on all home units and 'sessionUnitExposedFlag'.
+ -- Normalise the 'dflagsPrompt', as they will be used for 'ic_dflags'
+ -- of the 'InteractiveContext'.
+ dflagsPrompt <- GHC.normaliseInteractiveDynFlags logger $
+ setHomeUnitId interactiveGhciUnitId $ dflags0
+ { packageFlags =
+ [ sessionUnitExposedFlag ] ++
+ [ homeUnitPkgFlag uid
+ | homeUnitEnv <- Foldable.toList $ hsc_HUG hsc_env
+ , Just homeUnit <- [homeUnitEnv_home_unit homeUnitEnv]
+ , let uid = homeUnitId homeUnit
+ ] ++
+ (packageFlags dflags0)
+ , importPaths = [] -- TODO @fendor: do we need this?
+ }
+
+ let
+ -- Explicitly depend on all current home units.
+ dflagsSession =
+ setHomeUnitId interactiveSessionUnitId $ dflags
+ { packageFlags =
+ [ homeUnitPkgFlag uid
+ | homeUnitEnv <- Foldable.toList $ hsc_HUG hsc_env
+ , Just homeUnit <- [homeUnitEnv_home_unit homeUnitEnv]
+ , let uid = homeUnitId homeUnit
+ ] ++
+ (packageFlags dflags)
+ , importPaths = [] -- TODO @fendor: do we need this?
+ }
+
+ let
+ cached_unit_dbs =
+ concat
+ . catMaybes
+ . fmap homeUnitEnv_unit_dbs
+ $ Foldable.toList
+ $ hsc_HUG hsc_env
+
+ all_unit_ids =
+ S.insert interactiveGhciUnitId $
+ S.insert interactiveSessionUnitId $
+ hsc_all_home_unit_ids hsc_env
+
+ ghciPromptUnit <- setupHomeUnitFor logger dflagsPrompt all_unit_ids cached_unit_dbs
+ ghciSessionUnit <- setupHomeUnitFor logger dflagsSession all_unit_ids cached_unit_dbs
+ let
+ -- Setup up the HUG, install the interactive home units
+ withInteractiveUnits =
+ HUG.unitEnv_insert interactiveGhciUnitId ghciPromptUnit
+ . HUG.unitEnv_insert interactiveSessionUnitId ghciSessionUnit
+
+ -- Finish up the setup, install the new HUG and make the 'interactiveGhciUnitId'
+ -- the active unit.
+ modifySessionM (\env -> do
+ -- Set the new HUG
+ let newEnv0 = hscUpdateHUG withInteractiveUnits env
+ -- Make sure the 'interactiveGhciUnitId' is active and 'hsc_dflags'
+ -- are populated correctly.
+ -- The 'interactiveGhciUnitId' will stay as the active unit within GHCi.
+ let newEnv1 = hscSetActiveUnitId interactiveGhciUnitId newEnv0
+ -- Use the 'DynFlags' of the 'interactiveGhciUnitId' for the 'InteractiveContext'.
+ GHC.initialiseInteractiveDynFlags dflagsPrompt newEnv1
+ )
+
+ pure ()
+ where
+ setupHomeUnitFor :: GHC.GhcMonad m => Logger -> DynFlags -> S.Set UnitId -> [UnitDatabase UnitId] -> m HomeUnitEnv
+ setupHomeUnitFor logger dflags all_home_units cached_unit_dbs = do
+ (dbs,unit_state,home_unit,_mconstants) <-
+ liftIO $ initUnits logger dflags (Just cached_unit_dbs) all_home_units
+ hpt <- liftIO emptyHomePackageTable
+ pure (HUG.mkHomeUnitEnv unit_state (Just dbs) dflags hpt (Just home_unit))
+
reportError :: GhciMonad m => GhciCommandMessage -> m ()
reportError err = do
printError err
@@ -933,7 +1138,7 @@ getInfoForPrompt = do
| otherwise = unLoc (ideclName d)
modules_names =
- ['*':(moduleNameString m) | IIModule m <- rev_imports] ++
+ ['*':(moduleNameString (moduleName m)) | IIModule m <- rev_imports] ++
[moduleNameString (myIdeclName d) | IIDecl d <- rev_imports]
line = 1 + line_number st
@@ -1971,13 +2176,27 @@ wrapDeferTypeErrors :: GHC.GhcMonad m => m a -> m a
wrapDeferTypeErrors load =
MC.bracket
(do
- -- Force originalFlags to avoid leaking the associated HscEnv
- !originalFlags <- getDynFlags
- void $ GHC.setProgramDynFlags $
- setGeneralFlag' Opt_DeferTypeErrors originalFlags
- return originalFlags)
- (\originalFlags -> void $ GHC.setProgramDynFlags originalFlags)
+ -- Force originalHUG to avoid leaking the associated HscEnv
+ !originalHUG <- hsc_HUG <$> GHC.getSession
+ _ <- GHC.setProgramHUG (fmap deferTypeErrors originalHUG)
+ return originalHUG)
+ (\originalHUG ->
+ -- Restore the old 'DynFlags' for each home unit.
+ -- This makes sure that '-fdefer-type-errors' is unset again, iff it wasn't set before.
+ modifySession (hscUpdateHUG (restoreOriginalDynFlags originalHUG)))
(\_ -> load)
+ where
+ deferTypeErrors home_unit_env =
+ home_unit_env
+ { homeUnitEnv_dflags =
+ setGeneralFlag' Opt_DeferTypeErrors (homeUnitEnv_dflags home_unit_env)
+ }
+
+ restoreOriginalDynFlags (HUG.UnitEnvGraph old) (HUG.UnitEnvGraph new) = HUG.UnitEnvGraph $
+ M.unionWith (\b a ->
+ a { homeUnitEnv_dflags = homeUnitEnv_dflags b
+ })
+ old new
loadModule :: GhciMonad m => [(FilePath, Maybe UnitId, Maybe Phase)] -> m SuccessFlag
loadModule fs = do
@@ -1986,7 +2205,7 @@ loadModule fs = do
-- | @:load@ command
loadModule_ :: GhciMonad m => [FilePath] -> m ()
-loadModule_ fs = void $ loadModule (zip3 fs (repeat Nothing) (repeat Nothing))
+loadModule_ fs = void $ loadModule (zip3 fs (repeat (Just interactiveSessionUnitId)) (repeat Nothing))
loadModuleDefer :: GhciMonad m => [FilePath] -> m ()
loadModuleDefer = wrapDeferTypeErrors . loadModule_
@@ -2030,7 +2249,8 @@ addModule :: GhciMonad m => [FilePath] -> m ()
addModule files = do
revertCAFs -- always revert CAFs on load/add.
files' <- mapM expandPath files
- targets <- mapM (\m -> GHC.guessTarget m Nothing Nothing) files'
+ -- New targets are always added to the 'interactiveSessionUnitId' 'HomeUnitEnv'.
+ targets <- mapM (\m -> GHC.guessTarget m (Just interactiveSessionUnitId) Nothing) files'
targets' <- filterM checkTarget targets
-- remove old targets with the same id; e.g. for :add *M
mapM_ GHC.removeTarget [ tid | Target { targetId = tid } <- targets' ]
@@ -2063,7 +2283,8 @@ addModule files = do
unAddModule :: GhciMonad m => [FilePath] -> m ()
unAddModule files = do
files' <- mapM expandPath files
- targets <- mapM (\m -> GHC.guessTarget m Nothing Nothing) files'
+ -- New targets are always added to the 'interactiveSessionUnitId' 'HomeUnitEnv'.
+ targets <- mapM (\m -> GHC.guessTarget m (Just interactiveSessionUnitId) Nothing) files'
let removals = [ tid | Target { targetId = tid } <- targets ]
mapM_ GHC.removeTarget removals
_ <- doLoadAndCollectInfo (Unadd $ length removals) LoadAllTargets
@@ -2105,7 +2326,7 @@ doLoadAndCollectInfo load_type howmuch = do
-- MP: :set +c code path only works in single package mode atm, hence
-- this call to isLoaded is ok. collectInfo needs to be modified further to
-- work with :set +c so I have punted on that for now.
- loaded <- filterM GHC.isLoaded (map ms_mod_name mod_summaries)
+ loaded <- filterM GHC.isLoadedHomeModule (map ms_mod mod_summaries)
v <- mod_infos <$> getGHCiState
!newInfos <- collectInfo v loaded
modifyGHCiState (\st -> st { mod_infos = newInfos })
@@ -2187,7 +2408,7 @@ setContextAfterLoad keep_ctxt (Just graph) = do
-- We import the module with a * iff
-- - it is interpreted, and
-- - -XSafe is off (it doesn't allow *-imports)
- let new_ctx | star_ok = [mkIIModule (GHC.moduleName m)]
+ let new_ctx | star_ok = [mkIIModule m]
| otherwise = [mkIIDecl (GHC.moduleName m)]
setContextKeepingPackageModules keep_ctxt new_ctx
@@ -2607,7 +2828,7 @@ guessCurrentModule cmd = do
imports <- GHC.getContext
case imports of
[] -> throwGhcException $ CmdLineError (':' : cmd ++ ": no current module")
- IIModule m : _ -> GHC.findQualifiedModule NoPkgQual m
+ IIModule m : _ -> pure m
IIDecl d : _ -> do
pkgqual <- GHC.renameRawPkgQualM (unLoc $ ideclName d) (ideclPkgQual d)
GHC.findQualifiedModule pkgqual (unLoc (ideclName d))
@@ -2628,7 +2849,7 @@ browseModule bang modl exports_only = do
then pure $ GHC.modInfoExports mod_info
else do
hsc_env <- GHC.getSession
- mmod_env <- liftIO $ mkTopLevEnv hsc_env (moduleName modl)
+ mmod_env <- liftIO $ mkTopLevEnv hsc_env modl
case mmod_env of
Left err -> throwGhcException (CmdLineError (GHC.moduleNameString (GHC.moduleName modl) ++ " " ++ err))
Right mod_env -> pure $ map greName . globalRdrEnvElts $ mod_env
@@ -2737,8 +2958,9 @@ addModulesToContext starred unstarred = restoreContextOnFailure $ do
addModulesToContext_ :: GhciMonad m => [ModuleName] -> [ModuleName] -> m ()
addModulesToContext_ starred unstarred = do
- mapM_ addII (map mkIIModule starred ++ map mkIIDecl unstarred)
- setGHCContextFromGHCiState
+ starredModules <- traverse lookupModuleName starred
+ mapM_ addII (map mkIIModule starredModules ++ map mkIIDecl unstarred)
+ setGHCContextFromGHCiState
remModulesFromContext :: GhciMonad m => [ModuleName] -> [ModuleName] -> m ()
remModulesFromContext starred unstarred = do
@@ -2804,14 +3026,14 @@ checkAdd ii = do
dflags <- getDynFlags
let safe = safeLanguageOn dflags
case ii of
- IIModule modname
+ IIModule mod
| safe -> throwGhcException $ CmdLineError "can't use * imports with Safe Haskell"
- | otherwise -> wantInterpretedModuleName modname >> return ()
+ | otherwise -> checkInterpretedModule mod >> return ()
IIDecl d -> do
let modname = unLoc (ideclName d)
pkgqual <- GHC.renameRawPkgQualM modname (ideclPkgQual d)
- m <- GHC.lookupQualifiedModule pkgqual modname
+ m <- lookupQualifiedModuleName pkgqual modname
when safe $ do
t <- GHC.isModuleTrusted m
unless t $ throwGhcException $ ProgramError $ ""
@@ -2874,13 +3096,13 @@ getImplicitPreludeImports iidecls = do
-- -----------------------------------------------------------------------------
-- Utils on InteractiveImport
-mkIIModule :: ModuleName -> InteractiveImport
+mkIIModule :: Module -> InteractiveImport
mkIIModule = IIModule
mkIIDecl :: ModuleName -> InteractiveImport
mkIIDecl = IIDecl . simpleImportDecl
-iiModules :: [InteractiveImport] -> [ModuleName]
+iiModules :: [InteractiveImport] -> [Module]
iiModules is = [m | IIModule m <- is]
isIIModule :: InteractiveImport -> Bool
@@ -2888,7 +3110,7 @@ isIIModule (IIModule _) = True
isIIModule _ = False
iiModuleName :: InteractiveImport -> ModuleName
-iiModuleName (IIModule m) = m
+iiModuleName (IIModule m) = moduleName m
iiModuleName (IIDecl d) = unLoc (ideclName d)
preludeModuleName :: ModuleName
@@ -2990,8 +3212,23 @@ showOptions show_all
then text "none."
else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
))
- liftIO $ showDynFlags show_all dflags
-
+ mapNonInteractiveHomeUnitsM (liftIO . showDynFlags show_all)
+
+mapNonInteractiveHomeUnitsM :: GHC.GhcMonad m => (DynFlags -> m ()) -> m ()
+mapNonInteractiveHomeUnitsM printer = do
+ hug <- hsc_HUG <$> GHC.getSession
+ singleOrMultipleHomeUnits
+ $ map (\(uid, homeUnit) -> (uid, homeUnitEnv_dflags homeUnit))
+ $ filter (\(uid, _) -> uid /= interactiveSessionUnitId
+ && uid /= interactiveGhciUnitId)
+ $ HUG.unitEnv_assocs hug
+ where
+ singleOrMultipleHomeUnits [] =
+ liftIO $ putStrLn "GHCi: internal error - no home unit configured"
+ singleOrMultipleHomeUnits [(_, dflags)] = printer dflags
+ singleOrMultipleHomeUnits xs = mapM_ (\(uid, dflags) -> do
+ liftIO $ putStrLn (showSDoc dflags (text "Unit ID:" <+> ppr uid))
+ printer dflags) xs
showDynFlags :: Bool -> DynFlags -> IO ()
showDynFlags show_all dflags = do
@@ -3117,69 +3354,200 @@ setOptions wds =
-- then, dynamic flags
when (not (null minus_opts)) $ newDynFlags False minus_opts
--- | newDynFlags will *not* read package environment files, therefore we
--- use 'parseDynamicFlagsCmdLine' rather than 'parseDynamicFlags'. This
--- function is called very often and results in repeatedly loading
--- environment files (see #19650)
+-- Note [No unused package warnings for the interactive session]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- The interactive session (also called "interactive-prompt" occassionally) should not
+-- report unused packages, as it will essentially always report packages
+-- as unused.
+-- The "interactive-prompt" doesn't contain any 'Module's, so most packages
+-- are unused.
+-- As this would flood the user with warnings they can't do anything about,
+-- we decide to unconditionally turn off the warning 'Opt_WarnUnusedPackages'.
+--
+-- Unused packages in GHCi are still reported via the 'interactive-session' unit.
+-- See Note [Multiple Home Units aware GHCi] for an explanation about the
+-- "interactive-prompt" and 'interactive-session' unit.
+
+-- | 'newDynFlags' adds the given user options to the session.
+--
+-- If 'True' is passed, we add the options only to the interactive 'DynFlags'.
+-- Otherwise, the options are added to each 'HomeUnitEnv' in the current session.
+--
+-- This function will check whether we need to re-initialise the 'UnitState',
+-- for example when the user writes ':set -package containers'.
+--
+-- Any warnings during parsing, or validation of the new 'DynFlags' will be
+-- directly reported to the user.
newDynFlags :: GhciMonad m => Bool -> [String] -> m ()
newDynFlags interactive_only minus_opts = do
- let lopts = map noLoc minus_opts
+ let lopts = map noLoc minus_opts
- logger <- getLogger
- idflags0 <- GHC.getInteractiveDynFlags
- (idflags1, leftovers, warns) <- DynFlags.parseDynamicFlagsCmdLine logger idflags0 lopts
+ case interactive_only of
+ True -> addToInteractiveDynFlags lopts
+ False -> addToProgramDynFlags lopts
- liftIO $ printOrThrowDiagnostics logger (initPrintConfig idflags1) (initDiagOpts idflags1) (GhcDriverMessage <$> warns)
+ idflags <- hsc_dflags <$> GHC.getSession
+ installInteractivePrint (interactivePrint idflags) False
+
+-- | Add the given options to the interactive 'DynFlags'.
+-- This function will normalise and validate the 'DynFlags' and report warnings
+-- directly to the user.
+--
+-- Updates both the 'hsc_dflags' of 'HscEnv', and the 'ic_dflags' of the 'InteractiveContext'.
+--
+-- 'addToInteractiveDynFlags' will *not* read package environment files, therefore we
+-- use 'parseDynamicFlagsCmdLine' rather than 'parseDynamicFlags'. This
+-- function is called very often and results in repeatedly loading
+-- environment files (see #19650)
+addToInteractiveDynFlags :: GhciMonad m => [Located String] -> m ()
+addToInteractiveDynFlags lopts = do
+ logger <- getLogger
+ idflags0 <- hsc_dflags <$> GHC.getSession
+ (idflags1, leftovers, warns) <- DynFlags.parseDynamicFlagsCmdLine logger idflags0 lopts
+
+ liftIO $ printOrThrowDiagnostics logger (initPrintConfig idflags1) (initDiagOpts idflags1) (GhcDriverMessage <$> warns)
+ when (not $ null leftovers) (unknownFlagsErr $ map unLoc leftovers)
+
+ when (packageFlagsChanged idflags1 idflags0) $ do
+ liftIO $ hPutStrLn stderr "cannot set package flags with :seti; use :set"
+
+ GHC.setInteractiveDynFlags idflags1
+ idflags_norm <- ic_dflags . hsc_IC <$> GHC.getSession
+ -- TODO @fendor: why not 'setProgramHUG_'?
+ _ <- GHC.setProgramDynFlags idflags_norm
+ pure ()
+
+-- | Add the given options to all 'DynFlags' in the 'HomeUnitGraph'.
+-- This function will validate the 'DynFlags' and report warnings directly to the user.
+--
+-- We additionally normalise the 'DynFlags' for the 'interactiveGhciUnitId' for use
+-- in the 'InteractiveContext'.
+--
+-- 'addToProgramDynFlags' will *not* read package environment files, therefore we
+-- use 'parseDynamicFlagsCmdLine' rather than 'parseDynamicFlags'. This
+-- function is called very often and results in repeatedly loading
+-- environment files (see #19650)
+addToProgramDynFlags :: GhciMonad m => [Located String] -> m ()
+addToProgramDynFlags lopts = do
+ logger <- getLogger
+ initial_hug <- hsc_HUG <$> GHC.getSession
+ -- Update the 'DynFlags' of each 'HomeUnitEnv'.
+ -- Parse the new 'DynFlags', and report potential issues once.
+ -- Arguably, we may want to report issues for each non-builtin 'HomeUnitEnv'
+ -- individually.
+ updates <- HUG.unitEnv_traverseWithKey (\uid homeUnitEnv -> do
+ let oldFlags = HUG.homeUnitEnv_dflags homeUnitEnv
+ (newFlags, leftovers, warns) <- DynFlags.parseDynamicFlagsCmdLine logger oldFlags lopts
+ -- We only want to report inconsistencies and warnings once.
+ -- Thus, we do it only once for the 'interactiveGhciUnitId'
+ when (uid == interactiveGhciUnitId) $ do
+ liftIO $ printOrThrowDiagnostics logger (initPrintConfig newFlags) (initDiagOpts newFlags) (GhcDriverMessage <$> warns)
when (not $ null leftovers) (unknownFlagsErr $ map unLoc leftovers)
- when (interactive_only && packageFlagsChanged idflags1 idflags0) $ do
- liftIO $ hPutStrLn stderr "cannot set package flags with :seti; use :set"
- GHC.setInteractiveDynFlags idflags1
- installInteractivePrint (interactivePrint idflags1) False
-
- dflags0 <- getDynFlags
-
- when (not interactive_only) $ do
- (dflags1, _, _) <- liftIO $ DynFlags.parseDynamicFlagsCmdLine logger dflags0 lopts
- must_reload <- GHC.setProgramDynFlags dflags1
-
- -- if the package flags changed, reset the context and link
- -- the new packages.
- hsc_env <- GHC.getSession
- let dflags2 = hsc_dflags hsc_env
- let interp = hscInterp hsc_env
- when (packageFlagsChanged dflags2 dflags0) $ do
- when (verbosity dflags2 > 0) $
- liftIO . putStrLn $
- "package flags have changed, resetting and loading new packages..."
- -- Clear caches and eventually defined breakpoints. (#1620)
- clearCaches
- when must_reload $ do
- let units = preloadUnits (hsc_units hsc_env)
- liftIO $ Loader.loadPackages interp hsc_env units
- -- package flags changed, we can't re-use any of the old context
- setContextAfterLoad False Nothing
- -- and copy the package flags to the interactive DynFlags
- idflags <- GHC.getInteractiveDynFlags
- GHC.setInteractiveDynFlags
- idflags{ packageFlags = packageFlags dflags2 }
-
- let ld0length = length $ ldInputs dflags0
- fmrk0length = length $ cmdlineFrameworks dflags0
-
- newLdInputs = drop ld0length (ldInputs dflags2)
- newCLFrameworks = drop fmrk0length (cmdlineFrameworks dflags2)
-
- dflags' = dflags2 { ldInputs = newLdInputs
- , cmdlineFrameworks = newCLFrameworks
- }
- hsc_env' = hscSetFlags dflags' hsc_env
-
- when (not (null newLdInputs && null newCLFrameworks)) $
- liftIO $ Loader.loadCmdLineLibs (hscInterp hsc_env') hsc_env'
-
- return ()
+ -- Special Logic!
+ -- Currently, the interactive 'DynFlags' have additional restrictions,
+ -- for example modifying package flags is not supported!
+ -- The interactive 'DynFlags' get normalised to uphold this restriction.
+ -- As a special precaution, we also don't want to report unusued packages warnings
+ -- for the interactive session.
+ -- See Note [No unused package warnings for the interactive session]
+ --
+ -- See Note [Multiple Home Units aware GHCi] for details about how
+ -- the interactive session is structured.
+ newFlags' <-
+ if uid == interactiveGhciUnitId
+ then do
+ -- See Note [No unused package warnings for the interactive session]
+ let icdflags1 = wopt_unset newFlags Opt_WarnUnusedPackages
+ GHC.normaliseInteractiveDynFlags logger icdflags1
+ else
+ pure newFlags
+ pure (homeUnitEnv { homeUnitEnv_dflags = newFlags' })
+ )
+ initial_hug
+ -- Update the HUG! This might force us to reload the 'UnitState' of each 'HomeUnitEnv'
+ -- if package flags were changed.
+ must_reload <- GHC.setProgramHUG_ True updates
+
+ -- Initialise the Interactive DynFlags.
+ -- Sets the 'ic_dflags' and initialises the 'ic_plugins'.
+ -- See Note [Relation between the 'InteractiveContext' and 'interactiveGhciUnitId']
+ icdflags <- hsc_dflags <$> GHC.getSession
+ modifySessionM (GHC.initialiseInteractiveDynFlags icdflags)
+
+ -- if the package flags changed, reset the context and link
+ -- the new packages.
+ hsc_env <- GHC.getSession
+ let dflags2 = hsc_dflags hsc_env
+ when must_reload $ do
+ when (verbosity dflags2 > 0) $
+ liftIO . putStrLn $
+ "package flags have changed, resetting and loading new packages..."
+
+ -- Clear caches and eventually defined breakpoints. (#1620)
+ clearCaches
+ reloadPackages hsc_env
+
+ reloadLinkerOptions hsc_env initial_hug
+
+reloadPackages :: GhciMonad m => HscEnv -> m ()
+reloadPackages hsc_env = do
+ let
+ units =
+ concatMap (preloadUnits . HUG.homeUnitEnv_units)
+ (Foldable.toList $ hsc_HUG hsc_env)
+ liftIO $ Loader.loadPackages (hscInterp hsc_env) hsc_env units
+ -- package flags changed, we can't re-use any of the old context
+ setContextAfterLoad False Nothing
+
+-- | Reload the linker options.
+--
+-- Synopsis: @'reloadLinkerOptions' hsc_env old_hug@
+--
+-- After the HUG is modified, the linker may need to be reloaded.
+-- The linker is reloaded via 'loadCmdLineLibs', if the library inputs
+-- have changed.
+-- To determine whether the library inputs have changed, we need the
+-- old HUG, which is passed as the argument 'old_hug'.
+--
+-- This function will crash, if the 'old_hug' doesn't have exactly
+-- the same keys has the given 'hsc_env'. I.e.
+--
+-- @
+-- HUG.unitEnv_keys old_hug == HUG.unitEnv_keys (hsc_HUG hsc_env)
+-- @
+reloadLinkerOptions :: MonadIO m => HscEnv -> HomeUnitGraph -> m ()
+reloadLinkerOptions hsc_env old_hug = do
+ let
+ new_hug = hsc_HUG hsc_env
+ let
+ (needs_updates, updated_hug) = HUG.unitEnv_traverseWithKey (\key unitEnv ->
+ let
+ old_flags = homeUnitEnv_dflags (HUG.unitEnv_lookup key old_hug)
+ new_flags = homeUnitEnv_dflags unitEnv
+ ld0length = length $ ldInputs old_flags
+ fmrk0length = length $ cmdlineFrameworks old_flags
+
+ newLdInputs = drop ld0length (ldInputs new_flags)
+ newCLFrameworks = drop fmrk0length (cmdlineFrameworks new_flags)
+
+ dflags' = new_flags { ldInputs = newLdInputs
+ , cmdlineFrameworks = newCLFrameworks
+ }
+ in
+ (S.Any (not (null newLdInputs && null newCLFrameworks)),
+ unitEnv { homeUnitEnv_dflags = dflags' })
+ ) new_hug
+
+ hsc_env' =
+ hscSetActiveUnitId (hscActiveUnitId hsc_env)
+ $ hscUpdateHUG (const updated_hug)
+ $ hsc_env
+
+ when (S.getAny needs_updates) $
+ liftIO $ Loader.loadCmdLineLibs (hscInterp hsc_env') hsc_env'
unknownFlagsErr :: GhciMonad m => [String] -> m ()
unknownFlagsErr fs = mapM_ (\f -> reportError (GhciUnknownFlag f (suggestions f))) fs
@@ -3261,7 +3629,6 @@ showCmd "" = showOptions False
showCmd "-a" = showOptions True
showCmd str = do
st <- getGHCiState
- dflags <- getDynFlags
hsc_env <- GHC.getSession
let lookupCmd :: String -> Maybe (m ())
@@ -3299,8 +3666,10 @@ showCmd str = do
case words str of
[w] | Just action <- lookupCmd w -> action
- _ -> let helpCmds = [ text name | (True, name, _) <- cmds ]
- in throwGhcException $ CmdLineError $ showSDoc dflags
+ _ -> do
+ let helpCmds = [ text name | (True, name, _) <- cmds ]
+ dflags <- getDynFlags
+ throwGhcException $ CmdLineError $ showSDoc dflags
$ hang (text "syntax:") 4
$ hang (text ":show") 6
$ brackets (fsep $ punctuate (text " |") helpCmds)
@@ -3321,7 +3690,7 @@ showImports = do
trans_ctx = transient_ctx st
show_one (IIModule star_m)
- = ":module +*" ++ moduleNameString star_m
+ = ":module +*" ++ moduleNameString (moduleName star_m)
show_one (IIDecl imp) = showPpr dflags imp
prel_iidecls <- getImplicitPreludeImports (rem_ctx ++ trans_ctx)
@@ -3427,16 +3796,14 @@ pprStopped res =
mb_mod_name = moduleName <$> ibi_tick_mod <$> GHC.resumeBreakpointId res
showUnits :: GHC.GhcMonad m => m ()
-showUnits = do
- dflags <- getDynFlags
+showUnits = mapNonInteractiveHomeUnitsM $ \dflags -> do
let pkg_flags = packageFlags dflags
liftIO $ putStrLn $ showSDoc dflags $
text ("active package flags:"++if null pkg_flags then " none" else "") $$
nest 2 (vcat (map pprFlag pkg_flags))
showPaths :: GHC.GhcMonad m => m ()
-showPaths = do
- dflags <- getDynFlags
+showPaths = mapNonInteractiveHomeUnitsM $ \dflags -> do
liftIO $ do
cwd <- getCurrentDirectory
putStrLn $ showSDoc dflags $
@@ -3448,7 +3815,7 @@ showPaths = do
nest 2 (vcat (map text ipaths))
showLanguages :: GHC.GhcMonad m => m ()
-showLanguages = getDynFlags >>= liftIO . showLanguages' False
+showLanguages = mapNonInteractiveHomeUnitsM $ liftIO . showLanguages' False
showiLanguages :: GHC.GhcMonad m => m ()
showiLanguages = GHC.getInteractiveDynFlags >>= liftIO . showLanguages' False
@@ -3627,11 +3994,11 @@ completeBreakpoint = wrapCompleter spaces $ \w -> do -- #3000
filterM GHC.moduleIsInterpreted hmods
-- Return all possible bids for a given Module
- bidsByModule :: GhciMonad m => [ModuleName] -> Module -> m [String]
+ bidsByModule :: GhciMonad m => [Module] -> Module -> m [String]
bidsByModule nonquals mod = do
(_, decls) <- getModBreak mod
let bids = nub $ declPath <$> elems decls
- pure $ case (moduleName mod) `elem` nonquals of
+ pure $ case mod `elem` nonquals of
True -> bids
False -> (combineModIdent (showModule mod)) <$> bids
@@ -4036,8 +4403,7 @@ breakSwitch (arg1:rest)
| all isDigit arg1 = do
imports <- GHC.getContext
case iiModules imports of
- (mn : _) -> do
- md <- lookupModuleName mn
+ (md : _) -> do
breakByModuleLine md (read arg1) rest
[] -> do
liftIO $ putStrLn "No modules are loaded with debugging support."
@@ -4169,8 +4535,7 @@ list2 [arg] | all isDigit arg = do
case iiModules imports of
[] -> liftIO $ putStrLn "No module to list"
(mn : _) -> do
- md <- lookupModuleName mn
- listModuleLine md (read arg)
+ listModuleLine mn (read arg)
list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
md <- wantInterpretedModule arg1
listModuleLine md (read arg2)
@@ -4426,7 +4791,20 @@ lookupModule :: GHC.GhcMonad m => String -> m Module
lookupModule mName = lookupModuleName (GHC.mkModuleName mName)
lookupModuleName :: GHC.GhcMonad m => ModuleName -> m Module
-lookupModuleName mName = GHC.lookupQualifiedModule NoPkgQual mName
+lookupModuleName mName = lookupQualifiedModuleName NoPkgQual mName
+
+lookupQualifiedModuleName :: GHC.GhcMonad m => PkgQual -> ModuleName -> m Module
+lookupQualifiedModuleName qual modl = do
+ GHC.lookupAllQualifiedModuleNames qual modl >>= \case
+ [] -> throwGhcException (CmdLineError ("module '" ++ str ++ "' could not be found."))
+ [m] -> pure m
+ ms -> throwGhcException (CmdLineError ("module name '" ++ str ++ "' is ambiguous:\n" ++ errorMsg ms))
+ where
+ str = moduleNameString modl
+ errorMsg ms = intercalate "\n"
+ [ "- " ++ unitIdString (toUnitId (moduleUnit m)) ++ ":" ++ moduleNameString (moduleName m)
+ | m <- ms
+ ]
isMainUnitModule :: Module -> Bool
isMainUnitModule m = GHC.moduleUnit m == mainUnit
@@ -4476,15 +4854,19 @@ wantInterpretedModule str = wantInterpretedModuleName (GHC.mkModuleName str)
wantInterpretedModuleName :: GHC.GhcMonad m => ModuleName -> m Module
wantInterpretedModuleName modname = do
- modl <- lookupModuleName modname
- let str = moduleNameString modname
- home_unit <- hsc_home_unit <$> GHC.getSession
- unless (isHomeModule home_unit modl) $
- throwGhcException (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module"))
- is_interpreted <- GHC.moduleIsInterpreted modl
- when (not is_interpreted) $
- throwGhcException (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first"))
- return modl
+ modl <- lookupModuleName modname
+ checkInterpretedModule modl
+
+checkInterpretedModule :: GHC.GhcMonad m => Module -> m Module
+checkInterpretedModule modl = do
+ let str = moduleNameString $ moduleName modl
+ hug <- hsc_HUG <$> GHC.getSession
+ unless (HUG.memberHugUnit (moduleUnit modl) hug) $
+ throwGhcException (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module"))
+ is_interpreted <- GHC.moduleIsInterpreted modl
+ when (not is_interpreted) $
+ throwGhcException (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first"))
+ return modl
wantNameFromInterpretedModule :: GHC.GhcMonad m
=> (Name -> SDoc -> m ())
=====================================
ghc/GHCi/UI/Exception.hs
=====================================
@@ -465,7 +465,7 @@ instance DiagnosticCodeNameSpace GHCi where
type GhciDiagnosticCode :: Symbol -> Nat
type family GhciDiagnosticCode c = n | n -> c where
- GhciDiagnosticCode "GhciCommandNotSupportedInMultiMode" = 83514
+ GhciDiagnosticCode "GhciCommandNotSupportedInMultiMode" = Outdated 83514
GhciDiagnosticCode "GhciInvalidArgumentString" = 68894
GhciDiagnosticCode "GhciCommandSyntaxError" = 72682
GhciDiagnosticCode "GhciInvalidPromptString" = 50882
=====================================
ghc/GHCi/UI/Info.hs
=====================================
@@ -46,6 +46,7 @@ import GHC.Tc.Types
import GHC.Types.Name.Reader
import GHC.Types.Name.Set
import GHC.Utils.Outputable
+import GHC.Unit.Types
import GHC.Types.SrcLoc
import GHC.Types.Var
import qualified GHC.Data.Strict as Strict
@@ -113,7 +114,7 @@ srcSpanFilePath = unpackFS . srcSpanFile
-- | Try to find the location of the given identifier at the given
-- position in the module.
findLoc :: GhcMonad m
- => Map ModuleName ModInfo
+ => Map Module ModInfo
-> RealSrcSpan
-> String
-> ExceptT GhciModuleError m (ModInfo,Name,SrcSpan)
@@ -133,7 +134,7 @@ findLoc infos span0 string = do
-- | Find any uses of the given identifier in the codebase.
findNameUses :: (GhcMonad m)
- => Map ModuleName ModInfo
+ => Map Module ModInfo
-> RealSrcSpan
-> String
-> ExceptT GhciModuleError m [SrcSpan]
@@ -160,7 +161,7 @@ stripSurrounding xs = filter (not . isRedundant) xs
-- | Try to resolve the name located at the given position, or
-- otherwise resolve based on the current module's scope.
findName :: GhcMonad m
- => Map ModuleName ModInfo
+ => Map Module ModInfo
-> RealSrcSpan
-> ModInfo
-> String
@@ -186,11 +187,11 @@ findName infos span0 mi string =
-- | Try to resolve the name from another (loaded) module's exports.
resolveNameFromModule :: GhcMonad m
- => Map ModuleName ModInfo
+ => Map Module ModInfo
-> Name
-> ExceptT GhciModuleError m Name
resolveNameFromModule infos name = do
- info <- maybe (throwE $ GhciNoModuleForName name) pure (nameModule_maybe name >>= \modL -> M.lookup (moduleName modL) infos)
+ info <- maybe (throwE $ GhciNoModuleForName name) pure (nameModule_maybe name >>= \modL -> M.lookup modL infos)
let all_names = modInfo_rdrs info
maybe (throwE GhciNoMatchingModuleExport) pure $
find (matchName name) all_names
@@ -206,7 +207,7 @@ resolveName spans' si = listToMaybe $ mapMaybe spaninfoVar $
-- | Try to find the type of the given span.
findType :: GhcMonad m
- => Map ModuleName ModInfo
+ => Map Module ModInfo
-> RealSrcSpan
-> String
-> ExceptT GhciModuleError m (ModInfo, Type)
@@ -228,14 +229,14 @@ findType infos span0 string = do
-- | Guess a module name from a file path.
guessModule :: GhcMonad m
- => Map ModuleName ModInfo -> FilePath -> MaybeT m ModuleName
+ => Map Module ModInfo -> FilePath -> MaybeT m Module
guessModule infos fp = do
- target <- lift $ guessTarget fp Nothing Nothing
- case targetId target of
- TargetModule mn -> return mn
+ target <- lift $ guessTargetId fp
+ case target of
+ TargetModule mn -> MaybeT $ pure $ findModByModuleName mn
TargetFile fp' _ -> guessModule' fp'
where
- guessModule' :: GhcMonad m => FilePath -> MaybeT m ModuleName
+ guessModule' :: GhcMonad m => FilePath -> MaybeT m Module
guessModule' fp' = case findModByFp fp' of
Just mn -> return mn
Nothing -> do
@@ -243,19 +244,21 @@ guessModule infos fp = do
target' <- lift $ guessTarget fp'' Nothing Nothing
case targetId target' of
- TargetModule mn -> return mn
+ TargetModule mn -> return $ mkModule (RealUnit $ Definite $ targetUnitId target') mn
_ -> MaybeT . pure $ findModByFp fp''
- findModByFp :: FilePath -> Maybe ModuleName
+ findModByFp :: FilePath -> Maybe Module
findModByFp fp' = fst <$> find ((Just fp' ==) . mifp) (M.toList infos)
where
- mifp :: (ModuleName, ModInfo) -> Maybe FilePath
+ mifp :: (Module, ModInfo) -> Maybe FilePath
mifp = ml_hs_file . ms_location . modinfoSummary . snd
+ findModByModuleName :: ModuleName -> Maybe Module
+ findModByModuleName mn = find ((== mn) . moduleName) (M.keys infos)
-- | Collect type info data for the loaded modules.
-collectInfo :: (GhcMonad m) => Map ModuleName ModInfo -> [ModuleName]
- -> m (Map ModuleName ModInfo)
+collectInfo :: (GhcMonad m) => Map Module ModInfo -> [Module]
+ -> m (Map Module ModInfo)
collectInfo ms loaded = do
df <- getDynFlags
unit_state <- hsc_units <$> getSession
@@ -299,17 +302,17 @@ srcFilePath modSum = fromMaybe obj_fp src_fp
ms_loc = ms_location modSum
-- | Get info about the module: summary, types, etc.
-getModInfo :: (GhcMonad m) => ModuleName -> m ModInfo
-getModInfo name = do
- m <- getModSummary name
- p <- parseModule m
+getModInfo :: (GhcMonad m) => Module -> m ModInfo
+getModInfo m = do
+ mod_summary <- getModSummary m
+ p <- parseModule mod_summary
typechecked <- typecheckModule p
let allTypes = processAllTypeCheckedModule typechecked
let !rdr_env = tcg_rdr_env (fst $ tm_internals_ typechecked)
- ts <- liftIO $ getModificationTime $ srcFilePath m
+ ts <- liftIO $ getModificationTime $ srcFilePath mod_summary
return $
ModInfo
- { modinfoSummary = m
+ { modinfoSummary = mod_summary
, modinfoSpans = allTypes
, modinfoRdrEnv = forceGlobalRdrEnv rdr_env
, modinfoLastUpdate = ts
=====================================
ghc/GHCi/UI/Monad.hs
=====================================
@@ -91,7 +91,6 @@ data GHCiState = GHCiState
prompt_cont :: PromptFunction,
editor :: String,
stop :: String,
- multiMode :: Bool,
localConfig :: LocalConfigBehaviour,
options :: [GHCiOption],
line_number :: !Int, -- ^ input line
@@ -155,7 +154,7 @@ data GHCiState = GHCiState
long_help :: String,
lastErrorLocations :: IORef [(FastString, Int)],
- mod_infos :: !(Map ModuleName ModInfo),
+ mod_infos :: !(Map Module ModInfo),
flushStdHandles :: ForeignHValue,
-- ^ @hFlush stdout; hFlush stderr@ in the interpreter
=====================================
ghc/Main.hs
=====================================
@@ -302,7 +302,8 @@ ghciUI units srcs maybe_expr = do
[] -> return []
_ -> do
s <- initMake srcs
- return $ map (uncurry (,Nothing,)) s
+ dflags <- getDynFlags
+ return $ map (uncurry (,Just $ homeUnitId_ dflags,)) s
interactiveUI defaultGhciSettings hs_srcs maybe_expr
#endif
=====================================
testsuite/tests/linters/notes.stdout
=====================================
@@ -6,39 +6,37 @@ ref compiler/GHC/Core/Opt/Simplify/Iteration.hs:2556:55: Note [Plan (AFTE
ref compiler/GHC/Core/Opt/Simplify/Iteration.hs:2985:13: Note [Case binder next]
ref compiler/GHC/Core/Opt/Simplify/Iteration.hs:4345:8: Note [Lambda-bound unfoldings]
ref compiler/GHC/Core/Opt/Simplify/Utils.hs:1387:37: Note [Gentle mode]
-ref compiler/GHC/Core/Opt/Specialise.hs:1761:29: Note [Arity decrease]
+ref compiler/GHC/Core/Opt/Specialise.hs:1758:29: Note [Arity decrease]
ref compiler/GHC/Core/TyCo/Rep.hs:1783:31: Note [What prevents a constraint from floating]
-ref compiler/GHC/Driver/DynFlags.hs:1218:52: Note [Eta-reduction in -O0]
-ref compiler/GHC/Driver/Main.hs:1901:34: Note [simpleTidyPgm - mkBootModDetailsTc]
+ref compiler/GHC/Driver/DynFlags.hs:1217:52: Note [Eta-reduction in -O0]
+ref compiler/GHC/Driver/Main.hs:1886:34: Note [simpleTidyPgm - mkBootModDetailsTc]
ref compiler/GHC/Hs/Expr.hs:189:63: Note [Pending Splices]
-ref compiler/GHC/Hs/Expr.hs:2194:87: Note [Lifecycle of a splice]
-ref compiler/GHC/Hs/Expr.hs:2230:7: Note [Pending Splices]
-ref compiler/GHC/Hs/Extension.hs:148:5: Note [Strict argument type constraints]
+ref compiler/GHC/Hs/Expr.hs:2208:87: Note [Lifecycle of a splice]
+ref compiler/GHC/Hs/Expr.hs:2244:7: Note [Pending Splices]
+ref compiler/GHC/Hs/Extension.hs:151:5: Note [Strict argument type constraints]
ref compiler/GHC/Hs/Pat.hs:151:74: Note [Lifecycle of a splice]
ref compiler/GHC/HsToCore/Pmc/Solver.hs:860:20: Note [COMPLETE sets on data families]
ref compiler/GHC/HsToCore/Quote.hs:1533:7: Note [How brackets and nested splices are handled]
ref compiler/GHC/Stg/Unarise.hs:457:32: Note [Renaming during unarisation]
ref compiler/GHC/Tc/Gen/HsType.hs:563:56: Note [Skolem escape prevention]
-ref compiler/GHC/Tc/Gen/HsType.hs:2717:7: Note [Matching a kind signature with a declaration]
+ref compiler/GHC/Tc/Gen/HsType.hs:2718:7: Note [Matching a kind signature with a declaration]
ref compiler/GHC/Tc/Gen/Pat.hs:284:20: Note [Typing patterns in pattern bindings]
-ref compiler/GHC/Tc/Gen/Pat.hs:1378:7: Note [Matching polytyped patterns]
+ref compiler/GHC/Tc/Gen/Pat.hs:1380:7: Note [Matching polytyped patterns]
ref compiler/GHC/Tc/Gen/Sig.hs:91:10: Note [Overview of type signatures]
-ref compiler/GHC/Tc/Gen/Splice.hs:368:16: Note [How brackets and nested splices are handled]
-ref compiler/GHC/Tc/Gen/Splice.hs:543:35: Note [PendingRnSplice]
-ref compiler/GHC/Tc/Gen/Splice.hs:670:7: Note [How brackets and nested splices are handled]
+ref compiler/GHC/Tc/Gen/Splice.hs:367:16: Note [How brackets and nested splices are handled]
+ref compiler/GHC/Tc/Gen/Splice.hs:542:35: Note [PendingRnSplice]
+ref compiler/GHC/Tc/Gen/Splice.hs:669:7: Note [How brackets and nested splices are handled]
ref compiler/GHC/Tc/Gen/Splice.hs:909:11: Note [How brackets and nested splices are handled]
ref compiler/GHC/Tc/Instance/Family.hs:458:35: Note [Constrained family instances]
-ref compiler/GHC/Tc/Solver/Rewrite.hs:1015:7: Note [Stability of rewriting]
-ref compiler/GHC/Tc/TyCl.hs:1322:6: Note [Unification variables need fresh Names]
+ref compiler/GHC/Tc/Solver/Rewrite.hs:1020:7: Note [Stability of rewriting]
+ref compiler/GHC/Tc/TyCl.hs:1662:6: Note [Unification variables need fresh Names]
ref compiler/GHC/Tc/Types/Constraint.hs:209:9: Note [NonCanonical Semantics]
ref compiler/GHC/Types/Demand.hs:304:25: Note [Preserving Boxity of results is rarely a win]
-ref compiler/GHC/Unit/Module/Deps.hs:86:13: Note [Structure of dep_boot_mods]
+ref compiler/GHC/Unit/Module/Deps.hs:97:13: Note [Structure of dep_boot_mods]
ref compiler/GHC/Utils/Monad.hs:415:34: Note [multiShotIO]
ref compiler/Language/Haskell/Syntax/Binds.hs:206:31: Note [fun_id in Match]
ref configure.ac:205:10: Note [Linking ghc-bin against threaded stage0 RTS]
ref docs/core-spec/core-spec.mng:177:6: Note [TyBinders]
-ref ghc/GHCi/UI.hs:3292:17: Note [Multiple Home Units aware GHCi]
-ref ghc/GHCi/UI.hs:3292:17: Note [Relation between the InteractiveContext and 'interactiveGhciUnitId']
ref hadrian/src/Expression.hs:145:30: Note [Linking ghc-bin against threaded stage0 RTS]
ref linters/lint-notes/Notes.hs:32:29: Note [" <> T.unpack x <> "]
ref linters/lint-notes/Notes.hs:69:22: Note [...]
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/05f613722fd027733eff60dde2576b…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/05f613722fd027733eff60dde2576b…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/fendor/ghci-multiple-home-units] 4 commits: Add testcases for GHCi multiple home units
by Hannes Siebenhandl (＠fendor) 09 May '25
by Hannes Siebenhandl (＠fendor) 09 May '25
09 May '25
Hannes Siebenhandl pushed to branch wip/fendor/ghci-multiple-home-units at Glasgow Haskell Compiler / GHC
Commits:
84c07bc8 by fendor at 2025-05-09T16:32:06+02:00
Add testcases for GHCi multiple home units
Adds the following testcases:
* Evaluate code with a single home unit using 'initMulti' initialisation
logic
* More complicated testcase with multiple home units, testing reload
logic and code evaluation.
- - - - -
b085eedb by fendor at 2025-05-09T16:32:06+02:00
FIXME: these test cases can be fixed by exploiting internals
- - - - -
98b69d2d by fendor at 2025-05-09T16:32:32+02:00
Make GHCi commands compatible with multiple home units
=== Design
We enable all GHCi features that were previously guarded by the 'inMulti'
option.
GHCi supported multiple home units up to a certain degree for quite a while now.
The supported feature set was limited, due to a design impasse:
One of the home units must be "active", e.g., there must be one 'HomeUnit'
whose 'UnitId' is "active" which is returned when calling
```haskell
do
hscActiveUnitId <$> getSession
````
This makes sense in a GHC session, since you are always compiling a particular
Module, but it makes less intuitive sense in an interactive session.
Given an expression to evaluate, we can't easily tell in which "context" the expression
should be parsed, typechecked and evaluated.
That's why initially, most of GHCi features, except for `:reload`ing were disabled
if the GHCi session had more than one 'HomeUnitEnv'.
We lift this restriction, enabling all features of GHCi for the multiple home unit case.
To do this, we fundamentally change the 'HomeUnitEnv' graph to be multiple home unit first.
Instead of differentiating the case were we have a single home unit and multiple,
we now always set up a multiple home unit session that scales seamlessly to an arbitrary
amount of home units.
We introduce two new 'HomeUnitEnv's that are always added to the 'HomeUnitGraph'.
They are:
The "interactive-ghci", called the 'interactiveGhciUnit', contains the same
'DynFlags' that are used by the 'InteractiveContext' for interactive evaluation
of expressions.
This 'HomeUnitEnv' is only used on the prompt of GHCi, so we may refer to it as
"interactive-prompt" unit.
See Note [Relation between the 'InteractiveContext' and 'interactiveGhciUnitId']
for discussing its role.
And the 'interactive-session', called 'interactiveSessionUnit' or
'interactiveSessionUnitId', which is used for loading Scripts into
GHCi that are not 'Target's of any home unit, via `:load` or `:add`.
Both of these "interactive" home units depend on all other 'HomeUnitEnv's that
are passed as arguments on the cli.
Additionally, the "interactive-ghci" unit depends on 'interactive-session'.
We always evaluate expressions in the context of the
"interactive-ghci" session.
Since "interactive-ghci" depends on all home units, we can import any 'Module'
from the other home units with ease.
As we have a clear 'HomeUnitGraph' hierarchy, we can set 'interactiveGhciUnitId'
as the active home unit for the full duration of the GHCi session.
In GHCi, we always set 'interactiveGhciUnitId' to be the currently active home unit.
=== Implementation Details
Given this design idea, the implementation is relatively straight
forward.
The core insight is that a 'ModuleName' is not sufficient to identify a
'Module' in the 'HomeUnitGraph'. Thus, large parts of the PR is simply
about refactoring usages of 'ModuleName' to prefer 'Module', which as a
'Unit' and is unique over the 'HomeUnitGraph'.
Consequentially, most usages of `lookupHPT` are likely to be incorrect and have
been replaced by `lookupHugByModule` which is keyed by a 'Module'.
In GHCi/UI.hs, we make sure there is only one location where we are
actually translating `ModuleName` to a `Module`:
* `lookupQualifiedModuleName`
If a `ModuleName` is ambiguous, we detect this and report it to the
user.
To avoid repeated lookups of `ModuleName`s, we store the `Module` in the
`InteractiveImport`, which additionally simplifies the interface
loading.
A subtle detail is that the `DynFlags` of the `InteractiveContext` are
now stored both in the `HomeUnitGraph` and in the `InteractiveContext`.
In UI.hs, there are multiple code paths where we are careful to update
the `DynFlags` in both locations.
Most importantly in `addToProgramDynFlags`.
---
There is one metric increase in this commit:
-------------------------
Metric Increase:
T4029
-------------------------
It is an increase from 14.4 MB to 16.1 MB (+11.8%) which sounds like a
pretty big regression at first.
However, we argue this increase is solely caused by using more data
structures for managing multiple home units in the GHCi session.
In particular, due to the design decision of using three home units, the
base memory usage increases... but by how much?
A big contributor is the `UnitState`, of which we have three now, which
on its own 260 KB per instance. That makes an additional memory usage of
520 KB, already explaining a third of the overall memory usage increase.
Then we store more elements in the `HomeUnitGraph`, we have more
`HomeUnitEnv` entries, etc...
While we didn't chase down each byte, we looked at the memory usage over time
for both '-hi' and '-hT' profiles and can say with confidence while the memory
usage increased slightly, we did not introduce any space leak, as
the graph looks almost identical as the memory usage graph of GHC HEAD.
- - - - -
05f61372 by fendor at 2025-05-09T16:51:41+02:00
FIXUP: Multiple Home Units is no longer a special case
- - - - -
125 changed files:
- compiler/GHC.hs
- compiler/GHC/Driver/Downsweep.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Rename/Unbound.hs
- compiler/GHC/Runtime/Context.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/StgToByteCode.hs
- compiler/GHC/StgToJS/Linker/Linker.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Types/Name/Ppr.hs
- compiler/GHC/Unit/Env.hs
- compiler/GHC/Unit/Home/Graph.hs
- compiler/GHC/Unit/Types.hs
- ghc/GHCi/UI.hs
- ghc/GHCi/UI/Exception.hs
- ghc/GHCi/UI/Info.hs
- ghc/GHCi/UI/Monad.hs
- ghc/Main.hs
- testsuite/driver/testlib.py
- testsuite/tests/backpack/cabal/bkpcabal08/bkpcabal08.stdout
- testsuite/tests/driver/T8526/T8526.stdout
- testsuite/tests/driver/fat-iface/fat014.stdout
- testsuite/tests/driver/multipleHomeUnits/multiGHCi.stderr
- testsuite/tests/ghc-api/T6145.hs
- testsuite/tests/ghc-api/annotations-literals/literals.hs
- testsuite/tests/ghc-api/annotations-literals/parsed.hs
- testsuite/tests/ghc-api/apirecomp001/myghc.hs
- testsuite/tests/ghc-api/fixed-nodes/T1.hs
- + testsuite/tests/ghci.debugger/scripts/break031/Makefile
- + testsuite/tests/ghci.debugger/scripts/break031/a/A.hs
- + testsuite/tests/ghci.debugger/scripts/break031/all.T
- + testsuite/tests/ghci.debugger/scripts/break031/b/B.hs
- + testsuite/tests/ghci.debugger/scripts/break031/break031a.script
- + testsuite/tests/ghci.debugger/scripts/break031/break031a.stdout
- + testsuite/tests/ghci.debugger/scripts/break031/break031b.script
- + testsuite/tests/ghci.debugger/scripts/break031/break031b.stderr
- + testsuite/tests/ghci.debugger/scripts/break031/break031b.stdout
- + testsuite/tests/ghci.debugger/scripts/break031/unitA
- + testsuite/tests/ghci.debugger/scripts/break031/unitB
- testsuite/tests/ghci/linking/dyn/T3372.hs
- + testsuite/tests/ghci/prog-mhu001/Makefile
- + testsuite/tests/ghci/prog-mhu001/all.T
- + testsuite/tests/ghci/prog-mhu001/e/E.hs
- + testsuite/tests/ghci/prog-mhu001/prog-mhu001a.script
- + testsuite/tests/ghci/prog-mhu001/prog-mhu001a.stdout
- + testsuite/tests/ghci/prog-mhu001/prog-mhu001b.script
- + testsuite/tests/ghci/prog-mhu001/prog-mhu001b.stdout
- + testsuite/tests/ghci/prog-mhu001/prog-mhu001c.script
- + testsuite/tests/ghci/prog-mhu001/prog-mhu001c.stdout
- + testsuite/tests/ghci/prog-mhu001/prog-mhu001d.script
- + testsuite/tests/ghci/prog-mhu001/prog-mhu001d.stdout
- + testsuite/tests/ghci/prog-mhu001/prog-mhu001e.script
- + testsuite/tests/ghci/prog-mhu001/prog-mhu001e.stdout
- + testsuite/tests/ghci/prog-mhu001/prog-mhu001f.script
- + testsuite/tests/ghci/prog-mhu001/prog-mhu001f.stdout
- + testsuite/tests/ghci/prog-mhu001/unitE
- + testsuite/tests/ghci/prog-mhu001/unitE-main-is
- + testsuite/tests/ghci/prog-mhu002/Makefile
- + testsuite/tests/ghci/prog-mhu002/a/A.hs
- + testsuite/tests/ghci/prog-mhu002/all.T
- + testsuite/tests/ghci/prog-mhu002/b/B.hs
- + testsuite/tests/ghci/prog-mhu002/c/C.hs
- + testsuite/tests/ghci/prog-mhu002/d/Main.hs
- + testsuite/tests/ghci/prog-mhu002/prog-mhu002a.script
- + testsuite/tests/ghci/prog-mhu002/prog-mhu002a.stderr
- + testsuite/tests/ghci/prog-mhu002/prog-mhu002a.stdout
- + testsuite/tests/ghci/prog-mhu002/prog-mhu002b.script
- + testsuite/tests/ghci/prog-mhu002/prog-mhu002b.stderr
- + testsuite/tests/ghci/prog-mhu002/prog-mhu002b.stdout
- + testsuite/tests/ghci/prog-mhu002/prog-mhu002c.script
- + testsuite/tests/ghci/prog-mhu002/prog-mhu002c.stdout
- + testsuite/tests/ghci/prog-mhu002/prog-mhu002d.script
- + testsuite/tests/ghci/prog-mhu002/prog-mhu002d.stdout
- + testsuite/tests/ghci/prog-mhu002/prog-mhu002e.script
- + testsuite/tests/ghci/prog-mhu002/prog-mhu002e.stdout
- + testsuite/tests/ghci/prog-mhu002/prog-mhu002f.script
- + testsuite/tests/ghci/prog-mhu002/prog-mhu002f.stdout
- + testsuite/tests/ghci/prog-mhu002/unitA
- + testsuite/tests/ghci/prog-mhu002/unitB
- + testsuite/tests/ghci/prog-mhu002/unitC
- + testsuite/tests/ghci/prog-mhu002/unitD
- + testsuite/tests/ghci/prog-mhu003/Makefile
- + testsuite/tests/ghci/prog-mhu003/a/A.hs
- + testsuite/tests/ghci/prog-mhu003/all.T
- + testsuite/tests/ghci/prog-mhu003/b/Foo.hs
- + testsuite/tests/ghci/prog-mhu003/c/C.hs
- + testsuite/tests/ghci/prog-mhu003/d/Foo.hs
- + testsuite/tests/ghci/prog-mhu003/prog-mhu003.script
- + testsuite/tests/ghci/prog-mhu003/prog-mhu003.stderr
- + testsuite/tests/ghci/prog-mhu003/prog-mhu003.stdout
- + testsuite/tests/ghci/prog-mhu003/unitA
- + testsuite/tests/ghci/prog-mhu003/unitB
- + testsuite/tests/ghci/prog-mhu003/unitC
- + testsuite/tests/ghci/prog-mhu003/unitD
- + testsuite/tests/ghci/prog-mhu004/Makefile
- + testsuite/tests/ghci/prog-mhu004/a/Foo.hs
- + testsuite/tests/ghci/prog-mhu004/all.T
- + testsuite/tests/ghci/prog-mhu004/b/Foo.hs
- + testsuite/tests/ghci/prog-mhu004/prog-mhu004a.script
- + testsuite/tests/ghci/prog-mhu004/prog-mhu004a.stderr
- + testsuite/tests/ghci/prog-mhu004/prog-mhu004a.stdout
- + testsuite/tests/ghci/prog-mhu004/prog-mhu004b.script
- + testsuite/tests/ghci/prog-mhu004/prog-mhu004b.stdout
- + testsuite/tests/ghci/prog-mhu004/unitA
- + testsuite/tests/ghci/prog-mhu004/unitB
- testsuite/tests/ghci/prog010/ghci.prog010.script
- testsuite/tests/ghci/prog018/prog018.stdout
- testsuite/tests/ghci/scripts/T13869.stdout
- testsuite/tests/ghci/scripts/T13997.stdout
- testsuite/tests/ghci/scripts/T17669.stdout
- testsuite/tests/ghci/scripts/T18330.stdout
- testsuite/tests/ghci/scripts/T1914.stdout
- testsuite/tests/ghci/scripts/T20217.stdout
- testsuite/tests/ghci/scripts/T20587.stdout
- testsuite/tests/ghci/scripts/T21110.stderr
- testsuite/tests/ghci/scripts/T6105.stdout
- testsuite/tests/ghci/scripts/T8042.stdout
- testsuite/tests/ghci/scripts/T8042recomp.stdout
- testsuite/tests/ghci/scripts/ghci024.stdout
- testsuite/tests/ghci/scripts/ghci024.stdout-mingw32
- testsuite/tests/ghci/scripts/ghci058.script
- testsuite/tests/ghci/should_run/TopEnvIface.stdout
- testsuite/tests/linters/notes.stdout
- testsuite/tests/quasiquotation/T7918.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/387db53797e8dc894278823f4b29fd…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/387db53797e8dc894278823f4b29fd…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/andreask/interpreter_primops] Interpreter: Add limited support for direct primop evaluation.
by Andreas Klebinger (＠AndreasK) 09 May '25
by Andreas Klebinger (＠AndreasK) 09 May '25
09 May '25
Andreas Klebinger pushed to branch wip/andreask/interpreter_primops at Glasgow Haskell Compiler / GHC
Commits:
13b97782 by Andreas Klebinger at 2025-05-09T14:10:29+02:00
Interpreter: Add limited support for direct primop evaluation.
This commit adds support for a number of primops directly
to the interpreter. This avoids the indirection of going
through the primop wrapper for those primops speeding interpretation
of optimized code up massively.
Code involving IntSet runs about 25% faster with optimized core and these
changes. For core without breakpoints it's even more pronouced and I
saw reductions in runtime by up to 50%.
Running GHC itself in the interpreter was sped up by ~15% through this
change.
Additionally this comment does a few other related changes:
testsuite:
* Run foundation test in ghci and ghci-opt ways to test these
primops.
* Vastly expand the foundation test to cover all basic primops
by comparing result with the result of calling the wrapper.
Interpreter:
* When pushing arguments for interpreted primops extend each argument to
at least word with when pushing. This avoids some issues with big
endian. We can revisit this if it causes performance issues.
* Restructure the stack chunk check logic. There are now macros for
read accesses which might cross stack chunk boundries and macros which
omit the checks which are used when we statically know we access an
address in the current stack chunk.
- - - - -
17 changed files:
- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/ByteCode/Asm.hs
- compiler/GHC/ByteCode/Instr.hs
- compiler/GHC/StgToByteCode.hs
- rts/Disassembler.c
- rts/Interpreter.c
- rts/include/rts/Bytecodes.h
- testsuite/tests/codeGen/should_run/all.T
- + testsuite/tests/ghci/all.T
- + testsuite/tests/ghci/ghci-mem-primops.hs
- + testsuite/tests/ghci/ghci-mem-primops.script
- + testsuite/tests/ghci/ghci-mem-primops.stdout
- testsuite/tests/numeric/should_run/all.T
- testsuite/tests/numeric/should_run/foundation.hs
- testsuite/tests/numeric/should_run/foundation.stdout
- utils/genprimopcode/Main.hs
- utils/genprimopcode/Syntax.hs
Changes:
=====================================
compiler/GHC/Builtin/primops.txt.pp
=====================================
@@ -147,6 +147,7 @@ defaults
fixity = Nothing
vector = []
deprecated_msg = {} -- A non-empty message indicates deprecation
+ div_like = False -- Second argument expected to be non zero - used for tests
-- Note [When do out-of-line primops go in primops.txt.pp]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -296,14 +297,18 @@ primop Int8MulOp "timesInt8#" GenPrimOp Int8# -> Int8# -> Int8#
primop Int8QuotOp "quotInt8#" GenPrimOp Int8# -> Int8# -> Int8#
with
effect = CanFail
+ div_like = True
primop Int8RemOp "remInt8#" GenPrimOp Int8# -> Int8# -> Int8#
with
effect = CanFail
+ div_like = True
+
primop Int8QuotRemOp "quotRemInt8#" GenPrimOp Int8# -> Int8# -> (# Int8#, Int8# #)
with
effect = CanFail
+ div_like = True
primop Int8SllOp "uncheckedShiftLInt8#" GenPrimOp Int8# -> Int# -> Int8#
primop Int8SraOp "uncheckedShiftRAInt8#" GenPrimOp Int8# -> Int# -> Int8#
@@ -342,14 +347,17 @@ primop Word8MulOp "timesWord8#" GenPrimOp Word8# -> Word8# -> Word8#
primop Word8QuotOp "quotWord8#" GenPrimOp Word8# -> Word8# -> Word8#
with
effect = CanFail
+ div_like = True
primop Word8RemOp "remWord8#" GenPrimOp Word8# -> Word8# -> Word8#
with
effect = CanFail
+ div_like = True
primop Word8QuotRemOp "quotRemWord8#" GenPrimOp Word8# -> Word8# -> (# Word8#, Word8# #)
with
effect = CanFail
+ div_like = True
primop Word8AndOp "andWord8#" GenPrimOp Word8# -> Word8# -> Word8#
with commutable = True
@@ -400,14 +408,17 @@ primop Int16MulOp "timesInt16#" GenPrimOp Int16# -> Int16# -> Int16#
primop Int16QuotOp "quotInt16#" GenPrimOp Int16# -> Int16# -> Int16#
with
effect = CanFail
+ div_like = True
primop Int16RemOp "remInt16#" GenPrimOp Int16# -> Int16# -> Int16#
with
effect = CanFail
+ div_like = True
primop Int16QuotRemOp "quotRemInt16#" GenPrimOp Int16# -> Int16# -> (# Int16#, Int16# #)
with
effect = CanFail
+ div_like = True
primop Int16SllOp "uncheckedShiftLInt16#" GenPrimOp Int16# -> Int# -> Int16#
primop Int16SraOp "uncheckedShiftRAInt16#" GenPrimOp Int16# -> Int# -> Int16#
@@ -446,14 +457,17 @@ primop Word16MulOp "timesWord16#" GenPrimOp Word16# -> Word16# -> Word16#
primop Word16QuotOp "quotWord16#" GenPrimOp Word16# -> Word16# -> Word16#
with
effect = CanFail
+ div_like = True
primop Word16RemOp "remWord16#" GenPrimOp Word16# -> Word16# -> Word16#
with
effect = CanFail
+ div_like = True
primop Word16QuotRemOp "quotRemWord16#" GenPrimOp Word16# -> Word16# -> (# Word16#, Word16# #)
with
effect = CanFail
+ div_like = True
primop Word16AndOp "andWord16#" GenPrimOp Word16# -> Word16# -> Word16#
with commutable = True
@@ -504,14 +518,17 @@ primop Int32MulOp "timesInt32#" GenPrimOp Int32# -> Int32# -> Int32#
primop Int32QuotOp "quotInt32#" GenPrimOp Int32# -> Int32# -> Int32#
with
effect = CanFail
+ div_like = True
primop Int32RemOp "remInt32#" GenPrimOp Int32# -> Int32# -> Int32#
with
effect = CanFail
+ div_like = True
primop Int32QuotRemOp "quotRemInt32#" GenPrimOp Int32# -> Int32# -> (# Int32#, Int32# #)
with
effect = CanFail
+ div_like = True
primop Int32SllOp "uncheckedShiftLInt32#" GenPrimOp Int32# -> Int# -> Int32#
primop Int32SraOp "uncheckedShiftRAInt32#" GenPrimOp Int32# -> Int# -> Int32#
@@ -550,14 +567,17 @@ primop Word32MulOp "timesWord32#" GenPrimOp Word32# -> Word32# -> Word32#
primop Word32QuotOp "quotWord32#" GenPrimOp Word32# -> Word32# -> Word32#
with
effect = CanFail
+ div_like = True
primop Word32RemOp "remWord32#" GenPrimOp Word32# -> Word32# -> Word32#
with
effect = CanFail
+ div_like = True
primop Word32QuotRemOp "quotRemWord32#" GenPrimOp Word32# -> Word32# -> (# Word32#, Word32# #)
with
effect = CanFail
+ div_like = True
primop Word32AndOp "andWord32#" GenPrimOp Word32# -> Word32# -> Word32#
with commutable = True
@@ -608,10 +628,12 @@ primop Int64MulOp "timesInt64#" GenPrimOp Int64# -> Int64# -> Int64#
primop Int64QuotOp "quotInt64#" GenPrimOp Int64# -> Int64# -> Int64#
with
effect = CanFail
+ div_like = True
primop Int64RemOp "remInt64#" GenPrimOp Int64# -> Int64# -> Int64#
with
effect = CanFail
+ div_like = True
primop Int64SllOp "uncheckedIShiftL64#" GenPrimOp Int64# -> Int# -> Int64#
primop Int64SraOp "uncheckedIShiftRA64#" GenPrimOp Int64# -> Int# -> Int64#
@@ -650,10 +672,12 @@ primop Word64MulOp "timesWord64#" GenPrimOp Word64# -> Word64# -> Word64#
primop Word64QuotOp "quotWord64#" GenPrimOp Word64# -> Word64# -> Word64#
with
effect = CanFail
+ div_like = True
primop Word64RemOp "remWord64#" GenPrimOp Word64# -> Word64# -> Word64#
with
effect = CanFail
+ div_like = True
primop Word64AndOp "and64#" GenPrimOp Word64# -> Word64# -> Word64#
with commutable = True
@@ -737,6 +761,7 @@ primop IntQuotOp "quotInt#" GenPrimOp
zero.
}
with effect = CanFail
+ div_like = True
primop IntRemOp "remInt#" GenPrimOp
Int# -> Int# -> Int#
@@ -744,11 +769,13 @@ primop IntRemOp "remInt#" GenPrimOp
behavior is undefined if the second argument is zero.
}
with effect = CanFail
+ div_like = True
primop IntQuotRemOp "quotRemInt#" GenPrimOp
Int# -> Int# -> (# Int#, Int# #)
{Rounds towards zero.}
with effect = CanFail
+ div_like = True
primop IntAndOp "andI#" GenPrimOp Int# -> Int# -> Int#
{Bitwise "and".}
@@ -886,19 +913,23 @@ primop WordMul2Op "timesWord2#" GenPrimOp
primop WordQuotOp "quotWord#" GenPrimOp Word# -> Word# -> Word#
with effect = CanFail
+ div_like = True
primop WordRemOp "remWord#" GenPrimOp Word# -> Word# -> Word#
with effect = CanFail
+ div_like = True
primop WordQuotRemOp "quotRemWord#" GenPrimOp
Word# -> Word# -> (# Word#, Word# #)
with effect = CanFail
+ div_like = True
primop WordQuotRem2Op "quotRemWord2#" GenPrimOp
Word# -> Word# -> Word# -> (# Word#, Word# #)
{ Takes high word of dividend, then low word of dividend, then divisor.
Requires that high word < divisor.}
with effect = CanFail
+ div_like = True
primop WordAndOp "and#" GenPrimOp Word# -> Word# -> Word#
with commutable = True
@@ -4166,6 +4197,7 @@ primop VecQuotOp "quot#" GenPrimOp
Do not expect high performance. }
with effect = CanFail
vector = INT_VECTOR_TYPES
+ div_like = True
primop VecRemOp "rem#" GenPrimOp
VECTOR -> VECTOR -> VECTOR
@@ -4175,6 +4207,8 @@ primop VecRemOp "rem#" GenPrimOp
Do not expect high performance. }
with effect = CanFail
vector = INT_VECTOR_TYPES
+ div_like = True
+
primop VecNegOp "negate#" GenPrimOp
VECTOR -> VECTOR
=====================================
compiler/GHC/ByteCode/Asm.hs
=====================================
@@ -732,6 +732,143 @@ assembleI platform i = case i of
CCALL off m_addr i -> do np <- addr m_addr
emit_ bci_CCALL [wOp off, Op np, SmallOp i]
PRIMCALL -> emit_ bci_PRIMCALL []
+
+ OP_ADD w -> case w of
+ W64 -> emit_ bci_OP_ADD_64 []
+ W32 -> emit_ bci_OP_ADD_32 []
+ W16 -> emit_ bci_OP_ADD_16 []
+ W8 -> emit_ bci_OP_ADD_08 []
+ _ -> unsupported_width
+ OP_SUB w -> case w of
+ W64 -> emit_ bci_OP_SUB_64 []
+ W32 -> emit_ bci_OP_SUB_32 []
+ W16 -> emit_ bci_OP_SUB_16 []
+ W8 -> emit_ bci_OP_SUB_08 []
+ _ -> unsupported_width
+ OP_AND w -> case w of
+ W64 -> emit_ bci_OP_AND_64 []
+ W32 -> emit_ bci_OP_AND_32 []
+ W16 -> emit_ bci_OP_AND_16 []
+ W8 -> emit_ bci_OP_AND_08 []
+ _ -> unsupported_width
+ OP_XOR w -> case w of
+ W64 -> emit_ bci_OP_XOR_64 []
+ W32 -> emit_ bci_OP_XOR_32 []
+ W16 -> emit_ bci_OP_XOR_16 []
+ W8 -> emit_ bci_OP_XOR_08 []
+ _ -> unsupported_width
+ OP_OR w -> case w of
+ W64 -> emit_ bci_OP_OR_64 []
+ W32 -> emit_ bci_OP_OR_32 []
+ W16 -> emit_ bci_OP_OR_16 []
+ W8 -> emit_ bci_OP_OR_08 []
+ _ -> unsupported_width
+ OP_NOT w -> case w of
+ W64 -> emit_ bci_OP_NOT_64 []
+ W32 -> emit_ bci_OP_NOT_32 []
+ W16 -> emit_ bci_OP_NOT_16 []
+ W8 -> emit_ bci_OP_NOT_08 []
+ _ -> unsupported_width
+ OP_NEG w -> case w of
+ W64 -> emit_ bci_OP_NEG_64 []
+ W32 -> emit_ bci_OP_NEG_32 []
+ W16 -> emit_ bci_OP_NEG_16 []
+ W8 -> emit_ bci_OP_NEG_08 []
+ _ -> unsupported_width
+ OP_MUL w -> case w of
+ W64 -> emit_ bci_OP_MUL_64 []
+ W32 -> emit_ bci_OP_MUL_32 []
+ W16 -> emit_ bci_OP_MUL_16 []
+ W8 -> emit_ bci_OP_MUL_08 []
+ _ -> unsupported_width
+ OP_SHL w -> case w of
+ W64 -> emit_ bci_OP_SHL_64 []
+ W32 -> emit_ bci_OP_SHL_32 []
+ W16 -> emit_ bci_OP_SHL_16 []
+ W8 -> emit_ bci_OP_SHL_08 []
+ _ -> unsupported_width
+ OP_ASR w -> case w of
+ W64 -> emit_ bci_OP_ASR_64 []
+ W32 -> emit_ bci_OP_ASR_32 []
+ W16 -> emit_ bci_OP_ASR_16 []
+ W8 -> emit_ bci_OP_ASR_08 []
+ _ -> unsupported_width
+ OP_LSR w -> case w of
+ W64 -> emit_ bci_OP_LSR_64 []
+ W32 -> emit_ bci_OP_LSR_32 []
+ W16 -> emit_ bci_OP_LSR_16 []
+ W8 -> emit_ bci_OP_LSR_08 []
+ _ -> unsupported_width
+
+ OP_NEQ w -> case w of
+ W64 -> emit_ bci_OP_NEQ_64 []
+ W32 -> emit_ bci_OP_NEQ_32 []
+ W16 -> emit_ bci_OP_NEQ_16 []
+ W8 -> emit_ bci_OP_NEQ_08 []
+ _ -> unsupported_width
+ OP_EQ w -> case w of
+ W64 -> emit_ bci_OP_EQ_64 []
+ W32 -> emit_ bci_OP_EQ_32 []
+ W16 -> emit_ bci_OP_EQ_16 []
+ W8 -> emit_ bci_OP_EQ_08 []
+ _ -> unsupported_width
+
+ OP_U_LT w -> case w of
+ W64 -> emit_ bci_OP_U_LT_64 []
+ W32 -> emit_ bci_OP_U_LT_32 []
+ W16 -> emit_ bci_OP_U_LT_16 []
+ W8 -> emit_ bci_OP_U_LT_08 []
+ _ -> unsupported_width
+ OP_S_LT w -> case w of
+ W64 -> emit_ bci_OP_S_LT_64 []
+ W32 -> emit_ bci_OP_S_LT_32 []
+ W16 -> emit_ bci_OP_S_LT_16 []
+ W8 -> emit_ bci_OP_S_LT_08 []
+ _ -> unsupported_width
+ OP_U_GE w -> case w of
+ W64 -> emit_ bci_OP_U_GE_64 []
+ W32 -> emit_ bci_OP_U_GE_32 []
+ W16 -> emit_ bci_OP_U_GE_16 []
+ W8 -> emit_ bci_OP_U_GE_08 []
+ _ -> unsupported_width
+ OP_S_GE w -> case w of
+ W64 -> emit_ bci_OP_S_GE_64 []
+ W32 -> emit_ bci_OP_S_GE_32 []
+ W16 -> emit_ bci_OP_S_GE_16 []
+ W8 -> emit_ bci_OP_S_GE_08 []
+ _ -> unsupported_width
+ OP_U_GT w -> case w of
+ W64 -> emit_ bci_OP_U_GT_64 []
+ W32 -> emit_ bci_OP_U_GT_32 []
+ W16 -> emit_ bci_OP_U_GT_16 []
+ W8 -> emit_ bci_OP_U_GT_08 []
+ _ -> unsupported_width
+ OP_S_GT w -> case w of
+ W64 -> emit_ bci_OP_S_GT_64 []
+ W32 -> emit_ bci_OP_S_GT_32 []
+ W16 -> emit_ bci_OP_S_GT_16 []
+ W8 -> emit_ bci_OP_S_GT_08 []
+ _ -> unsupported_width
+ OP_U_LE w -> case w of
+ W64 -> emit_ bci_OP_U_LE_64 []
+ W32 -> emit_ bci_OP_U_LE_32 []
+ W16 -> emit_ bci_OP_U_LE_16 []
+ W8 -> emit_ bci_OP_U_LE_08 []
+ _ -> unsupported_width
+ OP_S_LE w -> case w of
+ W64 -> emit_ bci_OP_S_LE_64 []
+ W32 -> emit_ bci_OP_S_LE_32 []
+ W16 -> emit_ bci_OP_S_LE_16 []
+ W8 -> emit_ bci_OP_S_LE_08 []
+ _ -> unsupported_width
+
+ OP_INDEX_ADDR w -> case w of
+ W64 -> emit_ bci_OP_INDEX_ADDR_64 []
+ W32 -> emit_ bci_OP_INDEX_ADDR_32 []
+ W16 -> emit_ bci_OP_INDEX_ADDR_16 []
+ W8 -> emit_ bci_OP_INDEX_ADDR_08 []
+ _ -> unsupported_width
+
BRK_FUN arr tick_mod tick_mod_id tickx info_mod info_mod_id infox cc ->
do p1 <- ptr (BCOPtrBreakArray arr)
tick_addr <- addr tick_mod
@@ -753,6 +890,7 @@ assembleI platform i = case i of
where
+ unsupported_width = panic "GHC.ByteCode.Asm: Unsupported Width"
emit_ = emit word_size
literal :: Literal -> m Word
=====================================
compiler/GHC/ByteCode/Instr.hs
=====================================
@@ -14,12 +14,15 @@ module GHC.ByteCode.Instr (
import GHC.Prelude
import GHC.ByteCode.Types
+import GHC.Cmm.Type (Width)
import GHCi.RemoteTypes
import GHCi.FFI (C_ffi_cif)
import GHC.StgToCmm.Layout ( ArgRep(..) )
import GHC.Utils.Outputable
+import GHC.Unit.Types (UnitId)
import GHC.Types.Name
import GHC.Types.Literal
+import GHC.Types.Unique
import GHC.Core.DataCon
import GHC.Builtin.PrimOps
import GHC.Runtime.Heap.Layout ( StgWord )
@@ -36,8 +39,6 @@ import GHC.Stack.CCS (CostCentre)
import GHC.Stg.Syntax
import GHCi.BreakArray (BreakArray)
import Language.Haskell.Syntax.Module.Name (ModuleName)
-import GHC.Types.Unique
-import GHC.Unit.Types (UnitId)
-- ----------------------------------------------------------------------------
-- Bytecode instructions
@@ -220,6 +221,39 @@ data BCInstr
| PRIMCALL
+ -- Primops - The actual interpreter instructions are flattened into 64/32/16/8 wide
+ -- instructions. But for generating code it's handy to have the width as argument
+ -- to avoid duplication.
+ | OP_ADD !Width
+ | OP_SUB !Width
+ | OP_AND !Width
+ | OP_XOR !Width
+ | OP_MUL !Width
+ | OP_SHL !Width
+ | OP_ASR !Width
+ | OP_LSR !Width
+ | OP_OR !Width
+
+ | OP_NOT !Width
+ | OP_NEG !Width
+
+ | OP_NEQ !Width
+ | OP_EQ !Width
+
+ | OP_U_LT !Width
+ | OP_U_GE !Width
+ | OP_U_GT !Width
+ | OP_U_LE !Width
+
+ | OP_S_LT !Width
+ | OP_S_GE !Width
+ | OP_S_GT !Width
+ | OP_S_LE !Width
+
+ -- Always puts at least a machine word on the stack.
+ -- We zero extend the result we put on the stack according to host byte order.
+ | OP_INDEX_ADDR !Width
+
-- For doing magic ByteArray passing to foreign calls
| SWIZZLE !WordOff -- to the ptr N words down the stack,
!Int -- add M
@@ -401,6 +435,32 @@ instance Outputable BCInstr where
0x2 -> text "(unsafe)"
_ -> empty)
ppr PRIMCALL = text "PRIMCALL"
+
+ ppr (OP_ADD w) = text "OP_ADD_" <> ppr w
+ ppr (OP_SUB w) = text "OP_SUB_" <> ppr w
+ ppr (OP_AND w) = text "OP_AND_" <> ppr w
+ ppr (OP_XOR w) = text "OP_XOR_" <> ppr w
+ ppr (OP_OR w) = text "OP_OR_" <> ppr w
+ ppr (OP_NOT w) = text "OP_NOT_" <> ppr w
+ ppr (OP_NEG w) = text "OP_NEG_" <> ppr w
+ ppr (OP_MUL w) = text "OP_MUL_" <> ppr w
+ ppr (OP_SHL w) = text "OP_SHL_" <> ppr w
+ ppr (OP_ASR w) = text "OP_ASR_" <> ppr w
+ ppr (OP_LSR w) = text "OP_LSR_" <> ppr w
+
+ ppr (OP_EQ w) = text "OP_EQ_" <> ppr w
+ ppr (OP_NEQ w) = text "OP_NEQ_" <> ppr w
+ ppr (OP_S_LT w) = text "OP_S_LT_" <> ppr w
+ ppr (OP_S_GE w) = text "OP_S_GE_" <> ppr w
+ ppr (OP_S_GT w) = text "OP_S_GT_" <> ppr w
+ ppr (OP_S_LE w) = text "OP_S_LE_" <> ppr w
+ ppr (OP_U_LT w) = text "OP_U_LT_" <> ppr w
+ ppr (OP_U_GE w) = text "OP_U_GE_" <> ppr w
+ ppr (OP_U_GT w) = text "OP_U_GT_" <> ppr w
+ ppr (OP_U_LE w) = text "OP_U_LE_" <> ppr w
+
+ ppr (OP_INDEX_ADDR w) = text "OP_INDEX_ADDR_" <> ppr w
+
ppr (SWIZZLE stkoff n) = text "SWIZZLE " <+> text "stkoff" <+> ppr stkoff
<+> text "by" <+> ppr n
ppr ENTER = text "ENTER"
@@ -509,6 +569,31 @@ bciStackUse RETURN{} = 1 -- pushes stg_ret_X for some X
bciStackUse RETURN_TUPLE{} = 1 -- pushes stg_ret_t header
bciStackUse CCALL{} = 0
bciStackUse PRIMCALL{} = 1 -- pushes stg_primcall
+bciStackUse OP_ADD{} = 0 -- We overestimate, it's -1 actually ...
+bciStackUse OP_SUB{} = 0
+bciStackUse OP_AND{} = 0
+bciStackUse OP_XOR{} = 0
+bciStackUse OP_OR{} = 0
+bciStackUse OP_NOT{} = 0
+bciStackUse OP_NEG{} = 0
+bciStackUse OP_MUL{} = 0
+bciStackUse OP_SHL{} = 0
+bciStackUse OP_ASR{} = 0
+bciStackUse OP_LSR{} = 0
+
+bciStackUse OP_NEQ{} = 0
+bciStackUse OP_EQ{} = 0
+bciStackUse OP_S_LT{} = 0
+bciStackUse OP_S_GT{} = 0
+bciStackUse OP_S_LE{} = 0
+bciStackUse OP_S_GE{} = 0
+bciStackUse OP_U_LT{} = 0
+bciStackUse OP_U_GT{} = 0
+bciStackUse OP_U_LE{} = 0
+bciStackUse OP_U_GE{} = 0
+
+bciStackUse OP_INDEX_ADDR{} = 0
+
bciStackUse SWIZZLE{} = 0
bciStackUse BRK_FUN{} = 0
=====================================
compiler/GHC/StgToByteCode.hs
=====================================
@@ -58,6 +58,7 @@ import GHC.Builtin.Uniques
import GHC.Data.FastString
import GHC.Utils.Panic
import GHC.Utils.Exception (evaluate)
+import GHC.CmmToAsm.Config (platformWordWidth)
import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, idPrimRepU,
addIdReps, addArgReps,
assertNonVoidIds, assertNonVoidStgArgs )
@@ -734,8 +735,14 @@ schemeT d s p (StgOpApp (StgFCallOp (CCall ccall_spec) _ty) args result_ty)
then generateCCall d s p ccall_spec result_ty args
else unsupportedCConvException
-schemeT d s p (StgOpApp (StgPrimOp op) args _ty)
- = doTailCall d s p (primOpId op) (reverse args)
+schemeT d s p (StgOpApp (StgPrimOp op) args _ty) = do
+ profile <- getProfile
+ let platform = profilePlatform profile
+ case doPrimOp platform op d s p args of
+ -- Can we do this right in the interpreter?
+ Just prim_code -> prim_code
+ -- Otherwise we have to do a call to the primop wrapper instead :(
+ _ -> doTailCall d s p (primOpId op) (reverse args)
schemeT d s p (StgOpApp (StgPrimCallOp (PrimCall label unit)) args result_ty)
= generatePrimCall d s p label (Just unit) result_ty args
@@ -830,6 +837,299 @@ doTailCall init_d s p fn args = do
(final_d, more_push_code) <- push_seq (d + sz) args
return (final_d, push_code `appOL` more_push_code)
+doPrimOp :: Platform
+ -> PrimOp
+ -> StackDepth
+ -> Sequel
+ -> BCEnv
+ -> [StgArg]
+ -> Maybe (BcM BCInstrList)
+doPrimOp platform op init_d s p args =
+ case op of
+ IntAddOp -> sizedPrimOp OP_ADD
+ Int64AddOp -> sizedPrimOp OP_ADD
+ Int32AddOp -> sizedPrimOp OP_ADD
+ Int16AddOp -> sizedPrimOp OP_ADD
+ Int8AddOp -> sizedPrimOp OP_ADD
+ WordAddOp -> sizedPrimOp OP_ADD
+ Word64AddOp -> sizedPrimOp OP_ADD
+ Word32AddOp -> sizedPrimOp OP_ADD
+ Word16AddOp -> sizedPrimOp OP_ADD
+ Word8AddOp -> sizedPrimOp OP_ADD
+ AddrAddOp -> sizedPrimOp OP_ADD
+
+ IntMulOp -> sizedPrimOp OP_MUL
+ Int64MulOp -> sizedPrimOp OP_MUL
+ Int32MulOp -> sizedPrimOp OP_MUL
+ Int16MulOp -> sizedPrimOp OP_MUL
+ Int8MulOp -> sizedPrimOp OP_MUL
+ WordMulOp -> sizedPrimOp OP_MUL
+ Word64MulOp -> sizedPrimOp OP_MUL
+ Word32MulOp -> sizedPrimOp OP_MUL
+ Word16MulOp -> sizedPrimOp OP_MUL
+ Word8MulOp -> sizedPrimOp OP_MUL
+
+ IntSubOp -> sizedPrimOp OP_SUB
+ WordSubOp -> sizedPrimOp OP_SUB
+ Int64SubOp -> sizedPrimOp OP_SUB
+ Int32SubOp -> sizedPrimOp OP_SUB
+ Int16SubOp -> sizedPrimOp OP_SUB
+ Int8SubOp -> sizedPrimOp OP_SUB
+ Word64SubOp -> sizedPrimOp OP_SUB
+ Word32SubOp -> sizedPrimOp OP_SUB
+ Word16SubOp -> sizedPrimOp OP_SUB
+ Word8SubOp -> sizedPrimOp OP_SUB
+ AddrSubOp -> sizedPrimOp OP_SUB
+
+ IntAndOp -> sizedPrimOp OP_AND
+ WordAndOp -> sizedPrimOp OP_AND
+ Word64AndOp -> sizedPrimOp OP_AND
+ Word32AndOp -> sizedPrimOp OP_AND
+ Word16AndOp -> sizedPrimOp OP_AND
+ Word8AndOp -> sizedPrimOp OP_AND
+
+ IntNotOp -> sizedPrimOp OP_NOT
+ WordNotOp -> sizedPrimOp OP_NOT
+ Word64NotOp -> sizedPrimOp OP_NOT
+ Word32NotOp -> sizedPrimOp OP_NOT
+ Word16NotOp -> sizedPrimOp OP_NOT
+ Word8NotOp -> sizedPrimOp OP_NOT
+
+ IntXorOp -> sizedPrimOp OP_XOR
+ WordXorOp -> sizedPrimOp OP_XOR
+ Word64XorOp -> sizedPrimOp OP_XOR
+ Word32XorOp -> sizedPrimOp OP_XOR
+ Word16XorOp -> sizedPrimOp OP_XOR
+ Word8XorOp -> sizedPrimOp OP_XOR
+
+ IntOrOp -> sizedPrimOp OP_OR
+ WordOrOp -> sizedPrimOp OP_OR
+ Word64OrOp -> sizedPrimOp OP_OR
+ Word32OrOp -> sizedPrimOp OP_OR
+ Word16OrOp -> sizedPrimOp OP_OR
+ Word8OrOp -> sizedPrimOp OP_OR
+
+ WordSllOp -> sizedPrimOp OP_SHL
+ Word64SllOp -> sizedPrimOp OP_SHL
+ Word32SllOp -> sizedPrimOp OP_SHL
+ Word16SllOp -> sizedPrimOp OP_SHL
+ Word8SllOp -> sizedPrimOp OP_SHL
+ IntSllOp -> sizedPrimOp OP_SHL
+ Int64SllOp -> sizedPrimOp OP_SHL
+ Int32SllOp -> sizedPrimOp OP_SHL
+ Int16SllOp -> sizedPrimOp OP_SHL
+ Int8SllOp -> sizedPrimOp OP_SHL
+
+ WordSrlOp -> sizedPrimOp OP_LSR
+ Word64SrlOp -> sizedPrimOp OP_LSR
+ Word32SrlOp -> sizedPrimOp OP_LSR
+ Word16SrlOp -> sizedPrimOp OP_LSR
+ Word8SrlOp -> sizedPrimOp OP_LSR
+ IntSrlOp -> sizedPrimOp OP_LSR
+ Int64SrlOp -> sizedPrimOp OP_LSR
+ Int32SrlOp -> sizedPrimOp OP_LSR
+ Int16SrlOp -> sizedPrimOp OP_LSR
+ Int8SrlOp -> sizedPrimOp OP_LSR
+
+ IntSraOp -> sizedPrimOp OP_ASR
+ Int64SraOp -> sizedPrimOp OP_ASR
+ Int32SraOp -> sizedPrimOp OP_ASR
+ Int16SraOp -> sizedPrimOp OP_ASR
+ Int8SraOp -> sizedPrimOp OP_ASR
+
+
+ IntNeOp -> sizedPrimOp OP_NEQ
+ Int64NeOp -> sizedPrimOp OP_NEQ
+ Int32NeOp -> sizedPrimOp OP_NEQ
+ Int16NeOp -> sizedPrimOp OP_NEQ
+ Int8NeOp -> sizedPrimOp OP_NEQ
+ WordNeOp -> sizedPrimOp OP_NEQ
+ Word64NeOp -> sizedPrimOp OP_NEQ
+ Word32NeOp -> sizedPrimOp OP_NEQ
+ Word16NeOp -> sizedPrimOp OP_NEQ
+ Word8NeOp -> sizedPrimOp OP_NEQ
+ AddrNeOp -> sizedPrimOp OP_NEQ
+
+ IntEqOp -> sizedPrimOp OP_EQ
+ Int64EqOp -> sizedPrimOp OP_EQ
+ Int32EqOp -> sizedPrimOp OP_EQ
+ Int16EqOp -> sizedPrimOp OP_EQ
+ Int8EqOp -> sizedPrimOp OP_EQ
+ WordEqOp -> sizedPrimOp OP_EQ
+ Word64EqOp -> sizedPrimOp OP_EQ
+ Word32EqOp -> sizedPrimOp OP_EQ
+ Word16EqOp -> sizedPrimOp OP_EQ
+ Word8EqOp -> sizedPrimOp OP_EQ
+ AddrEqOp -> sizedPrimOp OP_EQ
+ CharEqOp -> sizedPrimOp OP_EQ
+
+ IntLtOp -> sizedPrimOp OP_S_LT
+ Int64LtOp -> sizedPrimOp OP_S_LT
+ Int32LtOp -> sizedPrimOp OP_S_LT
+ Int16LtOp -> sizedPrimOp OP_S_LT
+ Int8LtOp -> sizedPrimOp OP_S_LT
+ WordLtOp -> sizedPrimOp OP_U_LT
+ Word64LtOp -> sizedPrimOp OP_U_LT
+ Word32LtOp -> sizedPrimOp OP_U_LT
+ Word16LtOp -> sizedPrimOp OP_U_LT
+ Word8LtOp -> sizedPrimOp OP_U_LT
+ AddrLtOp -> sizedPrimOp OP_U_LT
+ CharLtOp -> sizedPrimOp OP_U_LT
+
+ IntGeOp -> sizedPrimOp OP_S_GE
+ Int64GeOp -> sizedPrimOp OP_S_GE
+ Int32GeOp -> sizedPrimOp OP_S_GE
+ Int16GeOp -> sizedPrimOp OP_S_GE
+ Int8GeOp -> sizedPrimOp OP_S_GE
+ WordGeOp -> sizedPrimOp OP_U_GE
+ Word64GeOp -> sizedPrimOp OP_U_GE
+ Word32GeOp -> sizedPrimOp OP_U_GE
+ Word16GeOp -> sizedPrimOp OP_U_GE
+ Word8GeOp -> sizedPrimOp OP_U_GE
+ AddrGeOp -> sizedPrimOp OP_U_GE
+ CharGeOp -> sizedPrimOp OP_U_GE
+
+ IntGtOp -> sizedPrimOp OP_S_GT
+ Int64GtOp -> sizedPrimOp OP_S_GT
+ Int32GtOp -> sizedPrimOp OP_S_GT
+ Int16GtOp -> sizedPrimOp OP_S_GT
+ Int8GtOp -> sizedPrimOp OP_S_GT
+ WordGtOp -> sizedPrimOp OP_U_GT
+ Word64GtOp -> sizedPrimOp OP_U_GT
+ Word32GtOp -> sizedPrimOp OP_U_GT
+ Word16GtOp -> sizedPrimOp OP_U_GT
+ Word8GtOp -> sizedPrimOp OP_U_GT
+ AddrGtOp -> sizedPrimOp OP_U_GT
+ CharGtOp -> sizedPrimOp OP_U_GT
+
+ IntLeOp -> sizedPrimOp OP_S_LE
+ Int64LeOp -> sizedPrimOp OP_S_LE
+ Int32LeOp -> sizedPrimOp OP_S_LE
+ Int16LeOp -> sizedPrimOp OP_S_LE
+ Int8LeOp -> sizedPrimOp OP_S_LE
+ WordLeOp -> sizedPrimOp OP_U_LE
+ Word64LeOp -> sizedPrimOp OP_U_LE
+ Word32LeOp -> sizedPrimOp OP_U_LE
+ Word16LeOp -> sizedPrimOp OP_U_LE
+ Word8LeOp -> sizedPrimOp OP_U_LE
+ AddrLeOp -> sizedPrimOp OP_U_LE
+ CharLeOp -> sizedPrimOp OP_U_LE
+
+ IntNegOp -> sizedPrimOp OP_NEG
+ Int64NegOp -> sizedPrimOp OP_NEG
+ Int32NegOp -> sizedPrimOp OP_NEG
+ Int16NegOp -> sizedPrimOp OP_NEG
+ Int8NegOp -> sizedPrimOp OP_NEG
+
+ IntToWordOp -> mk_conv (platformWordWidth platform)
+ WordToIntOp -> mk_conv (platformWordWidth platform)
+ Int8ToWord8Op -> mk_conv W8
+ Word8ToInt8Op -> mk_conv W8
+ Int16ToWord16Op -> mk_conv W16
+ Word16ToInt16Op -> mk_conv W16
+ Int32ToWord32Op -> mk_conv W32
+ Word32ToInt32Op -> mk_conv W32
+ Int64ToWord64Op -> mk_conv W64
+ Word64ToInt64Op -> mk_conv W64
+ IntToAddrOp -> mk_conv (platformWordWidth platform)
+ AddrToIntOp -> mk_conv (platformWordWidth platform)
+ ChrOp -> mk_conv (platformWordWidth platform) -- Int# and Char# are rep'd the same
+ OrdOp -> mk_conv (platformWordWidth platform)
+
+ -- Memory primops, expand the ghci-mem-primops test if you add more.
+ IndexOffAddrOp_Word8 -> primOpWithRep (OP_INDEX_ADDR W8) W8
+ IndexOffAddrOp_Word16 -> primOpWithRep (OP_INDEX_ADDR W16) W16
+ IndexOffAddrOp_Word32 -> primOpWithRep (OP_INDEX_ADDR W32) W32
+ IndexOffAddrOp_Word64 -> primOpWithRep (OP_INDEX_ADDR W64) W64
+
+ _ -> Nothing
+ where
+ primArg1Width :: StgArg -> Width
+ primArg1Width arg
+ | rep <- (stgArgRepU arg)
+ = case rep of
+ AddrRep -> platformWordWidth platform
+ IntRep -> platformWordWidth platform
+ WordRep -> platformWordWidth platform
+
+ Int64Rep -> W64
+ Word64Rep -> W64
+
+ Int32Rep -> W32
+ Word32Rep -> W32
+
+ Int16Rep -> W16
+ Word16Rep -> W16
+
+ Int8Rep -> W8
+ Word8Rep -> W8
+
+ FloatRep -> unexpectedRep
+ DoubleRep -> unexpectedRep
+
+ BoxedRep{} -> unexpectedRep
+ VecRep{} -> unexpectedRep
+ where
+ unexpectedRep = panic "doPrimOp: Unexpected argument rep"
+
+
+ -- TODO: The slides for the result need to be two words on 32bit for 64bit ops.
+ mkNReturn width
+ | W64 <- width = RETURN L -- L works for 64 bit on any platform
+ | otherwise = RETURN N -- <64bit width, fits in word on all platforms
+
+ mkSlideWords width = if platformWordWidth platform < width then 2 else 1
+
+ -- Push args, execute primop, slide, return_N
+ -- Decides width of operation based on first argument.
+ sizedPrimOp op_inst = Just $ do
+ let width = primArg1Width (head args)
+ prim_code <- mkPrimOpCode init_d s p (op_inst width) $ args
+ let slide = mkSlideW (mkSlideWords width) (bytesToWords platform $ init_d - s) `snocOL` mkNReturn width
+ return $ prim_code `appOL` slide
+
+ -- primOpWithRep op w => operation @op@ resulting in result @w@ wide.
+ primOpWithRep :: BCInstr -> Width -> Maybe (BcM (OrdList BCInstr))
+ primOpWithRep op_inst width = Just $ do
+ prim_code <- mkPrimOpCode init_d s p op_inst $ args
+
+ let slide = mkSlideW (mkSlideWords width) (bytesToWords platform $ init_d - s) `snocOL` mkNReturn width
+ return $ prim_code `appOL` slide
+
+ -- Convert the argument to a result of width @target_width@
+ mk_conv :: Width -> Maybe (BcM (OrdList BCInstr))
+ mk_conv target_width = Just $ do
+ let width = primArg1Width (head args)
+ (push_code, _bytes) <- pushAtom init_d p (head args)
+ let slide = mkSlideW (mkSlideWords width) (bytesToWords platform $ init_d - s) `snocOL` mkNReturn target_width
+ return $ push_code `appOL` slide
+
+-- Push the arguments on the stack and emit the given instruction
+-- Pushes at least one word per non void arg.
+mkPrimOpCode
+ :: StackDepth
+ -> Sequel
+ -> BCEnv
+ -> BCInstr -- The operator
+ -> [StgArg] -- Args, in *reverse* order (must be fully applied)
+ -> BcM BCInstrList
+mkPrimOpCode orig_d _ p op_inst args = app_code
+ where
+ app_code = do
+ profile <- getProfile
+ let _platform = profilePlatform profile
+
+ do_pushery :: StackDepth -> [StgArg] -> BcM BCInstrList
+ do_pushery !d (arg : args) = do
+ (push,arg_bytes) <- pushAtom d p arg
+ more_push_code <- do_pushery (d + arg_bytes) args
+ return (push `appOL` more_push_code)
+ do_pushery !_d [] = do
+ return (unitOL op_inst)
+
+ -- Push on the stack in the reverse order.
+ do_pushery orig_d (reverse args)
+
-- v. similar to CgStackery.findMatch, ToDo: merge
findPushSeq :: [ArgRep] -> (BCInstr, Int, [ArgRep])
findPushSeq (P: P: P: P: P: P: rest)
=====================================
rts/Disassembler.c
=====================================
@@ -62,6 +62,26 @@ disInstr ( StgBCO *bco, int pc )
#error Cannot cope with WORD_SIZE_IN_BITS being nether 32 nor 64
#endif
#define BCO_GET_LARGE_ARG ((instr & bci_FLAG_LARGE_ARGS) ? BCO_READ_NEXT_WORD : BCO_NEXT)
+// For brevity
+#define BELCH_INSTR_NAME(OP_NAME) \
+ case bci_ ## OP_NAME: \
+ debugBelch("OP_NAME\n"); \
+ break
+
+#define BELCH_INSTR_NAME_ALL_SIZES(OP_NAME) \
+ case bci_ ## OP_NAME ## _64: \
+ debugBelch("#OP_NAME" "_64\n"); \
+ break; \
+ case bci_ ## OP_NAME ## _32: \
+ debugBelch("#OP_NAME" "_32\n"); \
+ break; \
+ case bci_ ## OP_NAME ## _16: \
+ debugBelch("#OP_NAME" "_16\n"); \
+ break; \
+ case bci_ ## OP_NAME ## _08: \
+ debugBelch("#OP_NAME" "_08\n"); \
+ break;
+
switch (instr & 0xff) {
case bci_BRK_FUN:
@@ -419,38 +439,20 @@ disInstr ( StgBCO *bco, int pc )
debugBelch("TESTEQ_P %d, fail to %d\n", instrs[pc],
instrs[pc+1]);
pc += 2; break;
- case bci_CASEFAIL:
- debugBelch("CASEFAIL\n" );
- break;
+ BELCH_INSTR_NAME(CASEFAIL);
case bci_JMP:
debugBelch("JMP to %d\n", instrs[pc]);
pc += 1; break;
- case bci_ENTER:
- debugBelch("ENTER\n");
- break;
+ BELCH_INSTR_NAME(ENTER);
+ BELCH_INSTR_NAME(RETURN_P);
+ BELCH_INSTR_NAME(RETURN_N);
+ BELCH_INSTR_NAME(RETURN_F);
+ BELCH_INSTR_NAME(RETURN_D);
+ BELCH_INSTR_NAME(RETURN_L);
+ BELCH_INSTR_NAME(RETURN_V);
+ BELCH_INSTR_NAME(RETURN_T);
- case bci_RETURN_P:
- debugBelch("RETURN_P\n" );
- break;
- case bci_RETURN_N:
- debugBelch("RETURN_N\n" );
- break;
- case bci_RETURN_F:
- debugBelch("RETURN_F\n" );
- break;
- case bci_RETURN_D:
- debugBelch("RETURN_D\n" );
- break;
- case bci_RETURN_L:
- debugBelch("RETURN_L\n" );
- break;
- case bci_RETURN_V:
- debugBelch("RETURN_V\n" );
- break;
- case bci_RETURN_T:
- debugBelch("RETURN_T\n ");
- break;
case bci_BCO_NAME: {
const char *name = (const char*) literals[instrs[pc]];
@@ -459,6 +461,33 @@ disInstr ( StgBCO *bco, int pc )
break;
}
+ BELCH_INSTR_NAME_ALL_SIZES(OP_ADD);
+ BELCH_INSTR_NAME_ALL_SIZES(OP_SUB);
+ BELCH_INSTR_NAME_ALL_SIZES(OP_AND);
+ BELCH_INSTR_NAME_ALL_SIZES(OP_XOR);
+ BELCH_INSTR_NAME_ALL_SIZES(OP_OR);
+ BELCH_INSTR_NAME_ALL_SIZES(OP_NOT);
+ BELCH_INSTR_NAME_ALL_SIZES(OP_NEG);
+ BELCH_INSTR_NAME_ALL_SIZES(OP_MUL);
+ BELCH_INSTR_NAME_ALL_SIZES(OP_SHL);
+ BELCH_INSTR_NAME_ALL_SIZES(OP_ASR);
+ BELCH_INSTR_NAME_ALL_SIZES(OP_LSR);
+
+ BELCH_INSTR_NAME_ALL_SIZES(OP_NEQ);
+ BELCH_INSTR_NAME_ALL_SIZES(OP_EQ);
+
+ BELCH_INSTR_NAME_ALL_SIZES(OP_U_GT);
+ BELCH_INSTR_NAME_ALL_SIZES(OP_U_LE);
+ BELCH_INSTR_NAME_ALL_SIZES(OP_U_GE);
+ BELCH_INSTR_NAME_ALL_SIZES(OP_U_LT);
+
+ BELCH_INSTR_NAME_ALL_SIZES(OP_S_GT);
+ BELCH_INSTR_NAME_ALL_SIZES(OP_S_LE);
+ BELCH_INSTR_NAME_ALL_SIZES(OP_S_GE);
+ BELCH_INSTR_NAME_ALL_SIZES(OP_S_LT);
+
+ BELCH_INSTR_NAME_ALL_SIZES(OP_INDEX_ADDR);
+
default:
barf("disInstr: unknown opcode %u", (unsigned int) instr);
}
=====================================
rts/Interpreter.c
=====================================
@@ -178,23 +178,35 @@ See also Note [Width of parameters] for some more motivation.
#define Sp_plusB(n) ((void *)((StgWord8*)Sp + (ptrdiff_t)(n)))
#define Sp_minusB(n) ((void *)((StgWord8*)Sp - (ptrdiff_t)(n)))
-#define Sp_plusW(n) (Sp_plusB((ptrdiff_t)(n) * (ptrdiff_t)sizeof(W_)))
-#define Sp_minusW(n) (Sp_minusB((ptrdiff_t)(n) * (ptrdiff_t)sizeof(W_)))
+#define Sp_plusW(n) ((void*)Sp_plusB((ptrdiff_t)(n) * (ptrdiff_t)sizeof(W_)))
+#define Sp_plusW64(n) ((void*)Sp_plusB((ptrdiff_t)(n) * (ptrdiff_t)sizeof(StgWord64)))
+#define Sp_minusW(n) ((void*)Sp_minusB((ptrdiff_t)(n) * (ptrdiff_t)sizeof(W_)))
#define Sp_addB(n) (Sp = Sp_plusB(n))
#define Sp_subB(n) (Sp = Sp_minusB(n))
#define Sp_addW(n) (Sp = Sp_plusW(n))
+#define Sp_addW64(n) (Sp = Sp_plusW64(n))
#define Sp_subW(n) (Sp = Sp_minusW(n))
-#define SpW(n) (*(StgWord*)(Sp_plusW(n)))
-#define SpB(n) (*(StgWord*)(Sp_plusB(n)))
+// Assumes stack location is within stack chunk bounds
+#define SpW(n) (*(StgWord*)(Sp_plusW(n)))
+#define SpW64(n) (*(StgWord*)(Sp_plusW64(n)))
-#define WITHIN_CAP_CHUNK_BOUNDS(n) WITHIN_CHUNK_BOUNDS(n, cap->r.rCurrentTSO->stackobj)
+#define WITHIN_CAP_CHUNK_BOUNDS_W(n) WITHIN_CHUNK_BOUNDS_W(n, cap->r.rCurrentTSO->stackobj)
-#define WITHIN_CHUNK_BOUNDS(n, s) \
- (RTS_LIKELY((StgWord*)(Sp_plusW(n)) < ((s)->stack + (s)->stack_size - sizeofW(StgUnderflowFrame))))
+#define WITHIN_CHUNK_BOUNDS_W(n, s) \
+ (RTS_LIKELY(((StgWord*) Sp_plusW(n)) < ((s)->stack + (s)->stack_size - sizeofW(StgUnderflowFrame))))
+#define W64_TO_WDS(n) ((n * sizeof(StgWord64) / sizeof(StgWord)))
+
+// Always safe to use - Return the value at the address
+#define ReadSpW(n) (*((StgWord*) SafeSpWP(n)))
+//Argument is offset in multiples of word64
+#define ReadSpW64(n) (*((StgWord64*) SafeSpWP(W64_TO_WDS(n))))
+// Perhaps confusingly this still reads a full word, merely the offset is in bytes.
+#define ReadSpB(n) (*((StgWord*) SafeSpBP(n)))
+
/* Note [PUSH_L underflow]
~~~~~~~~~~~~~~~~~~~~~~~
BCOs can be nested, resulting in nested BCO stack frames where the inner most
@@ -215,9 +227,9 @@ variables. If a stack overflow happens between the creation of the stack frame
for BCO_1 and BCO_N the RTS might move BCO_N to a new stack chunk while leaving
BCO_1 in place, invalidating a simple offset based reference to the outer stack
frames.
-Therefore `ReadSpW` first performs a bounds check to ensure that accesses onto
+Therefore `SafeSpW` first performs a bounds check to ensure that accesses onto
the stack will succeed. If the target address would not be a valid location for
-the current stack chunk then `slow_spw` function is called, which dereferences
+the current stack chunk then `slow_sp` function is called, which dereferences
the underflow frame to adjust the offset before performing the lookup.
┌->--x | CHK_1 |
@@ -229,14 +241,43 @@ the underflow frame to adjust the offset before performing the lookup.
|---------| | PUSH_L <n>
| BCO_ N | ->-┘
|---------|
+
+To keep things simpler all accesses to the stack which might go beyond the stack
+chunk go through one of the ReadSP* or SafeSP* macros.
+When writing to the stack there is no need for checks, we ensured we have space
+in the current chunk ahead of time. So there we use SpW and it's variants which
+omit the stack bounds check.
+
See ticket #25750
*/
-#define ReadSpW(n) \
- ((WITHIN_CAP_CHUNK_BOUNDS(n)) ? SpW(n): slow_spw(Sp, cap->r.rCurrentTSO->stackobj, n))
+// Returns a pointer to the stack location.
+#define SafeSpWP(n) \
+ ( ((WITHIN_CAP_CHUNK_BOUNDS_W(n)) ? Sp_plusW(n) : slow_spw(Sp, cap->r.rCurrentTSO->stackobj, n)))
+#define SafeSpBP(off_w) \
+ ( (WITHIN_CAP_CHUNK_BOUNDS_W((1+(off_w))/sizeof(StgWord))) ? \
+ Sp_plusB(off_w) : \
+ (void*)((ptrdiff_t)((ptrdiff_t)(off_w) % (ptrdiff_t)sizeof(StgWord)) + (StgWord8*)slow_spw(Sp, cap->r.rCurrentTSO->stackobj, (off_w)/sizeof(StgWord))) \
+ )
+
+/* Note [Interpreter subword primops]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In general the interpreter stack is host-platform word aligned.
+We keep with this convention when evaluating primops for simplicity.
+
+This means:
+
+* All arguments are pushed extended to word size.
+* Results are written to the stack extended to word size.
+
+The only exception are constructor allocations where we push unaligned subwords
+on the stack which are cleaned up by the PACK instruction afterwards.
+
+*/
+
STATIC_INLINE StgPtr
allocate_NONUPD (Capability *cap, int n_words)
{
@@ -392,11 +433,12 @@ StgClosure * copyPAP (Capability *cap, StgPAP *oldpap)
// See Note [PUSH_L underflow] for in which situations this
// slow lookup is needed
-static StgWord
-slow_spw(void *Sp, StgStack *cur_stack, StgWord offset){
- // 1. If in range, access the item from the current stack chunk
- if (WITHIN_CHUNK_BOUNDS(offset, cur_stack)) {
- return SpW(offset);
+// Returns a pointer to the stack location.
+static void*
+slow_spw(void *Sp, StgStack *cur_stack, StgWord offset_words){
+ // 1. If in range, simply return ptr+offset_words pointing into the current stack chunk
+ if (WITHIN_CHUNK_BOUNDS_W(offset_words, cur_stack)) {
+ return Sp_plusW(offset_words);
}
// 2. Not in this stack chunk, so access the underflow frame.
else {
@@ -420,21 +462,19 @@ slow_spw(void *Sp, StgStack *cur_stack, StgWord offset){
// How many words were on the stack
stackWords = (StgWord *)frame - (StgWord *) Sp;
- ASSERT(offset > stackWords);
+ ASSERT(offset_words > stackWords);
// Recursive, in the very unlikely case we have to traverse two
// stack chunks.
- return slow_spw(new_stack->sp, new_stack, offset-stackWords);
+ return slow_spw(new_stack->sp, new_stack, offset_words-stackWords);
}
// 2b. Access the element if there is no underflow frame, it must be right
// at the top of the stack.
else {
// Not actually in the underflow case
- return SpW(offset);
+ return Sp_plusW(offset_words);
}
-
}
-
}
// Compute the pointer tag for the constructor and tag the pointer;
@@ -883,7 +923,7 @@ do_return_nonpointer:
// get the offset of the header of the next stack frame
offset = stack_frame_sizeW((StgClosure *)Sp);
- switch (get_itbl((StgClosure*)(Sp_plusW(offset)))->type) {
+ switch (get_itbl((StgClosure*)(SafeSpWP(offset)))->type) {
case RET_BCO:
// Returning to an interpreted continuation: pop the return frame
@@ -1236,9 +1276,9 @@ run_BCO:
#endif
bci = BCO_NEXT;
- /* We use the high 8 bits for flags, only the highest of which is
- * currently allocated */
- ASSERT((bci & 0xFF00) == (bci & 0x8000));
+ /* We use the high 8 bits for flags. The highest of which is
+ * currently allocated to LARGE_ARGS */
+ ASSERT((bci & 0xFF00) == (bci & ( bci_FLAG_LARGE_ARGS )));
switch (bci & 0xFF) {
@@ -1429,41 +1469,41 @@ run_BCO:
case bci_PUSH8: {
W_ off = BCO_GET_LARGE_ARG;
Sp_subB(1);
- *(StgWord8*)Sp = (StgWord8) *(StgWord*)(Sp_plusB(off+1));
+ *(StgWord8*)Sp = (StgWord8) (ReadSpB(off+1));
goto nextInsn;
}
case bci_PUSH16: {
W_ off = BCO_GET_LARGE_ARG;
Sp_subB(2);
- *(StgWord16*)Sp = (StgWord16) *(StgWord*)(Sp_plusB(off+2));
+ *(StgWord16*)Sp = (StgWord16) (ReadSpB(off+2));
goto nextInsn;
}
case bci_PUSH32: {
W_ off = BCO_GET_LARGE_ARG;
Sp_subB(4);
- *(StgWord32*)Sp = (StgWord32) *(StgWord*)(Sp_plusB(off+4));
+ *(StgWord32*)Sp = (StgWord32) (ReadSpB(off+4));
goto nextInsn;
}
case bci_PUSH8_W: {
W_ off = BCO_GET_LARGE_ARG;
- *(StgWord*)(Sp_minusW(1)) = (StgWord) ((StgWord8) *(StgWord*)(Sp_plusB(off)));
+ *(StgWord*)(Sp_minusW(1)) = (StgWord) ((StgWord8) (ReadSpB(off)));
Sp_subW(1);
goto nextInsn;
}
case bci_PUSH16_W: {
W_ off = BCO_GET_LARGE_ARG;
- *(StgWord*)(Sp_minusW(1)) = (StgWord) ((StgWord16) *(StgWord*)(Sp_plusB(off)));
+ *(StgWord*)(Sp_minusW(1)) = (StgWord) ((StgWord16) (ReadSpB(off)));
Sp_subW(1);
goto nextInsn;
}
case bci_PUSH32_W: {
W_ off = BCO_GET_LARGE_ARG;
- *(StgWord*)(Sp_minusW(1)) = (StgWord) ((StgWord32) *(StgWord*)(Sp_plusB(off)));
+ *(StgWord*)(Sp_minusW(1)) = (StgWord) ((StgWord32) (ReadSpB(off)));
Sp_subW(1);
goto nextInsn;
}
@@ -1953,7 +1993,7 @@ run_BCO:
case bci_TESTLT_I64: {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
- StgInt64 stackInt = (*(StgInt64*)Sp);
+ StgInt64 stackInt = ReadSpW64(0);
if (stackInt >= BCO_LITI64(discr))
bciPtr = failto;
goto nextInsn;
@@ -1999,7 +2039,7 @@ run_BCO:
case bci_TESTEQ_I64: {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
- StgInt64 stackInt = (*(StgInt64*)Sp);
+ StgInt64 stackInt = ReadSpW64(0);
if (stackInt != BCO_LITI64(discr)) {
bciPtr = failto;
}
@@ -2048,7 +2088,7 @@ run_BCO:
case bci_TESTLT_W64: {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
- StgWord64 stackWord = (*(StgWord64*)Sp);
+ StgWord64 stackWord = ReadSpW64(0);
if (stackWord >= BCO_LITW64(discr))
bciPtr = failto;
goto nextInsn;
@@ -2094,7 +2134,7 @@ run_BCO:
case bci_TESTEQ_W64: {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
- StgWord64 stackWord = (*(StgWord64*)Sp);
+ StgWord64 stackWord = ReadSpW64(0);
if (stackWord != BCO_LITW64(discr)) {
bciPtr = failto;
}
@@ -2231,7 +2271,7 @@ run_BCO:
case bci_SWIZZLE: {
W_ stkoff = BCO_GET_LARGE_ARG;
StgInt n = BCO_GET_LARGE_ARG;
- (*(StgInt*)(Sp_plusW(stkoff))) += n;
+ (*(StgInt*)(SafeSpWP(stkoff))) += n;
goto nextInsn;
}
@@ -2241,6 +2281,203 @@ run_BCO:
RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
}
+// op :: ty -> ty
+#define UN_SIZED_OP(op,ty) \
+ { \
+ if(sizeof(ty) == 8) { \
+ ty r = op ((ty) ReadSpW64(0)); \
+ SpW64(0) = (StgWord64) r; \
+ } else { \
+ ty r = op ((ty) ReadSpW(0)); \
+ SpW(0) = (StgWord) r; \
+ } \
+ goto nextInsn; \
+ }
+
+// op :: ty -> ty -> ty
+#define SIZED_BIN_OP(op,ty) \
+ { \
+ if(sizeof(ty) == 8) { \
+ ty r = ((ty) ReadSpW64(0)) op ((ty) ReadSpW64(1)); \
+ Sp_addW64(1); \
+ SpW64(0) = (StgWord64) r; \
+ } else { \
+ ty r = ((ty) ReadSpW(0)) op ((ty) ReadSpW(1)); \
+ Sp_addW(1); \
+ SpW(0) = (StgWord) r; \
+ }; \
+ goto nextInsn; \
+ }
+
+// op :: ty -> Int -> ty
+#define SIZED_BIN_OP_TY_INT(op,ty) \
+{ \
+ if(sizeof(ty) > sizeof(StgWord)) { \
+ ty r = ((ty) ReadSpW64(0)) op ((ty) ReadSpW(2)); \
+ Sp_addW(1); \
+ SpW64(0) = (StgWord64) r; \
+ } else { \
+ ty r = ((ty) ReadSpW(0)) op ((ty) ReadSpW(1)); \
+ Sp_addW(1); \
+ SpW(0) = (StgWord) r; \
+ }; \
+ goto nextInsn; \
+}
+
+// op :: ty -> ty -> Int
+#define SIZED_BIN_OP_TY_TY_INT(op,ty) \
+{ \
+ if(sizeof(ty) > sizeof(StgWord)) { \
+ ty r = ((ty) ReadSpW64(0)) op ((ty) ReadSpW64(1)); \
+ Sp_addW(3); \
+ SpW(0) = (StgWord) r; \
+ } else { \
+ ty r = ((ty) ReadSpW(0)) op ((ty) ReadSpW(1)); \
+ Sp_addW(1); \
+ SpW(0) = (StgWord) r; \
+ }; \
+ goto nextInsn; \
+}
+
+ case bci_OP_ADD_64: SIZED_BIN_OP(+, StgInt64)
+ case bci_OP_SUB_64: SIZED_BIN_OP(-, StgInt64)
+ case bci_OP_AND_64: SIZED_BIN_OP(&, StgInt64)
+ case bci_OP_XOR_64: SIZED_BIN_OP(^, StgInt64)
+ case bci_OP_OR_64: SIZED_BIN_OP(|, StgInt64)
+ case bci_OP_MUL_64: SIZED_BIN_OP(*, StgInt64)
+ case bci_OP_SHL_64: SIZED_BIN_OP_TY_INT(<<, StgWord64)
+ case bci_OP_LSR_64: SIZED_BIN_OP_TY_INT(>>, StgWord64)
+ case bci_OP_ASR_64: SIZED_BIN_OP_TY_INT(>>, StgInt64)
+
+ case bci_OP_NEQ_64: SIZED_BIN_OP_TY_TY_INT(!=, StgWord64)
+ case bci_OP_EQ_64: SIZED_BIN_OP_TY_TY_INT(==, StgWord64)
+ case bci_OP_U_GT_64: SIZED_BIN_OP_TY_TY_INT(>, StgWord64)
+ case bci_OP_U_GE_64: SIZED_BIN_OP_TY_TY_INT(>=, StgWord64)
+ case bci_OP_U_LT_64: SIZED_BIN_OP_TY_TY_INT(<, StgWord64)
+ case bci_OP_U_LE_64: SIZED_BIN_OP_TY_TY_INT(<=, StgWord64)
+
+ case bci_OP_S_GT_64: SIZED_BIN_OP_TY_TY_INT(>, StgInt64)
+ case bci_OP_S_GE_64: SIZED_BIN_OP_TY_TY_INT(>=, StgInt64)
+ case bci_OP_S_LT_64: SIZED_BIN_OP_TY_TY_INT(<, StgInt64)
+ case bci_OP_S_LE_64: SIZED_BIN_OP_TY_TY_INT(<=, StgInt64)
+
+ case bci_OP_NOT_64: UN_SIZED_OP(~, StgWord64)
+ case bci_OP_NEG_64: UN_SIZED_OP(-, StgInt64)
+
+
+ case bci_OP_ADD_32: SIZED_BIN_OP(+, StgInt32)
+ case bci_OP_SUB_32: SIZED_BIN_OP(-, StgInt32)
+ case bci_OP_AND_32: SIZED_BIN_OP(&, StgInt32)
+ case bci_OP_XOR_32: SIZED_BIN_OP(^, StgInt32)
+ case bci_OP_OR_32: SIZED_BIN_OP(|, StgInt32)
+ case bci_OP_MUL_32: SIZED_BIN_OP(*, StgInt32)
+ case bci_OP_SHL_32: SIZED_BIN_OP_TY_INT(<<, StgWord32)
+ case bci_OP_LSR_32: SIZED_BIN_OP_TY_INT(>>, StgWord32)
+ case bci_OP_ASR_32: SIZED_BIN_OP_TY_INT(>>, StgInt32)
+
+ case bci_OP_NEQ_32: SIZED_BIN_OP_TY_TY_INT(!=, StgWord32)
+ case bci_OP_EQ_32: SIZED_BIN_OP_TY_TY_INT(==, StgWord32)
+ case bci_OP_U_GT_32: SIZED_BIN_OP_TY_TY_INT(>, StgWord32)
+ case bci_OP_U_GE_32: SIZED_BIN_OP_TY_TY_INT(>=, StgWord32)
+ case bci_OP_U_LT_32: SIZED_BIN_OP_TY_TY_INT(<, StgWord32)
+ case bci_OP_U_LE_32: SIZED_BIN_OP_TY_TY_INT(<=, StgWord32)
+
+ case bci_OP_S_GT_32: SIZED_BIN_OP_TY_TY_INT(>, StgInt32)
+ case bci_OP_S_GE_32: SIZED_BIN_OP_TY_TY_INT(>=, StgInt32)
+ case bci_OP_S_LT_32: SIZED_BIN_OP_TY_TY_INT(<, StgInt32)
+ case bci_OP_S_LE_32: SIZED_BIN_OP_TY_TY_INT(<=, StgInt32)
+
+ case bci_OP_NOT_32: UN_SIZED_OP(~, StgWord32)
+ case bci_OP_NEG_32: UN_SIZED_OP(-, StgInt32)
+
+
+ case bci_OP_ADD_16: SIZED_BIN_OP(+, StgInt16)
+ case bci_OP_SUB_16: SIZED_BIN_OP(-, StgInt16)
+ case bci_OP_AND_16: SIZED_BIN_OP(&, StgInt16)
+ case bci_OP_XOR_16: SIZED_BIN_OP(^, StgInt16)
+ case bci_OP_OR_16: SIZED_BIN_OP(|, StgInt16)
+ case bci_OP_MUL_16: SIZED_BIN_OP(*, StgInt16)
+ case bci_OP_SHL_16: SIZED_BIN_OP_TY_INT(<<, StgWord16)
+ case bci_OP_LSR_16: SIZED_BIN_OP_TY_INT(>>, StgWord16)
+ case bci_OP_ASR_16: SIZED_BIN_OP_TY_INT(>>, StgInt16)
+
+ case bci_OP_NEQ_16: SIZED_BIN_OP_TY_TY_INT(!=, StgWord16)
+ case bci_OP_EQ_16: SIZED_BIN_OP_TY_TY_INT(==, StgWord16)
+ case bci_OP_U_GT_16: SIZED_BIN_OP_TY_TY_INT(>, StgWord16)
+ case bci_OP_U_GE_16: SIZED_BIN_OP_TY_TY_INT(>=, StgWord16)
+ case bci_OP_U_LT_16: SIZED_BIN_OP_TY_TY_INT(<, StgWord16)
+ case bci_OP_U_LE_16: SIZED_BIN_OP_TY_TY_INT(<=, StgWord16)
+
+ case bci_OP_S_GT_16: SIZED_BIN_OP(>, StgInt16)
+ case bci_OP_S_GE_16: SIZED_BIN_OP(>=, StgInt16)
+ case bci_OP_S_LT_16: SIZED_BIN_OP(<, StgInt16)
+ case bci_OP_S_LE_16: SIZED_BIN_OP(<=, StgInt16)
+
+ case bci_OP_NOT_16: UN_SIZED_OP(~, StgWord16)
+ case bci_OP_NEG_16: UN_SIZED_OP(-, StgInt16)
+
+
+ case bci_OP_ADD_08: SIZED_BIN_OP(+, StgInt8)
+ case bci_OP_SUB_08: SIZED_BIN_OP(-, StgInt8)
+ case bci_OP_AND_08: SIZED_BIN_OP(&, StgInt8)
+ case bci_OP_XOR_08: SIZED_BIN_OP(^, StgInt8)
+ case bci_OP_OR_08: SIZED_BIN_OP(|, StgInt8)
+ case bci_OP_MUL_08: SIZED_BIN_OP(*, StgInt8)
+ case bci_OP_SHL_08: SIZED_BIN_OP_TY_INT(<<, StgWord8)
+ case bci_OP_LSR_08: SIZED_BIN_OP_TY_INT(>>, StgWord8)
+ case bci_OP_ASR_08: SIZED_BIN_OP_TY_INT(>>, StgInt8)
+
+ case bci_OP_NEQ_08: SIZED_BIN_OP_TY_TY_INT(!=, StgWord8)
+ case bci_OP_EQ_08: SIZED_BIN_OP_TY_TY_INT(==, StgWord8)
+ case bci_OP_U_GT_08: SIZED_BIN_OP_TY_TY_INT(>, StgWord8)
+ case bci_OP_U_GE_08: SIZED_BIN_OP_TY_TY_INT(>=, StgWord8)
+ case bci_OP_U_LT_08: SIZED_BIN_OP_TY_TY_INT(<, StgWord8)
+ case bci_OP_U_LE_08: SIZED_BIN_OP_TY_TY_INT(<=, StgWord8)
+
+ case bci_OP_S_GT_08: SIZED_BIN_OP_TY_TY_INT(>, StgInt8)
+ case bci_OP_S_GE_08: SIZED_BIN_OP_TY_TY_INT(>=, StgInt8)
+ case bci_OP_S_LT_08: SIZED_BIN_OP_TY_TY_INT(<, StgInt8)
+ case bci_OP_S_LE_08: SIZED_BIN_OP_TY_TY_INT(<=, StgInt8)
+
+ case bci_OP_NOT_08: UN_SIZED_OP(~, StgWord8)
+ case bci_OP_NEG_08: UN_SIZED_OP(-, StgInt8)
+
+ case bci_OP_INDEX_ADDR_64:
+ {
+ StgWord64* addr = (StgWord64*) SpW(0);
+ StgInt offset = (StgInt) SpW(1);
+ if(sizeof(StgPtr) == sizeof(StgWord64)) {
+ Sp_addW(1);
+ }
+ SpW64(0) = *(addr+offset);
+ goto nextInsn;
+ }
+
+ case bci_OP_INDEX_ADDR_32:
+ {
+ StgWord32* addr = (StgWord32*) SpW(0);
+ StgInt offset = (StgInt) SpW(1);
+ Sp_addW(1);
+ SpW(0) = (StgWord) *(addr+offset);
+ goto nextInsn;
+ }
+ case bci_OP_INDEX_ADDR_16:
+ {
+ StgWord16* addr = (StgWord16*) SpW(0);
+ StgInt offset = (StgInt) SpW(1);
+ Sp_addW(1);
+ SpW(0) = (StgWord) *(addr+offset);
+ goto nextInsn;
+ }
+ case bci_OP_INDEX_ADDR_08:
+ {
+ StgWord8* addr = (StgWord8*) SpW(0);
+ StgInt offset = (StgInt) SpW(1);
+ Sp_addW(1);
+ SpW(0) = (StgWord) *(addr+offset);
+ goto nextInsn;
+ }
+
case bci_CCALL: {
void *tok;
W_ stk_offset = BCO_GET_LARGE_ARG;
=====================================
rts/include/rts/Bytecodes.h
=====================================
@@ -114,6 +114,107 @@
#define bci_BCO_NAME 88
+#define bci_OP_ADD_64 90
+#define bci_OP_SUB_64 91
+#define bci_OP_AND_64 92
+#define bci_OP_XOR_64 93
+#define bci_OP_NOT_64 94
+#define bci_OP_NEG_64 95
+#define bci_OP_MUL_64 96
+#define bci_OP_SHL_64 97
+#define bci_OP_ASR_64 98
+#define bci_OP_LSR_64 99
+#define bci_OP_OR_64 100
+
+#define bci_OP_NEQ_64 110
+#define bci_OP_EQ_64 111
+#define bci_OP_U_GE_64 112
+#define bci_OP_U_GT_64 113
+#define bci_OP_U_LT_64 114
+#define bci_OP_U_LE_64 115
+#define bci_OP_S_GE_64 116
+#define bci_OP_S_GT_64 117
+#define bci_OP_S_LT_64 118
+#define bci_OP_S_LE_64 119
+
+
+#define bci_OP_ADD_32 130
+#define bci_OP_SUB_32 131
+#define bci_OP_AND_32 132
+#define bci_OP_XOR_32 133
+#define bci_OP_NOT_32 134
+#define bci_OP_NEG_32 135
+#define bci_OP_MUL_32 136
+#define bci_OP_SHL_32 137
+#define bci_OP_ASR_32 138
+#define bci_OP_LSR_32 139
+#define bci_OP_OR_32 140
+
+#define bci_OP_NEQ_32 150
+#define bci_OP_EQ_32 151
+#define bci_OP_U_GE_32 152
+#define bci_OP_U_GT_32 153
+#define bci_OP_U_LT_32 154
+#define bci_OP_U_LE_32 155
+#define bci_OP_S_GE_32 156
+#define bci_OP_S_GT_32 157
+#define bci_OP_S_LT_32 158
+#define bci_OP_S_LE_32 159
+
+
+#define bci_OP_ADD_16 170
+#define bci_OP_SUB_16 171
+#define bci_OP_AND_16 172
+#define bci_OP_XOR_16 173
+#define bci_OP_NOT_16 174
+#define bci_OP_NEG_16 175
+#define bci_OP_MUL_16 176
+#define bci_OP_SHL_16 177
+#define bci_OP_ASR_16 178
+#define bci_OP_LSR_16 179
+#define bci_OP_OR_16 180
+
+#define bci_OP_NEQ_16 190
+#define bci_OP_EQ_16 191
+#define bci_OP_U_GE_16 192
+#define bci_OP_U_GT_16 193
+#define bci_OP_U_LT_16 194
+#define bci_OP_U_LE_16 195
+#define bci_OP_S_GE_16 196
+#define bci_OP_S_GT_16 197
+#define bci_OP_S_LT_16 198
+#define bci_OP_S_LE_16 199
+
+
+#define bci_OP_ADD_08 200
+#define bci_OP_SUB_08 201
+#define bci_OP_AND_08 202
+#define bci_OP_XOR_08 203
+#define bci_OP_NOT_08 204
+#define bci_OP_NEG_08 205
+#define bci_OP_MUL_08 206
+#define bci_OP_SHL_08 207
+#define bci_OP_ASR_08 208
+#define bci_OP_LSR_08 209
+#define bci_OP_OR_08 210
+
+#define bci_OP_NEQ_08 220
+#define bci_OP_EQ_08 221
+#define bci_OP_U_GE_08 222
+#define bci_OP_U_GT_08 223
+#define bci_OP_U_LT_08 224
+#define bci_OP_U_LE_08 225
+#define bci_OP_S_GE_08 226
+#define bci_OP_S_GT_08 227
+#define bci_OP_S_LT_08 228
+#define bci_OP_S_LE_08 229
+
+#define bci_OP_INDEX_ADDR_08 240
+#define bci_OP_INDEX_ADDR_16 241
+#define bci_OP_INDEX_ADDR_32 242
+#define bci_OP_INDEX_ADDR_64 243
+
+
/* If you need to go past 255 then you will run into the flags */
/* If you need to go below 0x0100 then you will run into the instructions */
=====================================
testsuite/tests/codeGen/should_run/all.T
=====================================
@@ -226,7 +226,7 @@ test('T20640b', normal, compile_and_run, [''])
test('T22296',[only_ways(llvm_ways)
,unless(arch('x86_64') or arch('aarch64'), skip)],compile_and_run,[''])
test('T22798', normal, compile_and_run, ['-fregs-graph'])
-test('CheckBoundsOK', normal, compile_and_run, ['-fcheck-prim-bounds'])
+test('CheckBoundsOK', normal, compile_and_run, ['-fcheck-prim-bounds -funoptimized-core-for-interpreter -O'])
test('OrigThunkInfo', normal, compile_and_run, ['-forig-thunk-info'])
test('T24809', req_profiling, compile_and_run, ['-forig-thunk-info -prof'])
=====================================
testsuite/tests/ghci/all.T
=====================================
@@ -0,0 +1,2 @@
+test('ghci-mem-primops', [ extra_ways(['ghci-opt']), only_ways(['ghci', 'ghci-opt']),
+ extra_hc_opts('-fno-unoptimized-core-for-interpreter -O')], ghci_script, ['ghci-mem-primops.script'])
=====================================
testsuite/tests/ghci/ghci-mem-primops.hs
=====================================
@@ -0,0 +1,31 @@
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE ExtendedLiterals #-}
+
+module Main where
+
+-- Test memory primops interpreted in interpreter, extend if you add more.
+import GHC.Word
+import GHC.PrimOps
+import GHC.IO
+import Numeric (showHex)
+
+data Bytes = Bytes { byte_addr :: Addr# }
+
+bytes :: Bytes
+bytes = Bytes "\0\1\2\3\4\5\6\7\8\0"#
+
+main = do
+ let val = 0x1122334455667788#Word
+ IO (\s -> case writeWordOffAddr# (byte_addr bytes) 0# val s of s2 -> (# s2,() #))
+ putStrLn . flip showHex "" $ W64# (indexWord64OffAddr# (byte_addr bytes) 0#)
+ putStrLn . flip showHex "" $ W# (indexWordOffAddr# (byte_addr bytes) 0#)
+
+ IO (\s -> case writeWord32OffAddr# (byte_addr bytes) 0# 0x11223344#Word32 s of s2 -> (# s2,() #))
+ putStrLn . flip showHex "" $ W32# (indexWord32OffAddr# (byte_addr bytes) 0#)
+
+ IO (\s -> case writeWord16OffAddr# (byte_addr bytes) 0# 0x1122#Word16 s of s2 -> (# s2,() #))
+ putStrLn . flip showHex "" $ W16# (indexWord16OffAddr# (byte_addr bytes) 0#)
+
+ IO (\s -> case writeWord8OffAddr# (byte_addr bytes) 0# 0x11#Word8 s of s2 -> (# s2,() #))
+ putStrLn . flip showHex "" $ W8# (indexWord8OffAddr# (byte_addr bytes) 0#)
\ No newline at end of file
=====================================
testsuite/tests/ghci/ghci-mem-primops.script
=====================================
@@ -0,0 +1,2 @@
+:l ghci-mem-primops
+:main
\ No newline at end of file
=====================================
testsuite/tests/ghci/ghci-mem-primops.stdout
=====================================
@@ -0,0 +1,5 @@
+1122334455667788
+1122334455667788
+11223344
+1122
+11
=====================================
testsuite/tests/numeric/should_run/all.T
=====================================
@@ -82,7 +82,7 @@ test('IntegerToFloat', normal, compile_and_run, [''])
test('T20291', normal, compile_and_run, [''])
test('T22282', normal, compile_and_run, [''])
test('T22671', js_fragile(24259), compile_and_run, [''])
-test('foundation', [when(js_arch(), run_timeout_multiplier(2)), js_fragile(24259)], compile_and_run, ['-O -package transformers'])
+test('foundation', [when(js_arch(), run_timeout_multiplier(2)), js_fragile(24259), extra_ways(['optasm','ghci','ghci-opt'])], compile_and_run, ['-package transformers -fno-break-points'])
test('T24066', normal, compile_and_run, [''])
test('div01', normal, compile_and_run, [''])
test('T24245', normal, compile_and_run, [''])
=====================================
testsuite/tests/numeric/should_run/foundation.hs
=====================================
@@ -1,3 +1,15 @@
+{- PARTS OF THIS FILE ARE SEMI-AUTOGENERATED.
+ You can re-generate them by invoking the genprimops utility with --foundation-tests
+ and then integrating the output in this file.
+
+ This test compares the results of various primops between the
+ pre-compiled version (primop wrapper) and the implementation of
+ whatever the test is run with.
+
+ This is particularly helpful when testing the interpreter as it allows us to
+ compare the result of the primop wrappers with the results of interpretation.
+-}
+
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
@@ -5,6 +17,9 @@
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE UnboxedTuples #-}
module Main
( main
) where
@@ -16,6 +31,7 @@ import Data.Typeable
import Data.Proxy
import GHC.Int
import GHC.Word
+import GHC.Word
import Data.Function
import GHC.Prim
import Control.Monad.Reader
@@ -26,6 +42,13 @@ import Foreign.Ptr
import Data.List (intercalate)
import Data.IORef
import Unsafe.Coerce
+import GHC.Types
+import Data.Char
+import Data.Semigroup
+import System.Exit
+
+import qualified GHC.Internal.PrimopWrappers as Wrapper
+import qualified GHC.Internal.Prim as Primop
newtype Gen a = Gen { runGen :: (ReaderT LCGGen IO a) }
deriving newtype (Functor, Applicative, Monad)
@@ -98,6 +121,17 @@ arbitraryWord64 = Gen $ do
h <- ask
liftIO (randomWord64 h)
+nonZero :: (Arbitrary a, Num a, Eq a) => Gen (NonZero a)
+nonZero = do
+ x <- arbitrary
+ if x == 0 then nonZero else pure $ NonZero x
+
+newtype NonZero a = NonZero { getNonZero :: a }
+ deriving (Eq,Ord,Bounded,Show)
+
+instance (Arbitrary a, Num a, Eq a) => Arbitrary (NonZero a) where
+ arbitrary = nonZero
+
instance Arbitrary Natural where
arbitrary = integralDownsize . (`mod` 10000) . abs <$> arbitraryInt64
@@ -126,6 +160,13 @@ instance Arbitrary Int16 where
instance Arbitrary Int8 where
arbitrary = integralDownsize <$> arbitraryInt64
+instance Arbitrary Char where
+ arbitrary = do
+ let high = fromIntegral $ fromEnum (maxBound :: Char) :: Word
+ (x::Word) <- arbitrary
+ let x' = mod x high
+ return (chr $ fromIntegral x')
+
int64ToInt :: Int64 -> Int
int64ToInt (I64# i) = I# (int64ToInt# i)
@@ -134,7 +175,7 @@ word64ToWord :: Word64 -> Word
word64ToWord (W64# i) = W# (word64ToWord# i)
-data RunS = RunS { depth :: Int, rg :: LCGGen }
+data RunS = RunS { depth :: Int, rg :: LCGGen, context :: [String] }
newtype LCGGen = LCGGen { randomWord64 :: IO Word64 }
@@ -148,43 +189,75 @@ newLCGGen LCGParams{..} = do
runPropertyCheck (PropertyBinaryOp res desc s1 s2) =
- if res then return True else (putMsg ("Failure: " ++ s1 ++ desc ++ s2) >> return False)
-runPropertyCheck (PropertyAnd a1 a2) = (&&) <$> runPropertyCheck a1 <*> runPropertyCheck a2
-
-runProperty :: Property -> ReaderT RunS IO ()
+ if res then return Success
+ else do
+ ctx <- context <$> ask
+ let msg = "Failure: " ++ s1 ++ desc ++ s2
+ putMsg msg
+ return (Failure [msg : ctx])
+runPropertyCheck (PropertyAnd a1 a2) = (<>) <$> runPropertyCheck a1 <*> runPropertyCheck a2
+
+runProperty :: Property -> ReaderT RunS IO Result
runProperty (Prop p) = do
let iterations = 100
loop iterations iterations
where
- loop iterations 0 = putMsg ("Passed " ++ show iterations ++ " iterations")
+ loop iterations 0 = do
+ putMsg ("Passed " ++ show iterations ++ " iterations")
+ return Success
loop iterations n = do
h <- rg <$> ask
p <- liftIO (runReaderT (runGen p) h)
let (ss, pc) = getCheck p
res <- runPropertyCheck pc
- if res then loop iterations (n-1)
- else putMsg ("With arguments " ++ intercalate ", " ss)
+ case res of
+ Success -> loop iterations (n-1)
+ Failure msgs -> do
+ let msg = ("With arguments " ++ intercalate ", " ss)
+ putMsg msg
+ return (Failure (map (msg :) msgs))
+
+data Result = Success | Failure [[String]]
+
+instance Semigroup Result where
+ Success <> x = x
+ x <> Success = x
+ (Failure xs) <> (Failure ys) = Failure (xs ++ ys)
+
+instance Monoid Result where
+ mempty = Success
putMsg s = do
n <- depth <$> ask
liftIO . putStrLn $ replicate (n * 2) ' ' ++ s
-nest = local (\s -> s { depth = depth s + 1 })
-runTestInternal :: Test -> ReaderT RunS IO ()
+nest c = local (\s -> s { depth = depth s + 1, context = c : context s })
+
+runTestInternal :: Test -> ReaderT RunS IO Result
runTestInternal (Group name tests) = do
- putMsg ("Group " ++ name)
- nest (mapM_ runTestInternal tests)
+ let label = ("Group " ++ name)
+ putMsg label
+ nest label (mconcat <$> mapM runTestInternal tests)
runTestInternal (Property name p) = do
- putMsg ("Running " ++ name)
- nest $ runProperty (property p)
+ let label = ("Running " ++ name)
+ putMsg label
+ nest label $ runProperty (property p)
runTests :: Test -> IO ()
runTests t = do
-- These params are the same ones as glibc uses.
h <- newLCGGen (LCGParams { seed = 1238123213, m = 2^31, a = 1103515245, c = 12345 })
- runReaderT (runTestInternal t) (RunS 0 h)
+ res <- runReaderT (runTestInternal t) (RunS 0 h [])
+ case res of
+ Success -> return ()
+ Failure tests -> do
+ putStrLn $ "These tests failed: \n" ++ intercalate " \n" (map (showStack 0 . reverse) tests)
+ exitFailure
+
+showStack _ [] = ""
+showStack n (s:ss) = replicate n ' ' ++ s ++ "\n" ++ showStack (n + 2) ss
-------------------------------------------------------------------------------
@@ -228,9 +301,8 @@ testMultiplicative _ = Group "Multiplicative"
testDividible :: forall a . (Show a, Eq a, Integral a, Num a, Arbitrary a, Typeable a)
=> Proxy a -> Test
testDividible _ = Group "Divisible"
- [ Property "(x `div` y) * y + (x `mod` y) == x" $ \(a :: a) b ->
- if b == 0 then True === True
- else a === (a `div` b) * b + (a `mod` b)
+ [ Property "(x `div` y) * y + (x `mod` y) == x" $ \(a :: a) (NonZero b) ->
+ a === (a `div` b) * b + (a `mod` b)
]
testOperatorPrecedence :: forall a . (Show a, Eq a, Prelude.Num a, Integral a, Num a, Arbitrary a, Typeable a)
@@ -272,6 +344,590 @@ testNumberRefs = Group "ALL"
, testNumber "Word32" (Proxy :: Proxy Word32)
, testNumber "Word64" (Proxy :: Proxy Word64)
]
+{-
+test_binop :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) a r'
+ (b :: TYPE r1) (r :: TYPE r2) . String -> (a -> b) -> (r -> r')
+ -> (b -> b -> r)
+ -> (b -> b -> r)
+ -> Test
+test_binop name unwrap wrap primop wrapper =
+-}
+-- #define TEST_BINOP(name, unwrap, wrap, primop, wrapper) Property name $ \l r -> wrap (primop (unwrap l) (unwrap r)) === wrap (wrapper (unwrap l) (unwrap r))
+
+wInt# :: Int# -> Int
+wInt# = I#
+
+uInt# :: Int -> Int#
+uInt# (I# x) = x
+
+wWord#:: Word# -> Word
+wWord#= W#
+
+uWord# (W# w) = w
+uWord8# (W8# w) = w
+uWord16# (W16# w) = w
+uWord32# (W32# w) = w
+uWord64# (W64# w) = w
+uChar# (C# c) = c
+uInt8# (I8# w) = w
+uInt16# (I16# w) = w
+uInt32# (I32# w) = w
+uInt64# (I64# w) = w
+
+wWord8# = W8#
+wWord16# = W16#
+wWord32# = W32#
+wWord64# = W64#
+wChar# = C#
+wInt8# = I8#
+wInt16# = I16#
+wInt32# = I32#
+wInt64# = I64#
+
+#define WTUP2(f, g, x) (case x of (# a, b #) -> (f a, g b))
+#define WTUP3(f, g, h, x) (case x of (# a, b, c #) -> (f a, g b, h c))
+
+
+class TestPrimop f where
+ testPrimop :: String -> f -> f -> Test
+
+ testPrimopDivLike :: String -> f -> f -> Test
+ testPrimopDivLike _ _ _ = error "Div testing not supported for this type."
+
+{-
+instance TestPrimop (Int# -> Int# -> Int#) where
+ testPrimop s l r = Property s $ \(uInt -> a1) (uInt -> a2) -> (wInt (l a1 a2)) === wInt (r a1 a2)
+
+instance TestPrimop (Word# -> Word# -> Int#) where
+ testPrimop s l r = Property s $ \(uWord -> a1) (uWord -> a2) -> (wInt (l a1 a2)) === wInt (r a1 a2)
+
+instance TestPrimop (Word# -> Int#) where
+ testPrimop s l r = Property s $ \(uWord -> a1) -> (wInt (l a1)) === wInt (r a1)
+
+instance TestPrimop (Word# -> Int# -> Word#) where
+ testPrimop s l r = Property s $ \(uWord -> a1) (uInt -> a2) -> (wWord (l a1 a2)) === wWord (r a1 a2)
+ -}
+
+
+twoNonZero :: (a -> a -> b) -> a -> NonZero a -> b
+twoNonZero f x (NonZero y) = f x y
+
+main = runTests (Group "ALL" [testNumberRefs, testPrimops])
+
+-- Test an interpreted primop vs a compiled primop
+testPrimops = Group "primop"
+ [ testPrimop "gtChar#" Primop.gtChar# Wrapper.gtChar#
+ , testPrimop "geChar#" Primop.geChar# Wrapper.geChar#
+ , testPrimop "eqChar#" Primop.eqChar# Wrapper.eqChar#
+ , testPrimop "neChar#" Primop.neChar# Wrapper.neChar#
+ , testPrimop "ltChar#" Primop.ltChar# Wrapper.ltChar#
+ , testPrimop "leChar#" Primop.leChar# Wrapper.leChar#
+ , testPrimop "ord#" Primop.ord# Wrapper.ord#
+ , testPrimop "int8ToInt#" Primop.int8ToInt# Wrapper.int8ToInt#
+ , testPrimop "intToInt8#" Primop.intToInt8# Wrapper.intToInt8#
+ , testPrimop "negateInt8#" Primop.negateInt8# Wrapper.negateInt8#
+ , testPrimop "plusInt8#" Primop.plusInt8# Wrapper.plusInt8#
+ , testPrimop "subInt8#" Primop.subInt8# Wrapper.subInt8#
+ , testPrimop "timesInt8#" Primop.timesInt8# Wrapper.timesInt8#
+ , testPrimopDivLike "quotInt8#" Primop.quotInt8# Wrapper.quotInt8#
+ , testPrimopDivLike "remInt8#" Primop.remInt8# Wrapper.remInt8#
+ , testPrimopDivLike "quotRemInt8#" Primop.quotRemInt8# Wrapper.quotRemInt8#
+ , testPrimop "uncheckedShiftLInt8#" Primop.uncheckedShiftLInt8# Wrapper.uncheckedShiftLInt8#
+ , testPrimop "uncheckedShiftRAInt8#" Primop.uncheckedShiftRAInt8# Wrapper.uncheckedShiftRAInt8#
+ , testPrimop "uncheckedShiftRLInt8#" Primop.uncheckedShiftRLInt8# Wrapper.uncheckedShiftRLInt8#
+ , testPrimop "int8ToWord8#" Primop.int8ToWord8# Wrapper.int8ToWord8#
+ , testPrimop "eqInt8#" Primop.eqInt8# Wrapper.eqInt8#
+ , testPrimop "geInt8#" Primop.geInt8# Wrapper.geInt8#
+ , testPrimop "gtInt8#" Primop.gtInt8# Wrapper.gtInt8#
+ , testPrimop "leInt8#" Primop.leInt8# Wrapper.leInt8#
+ , testPrimop "ltInt8#" Primop.ltInt8# Wrapper.ltInt8#
+ , testPrimop "neInt8#" Primop.neInt8# Wrapper.neInt8#
+ , testPrimop "word8ToWord#" Primop.word8ToWord# Wrapper.word8ToWord#
+ , testPrimop "wordToWord8#" Primop.wordToWord8# Wrapper.wordToWord8#
+ , testPrimop "plusWord8#" Primop.plusWord8# Wrapper.plusWord8#
+ , testPrimop "subWord8#" Primop.subWord8# Wrapper.subWord8#
+ , testPrimop "timesWord8#" Primop.timesWord8# Wrapper.timesWord8#
+ , testPrimopDivLike "quotWord8#" Primop.quotWord8# Wrapper.quotWord8#
+ , testPrimopDivLike "remWord8#" Primop.remWord8# Wrapper.remWord8#
+ , testPrimopDivLike "quotRemWord8#" Primop.quotRemWord8# Wrapper.quotRemWord8#
+ , testPrimop "andWord8#" Primop.andWord8# Wrapper.andWord8#
+ , testPrimop "orWord8#" Primop.orWord8# Wrapper.orWord8#
+ , testPrimop "xorWord8#" Primop.xorWord8# Wrapper.xorWord8#
+ , testPrimop "notWord8#" Primop.notWord8# Wrapper.notWord8#
+ , testPrimop "uncheckedShiftLWord8#" Primop.uncheckedShiftLWord8# Wrapper.uncheckedShiftLWord8#
+ , testPrimop "uncheckedShiftRLWord8#" Primop.uncheckedShiftRLWord8# Wrapper.uncheckedShiftRLWord8#
+ , testPrimop "word8ToInt8#" Primop.word8ToInt8# Wrapper.word8ToInt8#
+ , testPrimop "eqWord8#" Primop.eqWord8# Wrapper.eqWord8#
+ , testPrimop "geWord8#" Primop.geWord8# Wrapper.geWord8#
+ , testPrimop "gtWord8#" Primop.gtWord8# Wrapper.gtWord8#
+ , testPrimop "leWord8#" Primop.leWord8# Wrapper.leWord8#
+ , testPrimop "ltWord8#" Primop.ltWord8# Wrapper.ltWord8#
+ , testPrimop "neWord8#" Primop.neWord8# Wrapper.neWord8#
+ , testPrimop "int16ToInt#" Primop.int16ToInt# Wrapper.int16ToInt#
+ , testPrimop "intToInt16#" Primop.intToInt16# Wrapper.intToInt16#
+ , testPrimop "negateInt16#" Primop.negateInt16# Wrapper.negateInt16#
+ , testPrimop "plusInt16#" Primop.plusInt16# Wrapper.plusInt16#
+ , testPrimop "subInt16#" Primop.subInt16# Wrapper.subInt16#
+ , testPrimop "timesInt16#" Primop.timesInt16# Wrapper.timesInt16#
+ , testPrimopDivLike "quotInt16#" Primop.quotInt16# Wrapper.quotInt16#
+ , testPrimopDivLike "remInt16#" Primop.remInt16# Wrapper.remInt16#
+ , testPrimopDivLike "quotRemInt16#" Primop.quotRemInt16# Wrapper.quotRemInt16#
+ , testPrimop "uncheckedShiftLInt16#" Primop.uncheckedShiftLInt16# Wrapper.uncheckedShiftLInt16#
+ , testPrimop "uncheckedShiftRAInt16#" Primop.uncheckedShiftRAInt16# Wrapper.uncheckedShiftRAInt16#
+ , testPrimop "uncheckedShiftRLInt16#" Primop.uncheckedShiftRLInt16# Wrapper.uncheckedShiftRLInt16#
+ , testPrimop "int16ToWord16#" Primop.int16ToWord16# Wrapper.int16ToWord16#
+ , testPrimop "eqInt16#" Primop.eqInt16# Wrapper.eqInt16#
+ , testPrimop "geInt16#" Primop.geInt16# Wrapper.geInt16#
+ , testPrimop "gtInt16#" Primop.gtInt16# Wrapper.gtInt16#
+ , testPrimop "leInt16#" Primop.leInt16# Wrapper.leInt16#
+ , testPrimop "ltInt16#" Primop.ltInt16# Wrapper.ltInt16#
+ , testPrimop "neInt16#" Primop.neInt16# Wrapper.neInt16#
+ , testPrimop "word16ToWord#" Primop.word16ToWord# Wrapper.word16ToWord#
+ , testPrimop "wordToWord16#" Primop.wordToWord16# Wrapper.wordToWord16#
+ , testPrimop "plusWord16#" Primop.plusWord16# Wrapper.plusWord16#
+ , testPrimop "subWord16#" Primop.subWord16# Wrapper.subWord16#
+ , testPrimop "timesWord16#" Primop.timesWord16# Wrapper.timesWord16#
+ , testPrimopDivLike "quotWord16#" Primop.quotWord16# Wrapper.quotWord16#
+ , testPrimopDivLike "remWord16#" Primop.remWord16# Wrapper.remWord16#
+ , testPrimopDivLike "quotRemWord16#" Primop.quotRemWord16# Wrapper.quotRemWord16#
+ , testPrimop "andWord16#" Primop.andWord16# Wrapper.andWord16#
+ , testPrimop "orWord16#" Primop.orWord16# Wrapper.orWord16#
+ , testPrimop "xorWord16#" Primop.xorWord16# Wrapper.xorWord16#
+ , testPrimop "notWord16#" Primop.notWord16# Wrapper.notWord16#
+ , testPrimop "uncheckedShiftLWord16#" Primop.uncheckedShiftLWord16# Wrapper.uncheckedShiftLWord16#
+ , testPrimop "uncheckedShiftRLWord16#" Primop.uncheckedShiftRLWord16# Wrapper.uncheckedShiftRLWord16#
+ , testPrimop "word16ToInt16#" Primop.word16ToInt16# Wrapper.word16ToInt16#
+ , testPrimop "eqWord16#" Primop.eqWord16# Wrapper.eqWord16#
+ , testPrimop "geWord16#" Primop.geWord16# Wrapper.geWord16#
+ , testPrimop "gtWord16#" Primop.gtWord16# Wrapper.gtWord16#
+ , testPrimop "leWord16#" Primop.leWord16# Wrapper.leWord16#
+ , testPrimop "ltWord16#" Primop.ltWord16# Wrapper.ltWord16#
+ , testPrimop "neWord16#" Primop.neWord16# Wrapper.neWord16#
+ , testPrimop "int32ToInt#" Primop.int32ToInt# Wrapper.int32ToInt#
+ , testPrimop "intToInt32#" Primop.intToInt32# Wrapper.intToInt32#
+ , testPrimop "negateInt32#" Primop.negateInt32# Wrapper.negateInt32#
+ , testPrimop "plusInt32#" Primop.plusInt32# Wrapper.plusInt32#
+ , testPrimop "subInt32#" Primop.subInt32# Wrapper.subInt32#
+ , testPrimop "timesInt32#" Primop.timesInt32# Wrapper.timesInt32#
+ , testPrimopDivLike "quotInt32#" Primop.quotInt32# Wrapper.quotInt32#
+ , testPrimopDivLike "remInt32#" Primop.remInt32# Wrapper.remInt32#
+ , testPrimopDivLike "quotRemInt32#" Primop.quotRemInt32# Wrapper.quotRemInt32#
+ , testPrimop "uncheckedShiftLInt32#" Primop.uncheckedShiftLInt32# Wrapper.uncheckedShiftLInt32#
+ , testPrimop "uncheckedShiftRAInt32#" Primop.uncheckedShiftRAInt32# Wrapper.uncheckedShiftRAInt32#
+ , testPrimop "uncheckedShiftRLInt32#" Primop.uncheckedShiftRLInt32# Wrapper.uncheckedShiftRLInt32#
+ , testPrimop "int32ToWord32#" Primop.int32ToWord32# Wrapper.int32ToWord32#
+ , testPrimop "eqInt32#" Primop.eqInt32# Wrapper.eqInt32#
+ , testPrimop "geInt32#" Primop.geInt32# Wrapper.geInt32#
+ , testPrimop "gtInt32#" Primop.gtInt32# Wrapper.gtInt32#
+ , testPrimop "leInt32#" Primop.leInt32# Wrapper.leInt32#
+ , testPrimop "ltInt32#" Primop.ltInt32# Wrapper.ltInt32#
+ , testPrimop "neInt32#" Primop.neInt32# Wrapper.neInt32#
+ , testPrimop "word32ToWord#" Primop.word32ToWord# Wrapper.word32ToWord#
+ , testPrimop "wordToWord32#" Primop.wordToWord32# Wrapper.wordToWord32#
+ , testPrimop "plusWord32#" Primop.plusWord32# Wrapper.plusWord32#
+ , testPrimop "subWord32#" Primop.subWord32# Wrapper.subWord32#
+ , testPrimop "timesWord32#" Primop.timesWord32# Wrapper.timesWord32#
+ , testPrimopDivLike "quotWord32#" Primop.quotWord32# Wrapper.quotWord32#
+ , testPrimopDivLike "remWord32#" Primop.remWord32# Wrapper.remWord32#
+ , testPrimopDivLike "quotRemWord32#" Primop.quotRemWord32# Wrapper.quotRemWord32#
+ , testPrimop "andWord32#" Primop.andWord32# Wrapper.andWord32#
+ , testPrimop "orWord32#" Primop.orWord32# Wrapper.orWord32#
+ , testPrimop "xorWord32#" Primop.xorWord32# Wrapper.xorWord32#
+ , testPrimop "notWord32#" Primop.notWord32# Wrapper.notWord32#
+ , testPrimop "uncheckedShiftLWord32#" Primop.uncheckedShiftLWord32# Wrapper.uncheckedShiftLWord32#
+ , testPrimop "uncheckedShiftRLWord32#" Primop.uncheckedShiftRLWord32# Wrapper.uncheckedShiftRLWord32#
+ , testPrimop "word32ToInt32#" Primop.word32ToInt32# Wrapper.word32ToInt32#
+ , testPrimop "eqWord32#" Primop.eqWord32# Wrapper.eqWord32#
+ , testPrimop "geWord32#" Primop.geWord32# Wrapper.geWord32#
+ , testPrimop "gtWord32#" Primop.gtWord32# Wrapper.gtWord32#
+ , testPrimop "leWord32#" Primop.leWord32# Wrapper.leWord32#
+ , testPrimop "ltWord32#" Primop.ltWord32# Wrapper.ltWord32#
+ , testPrimop "neWord32#" Primop.neWord32# Wrapper.neWord32#
+ , testPrimop "int64ToInt#" Primop.int64ToInt# Wrapper.int64ToInt#
+ , testPrimop "intToInt64#" Primop.intToInt64# Wrapper.intToInt64#
+ , testPrimop "negateInt64#" Primop.negateInt64# Wrapper.negateInt64#
+ , testPrimop "plusInt64#" Primop.plusInt64# Wrapper.plusInt64#
+ , testPrimop "subInt64#" Primop.subInt64# Wrapper.subInt64#
+ , testPrimop "timesInt64#" Primop.timesInt64# Wrapper.timesInt64#
+ , testPrimopDivLike "quotInt64#" Primop.quotInt64# Wrapper.quotInt64#
+ , testPrimopDivLike "remInt64#" Primop.remInt64# Wrapper.remInt64#
+ , testPrimop "uncheckedIShiftL64#" Primop.uncheckedIShiftL64# Wrapper.uncheckedIShiftL64#
+ , testPrimop "uncheckedIShiftRA64#" Primop.uncheckedIShiftRA64# Wrapper.uncheckedIShiftRA64#
+ , testPrimop "uncheckedIShiftRL64#" Primop.uncheckedIShiftRL64# Wrapper.uncheckedIShiftRL64#
+ , testPrimop "int64ToWord64#" Primop.int64ToWord64# Wrapper.int64ToWord64#
+ , testPrimop "eqInt64#" Primop.eqInt64# Wrapper.eqInt64#
+ , testPrimop "geInt64#" Primop.geInt64# Wrapper.geInt64#
+ , testPrimop "gtInt64#" Primop.gtInt64# Wrapper.gtInt64#
+ , testPrimop "leInt64#" Primop.leInt64# Wrapper.leInt64#
+ , testPrimop "ltInt64#" Primop.ltInt64# Wrapper.ltInt64#
+ , testPrimop "neInt64#" Primop.neInt64# Wrapper.neInt64#
+ , testPrimop "word64ToWord#" Primop.word64ToWord# Wrapper.word64ToWord#
+ , testPrimop "wordToWord64#" Primop.wordToWord64# Wrapper.wordToWord64#
+ , testPrimop "plusWord64#" Primop.plusWord64# Wrapper.plusWord64#
+ , testPrimop "subWord64#" Primop.subWord64# Wrapper.subWord64#
+ , testPrimop "timesWord64#" Primop.timesWord64# Wrapper.timesWord64#
+ , testPrimopDivLike "quotWord64#" Primop.quotWord64# Wrapper.quotWord64#
+ , testPrimopDivLike "remWord64#" Primop.remWord64# Wrapper.remWord64#
+ , testPrimop "and64#" Primop.and64# Wrapper.and64#
+ , testPrimop "or64#" Primop.or64# Wrapper.or64#
+ , testPrimop "xor64#" Primop.xor64# Wrapper.xor64#
+ , testPrimop "not64#" Primop.not64# Wrapper.not64#
+ , testPrimop "uncheckedShiftL64#" Primop.uncheckedShiftL64# Wrapper.uncheckedShiftL64#
+ , testPrimop "uncheckedShiftRL64#" Primop.uncheckedShiftRL64# Wrapper.uncheckedShiftRL64#
+ , testPrimop "word64ToInt64#" Primop.word64ToInt64# Wrapper.word64ToInt64#
+ , testPrimop "eqWord64#" Primop.eqWord64# Wrapper.eqWord64#
+ , testPrimop "geWord64#" Primop.geWord64# Wrapper.geWord64#
+ , testPrimop "gtWord64#" Primop.gtWord64# Wrapper.gtWord64#
+ , testPrimop "leWord64#" Primop.leWord64# Wrapper.leWord64#
+ , testPrimop "ltWord64#" Primop.ltWord64# Wrapper.ltWord64#
+ , testPrimop "neWord64#" Primop.neWord64# Wrapper.neWord64#
+ , testPrimop "+#" (Primop.+#) (Wrapper.+#)
+ , testPrimop "-#" (Primop.-#) (Wrapper.-#)
+ , testPrimop "*#" (Primop.*#) (Wrapper.*#)
+ , testPrimop "timesInt2#" Primop.timesInt2# Wrapper.timesInt2#
+ , testPrimop "mulIntMayOflo#" Primop.mulIntMayOflo# Wrapper.mulIntMayOflo#
+ , testPrimopDivLike "quotInt#" Primop.quotInt# Wrapper.quotInt#
+ , testPrimopDivLike "remInt#" Primop.remInt# Wrapper.remInt#
+ , testPrimopDivLike "quotRemInt#" Primop.quotRemInt# Wrapper.quotRemInt#
+ , testPrimop "andI#" Primop.andI# Wrapper.andI#
+ , testPrimop "orI#" Primop.orI# Wrapper.orI#
+ , testPrimop "xorI#" Primop.xorI# Wrapper.xorI#
+ , testPrimop "notI#" Primop.notI# Wrapper.notI#
+ , testPrimop "negateInt#" Primop.negateInt# Wrapper.negateInt#
+ , testPrimop "addIntC#" Primop.addIntC# Wrapper.addIntC#
+ , testPrimop "subIntC#" Primop.subIntC# Wrapper.subIntC#
+ , testPrimop ">#" (Primop.>#) (Wrapper.>#)
+ , testPrimop ">=#" (Primop.>=#) (Wrapper.>=#)
+ , testPrimop "==#" (Primop.==#) (Wrapper.==#)
+ , testPrimop "/=#" (Primop./=#) (Wrapper./=#)
+ , testPrimop "<#" (Primop.<#) (Wrapper.<#)
+ , testPrimop "<=#" (Primop.<=#) (Wrapper.<=#)
+ , testPrimop "chr#" Primop.chr# Wrapper.chr#
+ , testPrimop "int2Word#" Primop.int2Word# Wrapper.int2Word#
+ , testPrimop "uncheckedIShiftL#" Primop.uncheckedIShiftL# Wrapper.uncheckedIShiftL#
+ , testPrimop "uncheckedIShiftRA#" Primop.uncheckedIShiftRA# Wrapper.uncheckedIShiftRA#
+ , testPrimop "uncheckedIShiftRL#" Primop.uncheckedIShiftRL# Wrapper.uncheckedIShiftRL#
+ , testPrimop "plusWord#" Primop.plusWord# Wrapper.plusWord#
+ , testPrimop "addWordC#" Primop.addWordC# Wrapper.addWordC#
+ , testPrimop "subWordC#" Primop.subWordC# Wrapper.subWordC#
+ , testPrimop "plusWord2#" Primop.plusWord2# Wrapper.plusWord2#
+ , testPrimop "minusWord#" Primop.minusWord# Wrapper.minusWord#
+ , testPrimop "timesWord#" Primop.timesWord# Wrapper.timesWord#
+ , testPrimop "timesWord2#" Primop.timesWord2# Wrapper.timesWord2#
+ , testPrimopDivLike "quotWord#" Primop.quotWord# Wrapper.quotWord#
+ , testPrimopDivLike "remWord#" Primop.remWord# Wrapper.remWord#
+ , testPrimopDivLike "quotRemWord#" Primop.quotRemWord# Wrapper.quotRemWord#
+ , testPrimop "and#" Primop.and# Wrapper.and#
+ , testPrimop "or#" Primop.or# Wrapper.or#
+ , testPrimop "xor#" Primop.xor# Wrapper.xor#
+ , testPrimop "not#" Primop.not# Wrapper.not#
+ , testPrimop "uncheckedShiftL#" Primop.uncheckedShiftL# Wrapper.uncheckedShiftL#
+ , testPrimop "uncheckedShiftRL#" Primop.uncheckedShiftRL# Wrapper.uncheckedShiftRL#
+ , testPrimop "word2Int#" Primop.word2Int# Wrapper.word2Int#
+ , testPrimop "gtWord#" Primop.gtWord# Wrapper.gtWord#
+ , testPrimop "geWord#" Primop.geWord# Wrapper.geWord#
+ , testPrimop "eqWord#" Primop.eqWord# Wrapper.eqWord#
+ , testPrimop "neWord#" Primop.neWord# Wrapper.neWord#
+ , testPrimop "ltWord#" Primop.ltWord# Wrapper.ltWord#
+ , testPrimop "leWord#" Primop.leWord# Wrapper.leWord#
+ , testPrimop "popCnt8#" Primop.popCnt8# Wrapper.popCnt8#
+ , testPrimop "popCnt16#" Primop.popCnt16# Wrapper.popCnt16#
+ , testPrimop "popCnt32#" Primop.popCnt32# Wrapper.popCnt32#
+ , testPrimop "popCnt64#" Primop.popCnt64# Wrapper.popCnt64#
+ , testPrimop "popCnt#" Primop.popCnt# Wrapper.popCnt#
+ , testPrimop "pdep8#" Primop.pdep8# Wrapper.pdep8#
+ , testPrimop "pdep16#" Primop.pdep16# Wrapper.pdep16#
+ , testPrimop "pdep32#" Primop.pdep32# Wrapper.pdep32#
+ , testPrimop "pdep64#" Primop.pdep64# Wrapper.pdep64#
+ , testPrimop "pdep#" Primop.pdep# Wrapper.pdep#
+ , testPrimop "pext8#" Primop.pext8# Wrapper.pext8#
+ , testPrimop "pext16#" Primop.pext16# Wrapper.pext16#
+ , testPrimop "pext32#" Primop.pext32# Wrapper.pext32#
+ , testPrimop "pext64#" Primop.pext64# Wrapper.pext64#
+ , testPrimop "pext#" Primop.pext# Wrapper.pext#
+ , testPrimop "clz8#" Primop.clz8# Wrapper.clz8#
+ , testPrimop "clz16#" Primop.clz16# Wrapper.clz16#
+ , testPrimop "clz32#" Primop.clz32# Wrapper.clz32#
+ , testPrimop "clz64#" Primop.clz64# Wrapper.clz64#
+ , testPrimop "clz#" Primop.clz# Wrapper.clz#
+ , testPrimop "ctz8#" Primop.ctz8# Wrapper.ctz8#
+ , testPrimop "ctz16#" Primop.ctz16# Wrapper.ctz16#
+ , testPrimop "ctz32#" Primop.ctz32# Wrapper.ctz32#
+ , testPrimop "ctz64#" Primop.ctz64# Wrapper.ctz64#
+ , testPrimop "ctz#" Primop.ctz# Wrapper.ctz#
+ , testPrimop "byteSwap16#" Primop.byteSwap16# Wrapper.byteSwap16#
+ , testPrimop "byteSwap32#" Primop.byteSwap32# Wrapper.byteSwap32#
+ , testPrimop "byteSwap64#" Primop.byteSwap64# Wrapper.byteSwap64#
+ , testPrimop "byteSwap#" Primop.byteSwap# Wrapper.byteSwap#
+ , testPrimop "bitReverse8#" Primop.bitReverse8# Wrapper.bitReverse8#
+ , testPrimop "bitReverse16#" Primop.bitReverse16# Wrapper.bitReverse16#
+ , testPrimop "bitReverse32#" Primop.bitReverse32# Wrapper.bitReverse32#
+ , testPrimop "bitReverse64#" Primop.bitReverse64# Wrapper.bitReverse64#
+ , testPrimop "bitReverse#" Primop.bitReverse# Wrapper.bitReverse#
+ , testPrimop "narrow8Int#" Primop.narrow8Int# Wrapper.narrow8Int#
+ , testPrimop "narrow16Int#" Primop.narrow16Int# Wrapper.narrow16Int#
+ , testPrimop "narrow32Int#" Primop.narrow32Int# Wrapper.narrow32Int#
+ , testPrimop "narrow8Word#" Primop.narrow8Word# Wrapper.narrow8Word#
+ , testPrimop "narrow16Word#" Primop.narrow16Word# Wrapper.narrow16Word#
+ , testPrimop "narrow32Word#" Primop.narrow32Word# Wrapper.narrow32Word#
+ ]
+
+instance TestPrimop (Char# -> Char# -> Int#) where
+ testPrimop s l r = Property s $ \ (uChar#-> x0) (uChar#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
+
+instance TestPrimop (Char# -> Int#) where
+ testPrimop s l r = Property s $ \ (uChar#-> x0) -> wInt# (l x0) === wInt# (r x0)
+
+instance TestPrimop (Int# -> Int# -> Int#) where
+ testPrimop s l r = Property s $ \ (uInt#-> x0) (uInt#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
+ testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt#-> x0) (uInt#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
+
+instance TestPrimop (Int# -> Int# -> (# Int#,Int# #)) where
+ testPrimop s l r = Property s $ \ (uInt#-> x0) (uInt#-> x1) -> WTUP2(wInt#,wInt#, (l x0 x1)) === WTUP2(wInt#,wInt#, (r x0 x1))
+ testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt#-> x0) (uInt#-> x1) -> WTUP2(wInt#,wInt#, (l x0 x1)) === WTUP2(wInt#,wInt#, (r x0 x1))
+
+instance TestPrimop (Int# -> Int# -> (# Int#,Int#,Int# #)) where
+ testPrimop s l r = Property s $ \ (uInt#-> x0) (uInt#-> x1) -> WTUP3(wInt#,wInt#,wInt#, (l x0 x1)) === WTUP3(wInt#,wInt#,wInt#, (r x0 x1))
+ testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt#-> x0) (uInt#-> x1) -> WTUP3(wInt#,wInt#,wInt#, (l x0 x1)) === WTUP3(wInt#,wInt#,wInt#, (r x0 x1))
+
+instance TestPrimop (Int# -> Char#) where
+ testPrimop s l r = Property s $ \ (uInt#-> x0) -> wChar# (l x0) === wChar# (r x0)
+
+instance TestPrimop (Int# -> Int#) where
+ testPrimop s l r = Property s $ \ (uInt#-> x0) -> wInt# (l x0) === wInt# (r x0)
+
+instance TestPrimop (Int# -> Int16#) where
+ testPrimop s l r = Property s $ \ (uInt#-> x0) -> wInt16# (l x0) === wInt16# (r x0)
+
+instance TestPrimop (Int# -> Int32#) where
+ testPrimop s l r = Property s $ \ (uInt#-> x0) -> wInt32# (l x0) === wInt32# (r x0)
+
+instance TestPrimop (Int# -> Int64#) where
+ testPrimop s l r = Property s $ \ (uInt#-> x0) -> wInt64# (l x0) === wInt64# (r x0)
+
+instance TestPrimop (Int# -> Int8#) where
+ testPrimop s l r = Property s $ \ (uInt#-> x0) -> wInt8# (l x0) === wInt8# (r x0)
+
+instance TestPrimop (Int# -> Word#) where
+ testPrimop s l r = Property s $ \ (uInt#-> x0) -> wWord# (l x0) === wWord# (r x0)
+
+instance TestPrimop (Int16# -> Int# -> Int16#) where
+ testPrimop s l r = Property s $ \ (uInt16#-> x0) (uInt#-> x1) -> wInt16# (l x0 x1) === wInt16# (r x0 x1)
+
+instance TestPrimop (Int16# -> Int16# -> Int#) where
+ testPrimop s l r = Property s $ \ (uInt16#-> x0) (uInt16#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
+ testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt16#-> x0) (uInt16#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
+
+instance TestPrimop (Int16# -> Int16# -> Int16#) where
+ testPrimop s l r = Property s $ \ (uInt16#-> x0) (uInt16#-> x1) -> wInt16# (l x0 x1) === wInt16# (r x0 x1)
+ testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt16#-> x0) (uInt16#-> x1) -> wInt16# (l x0 x1) === wInt16# (r x0 x1)
+
+instance TestPrimop (Int16# -> Int16# -> (# Int16#,Int16# #)) where
+ testPrimop s l r = Property s $ \ (uInt16#-> x0) (uInt16#-> x1) -> WTUP2(wInt16#,wInt16#, (l x0 x1)) === WTUP2(wInt16#,wInt16#, (r x0 x1))
+ testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt16#-> x0) (uInt16#-> x1) -> WTUP2(wInt16#,wInt16#, (l x0 x1)) === WTUP2(wInt16#,wInt16#, (r x0 x1))
+
+instance TestPrimop (Int16# -> Int#) where
+ testPrimop s l r = Property s $ \ (uInt16#-> x0) -> wInt# (l x0) === wInt# (r x0)
+
+instance TestPrimop (Int16# -> Int16#) where
+ testPrimop s l r = Property s $ \ (uInt16#-> x0) -> wInt16# (l x0) === wInt16# (r x0)
+
+instance TestPrimop (Int16# -> Word16#) where
+ testPrimop s l r = Property s $ \ (uInt16#-> x0) -> wWord16# (l x0) === wWord16# (r x0)
+
+instance TestPrimop (Int32# -> Int# -> Int32#) where
+ testPrimop s l r = Property s $ \ (uInt32#-> x0) (uInt#-> x1) -> wInt32# (l x0 x1) === wInt32# (r x0 x1)
+
+instance TestPrimop (Int32# -> Int32# -> Int#) where
+ testPrimop s l r = Property s $ \ (uInt32#-> x0) (uInt32#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
+ testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt32#-> x0) (uInt32#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
+
+instance TestPrimop (Int32# -> Int32# -> Int32#) where
+ testPrimop s l r = Property s $ \ (uInt32#-> x0) (uInt32#-> x1) -> wInt32# (l x0 x1) === wInt32# (r x0 x1)
+ testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt32#-> x0) (uInt32#-> x1) -> wInt32# (l x0 x1) === wInt32# (r x0 x1)
+
+instance TestPrimop (Int32# -> Int32# -> (# Int32#,Int32# #)) where
+ testPrimop s l r = Property s $ \ (uInt32#-> x0) (uInt32#-> x1) -> WTUP2(wInt32#,wInt32#, (l x0 x1)) === WTUP2(wInt32#,wInt32#, (r x0 x1))
+ testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt32#-> x0) (uInt32#-> x1) -> WTUP2(wInt32#,wInt32#, (l x0 x1)) === WTUP2(wInt32#,wInt32#, (r x0 x1))
+
+instance TestPrimop (Int32# -> Int#) where
+ testPrimop s l r = Property s $ \ (uInt32#-> x0) -> wInt# (l x0) === wInt# (r x0)
+
+instance TestPrimop (Int32# -> Int32#) where
+ testPrimop s l r = Property s $ \ (uInt32#-> x0) -> wInt32# (l x0) === wInt32# (r x0)
+
+instance TestPrimop (Int32# -> Word32#) where
+ testPrimop s l r = Property s $ \ (uInt32#-> x0) -> wWord32# (l x0) === wWord32# (r x0)
+
+instance TestPrimop (Int64# -> Int# -> Int64#) where
+ testPrimop s l r = Property s $ \ (uInt64#-> x0) (uInt#-> x1) -> wInt64# (l x0 x1) === wInt64# (r x0 x1)
+
+instance TestPrimop (Int64# -> Int64# -> Int#) where
+ testPrimop s l r = Property s $ \ (uInt64#-> x0) (uInt64#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
+ testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt64#-> x0) (uInt64#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
+
+instance TestPrimop (Int64# -> Int64# -> Int64#) where
+ testPrimop s l r = Property s $ \ (uInt64#-> x0) (uInt64#-> x1) -> wInt64# (l x0 x1) === wInt64# (r x0 x1)
+ testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt64#-> x0) (uInt64#-> x1) -> wInt64# (l x0 x1) === wInt64# (r x0 x1)
+
+instance TestPrimop (Int64# -> Int#) where
+ testPrimop s l r = Property s $ \ (uInt64#-> x0) -> wInt# (l x0) === wInt# (r x0)
+
+instance TestPrimop (Int64# -> Int64#) where
+ testPrimop s l r = Property s $ \ (uInt64#-> x0) -> wInt64# (l x0) === wInt64# (r x0)
+
+instance TestPrimop (Int64# -> Word64#) where
+ testPrimop s l r = Property s $ \ (uInt64#-> x0) -> wWord64# (l x0) === wWord64# (r x0)
+
+instance TestPrimop (Int8# -> Int# -> Int8#) where
+ testPrimop s l r = Property s $ \ (uInt8#-> x0) (uInt#-> x1) -> wInt8# (l x0 x1) === wInt8# (r x0 x1)
+
+instance TestPrimop (Int8# -> Int8# -> Int#) where
+ testPrimop s l r = Property s $ \ (uInt8#-> x0) (uInt8#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
+ testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt8#-> x0) (uInt8#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
+
+instance TestPrimop (Int8# -> Int8# -> Int8#) where
+ testPrimop s l r = Property s $ \ (uInt8#-> x0) (uInt8#-> x1) -> wInt8# (l x0 x1) === wInt8# (r x0 x1)
+ testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt8#-> x0) (uInt8#-> x1) -> wInt8# (l x0 x1) === wInt8# (r x0 x1)
+
+instance TestPrimop (Int8# -> Int8# -> (# Int8#,Int8# #)) where
+ testPrimop s l r = Property s $ \ (uInt8#-> x0) (uInt8#-> x1) -> WTUP2(wInt8#,wInt8#, (l x0 x1)) === WTUP2(wInt8#,wInt8#, (r x0 x1))
+ testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt8#-> x0) (uInt8#-> x1) -> WTUP2(wInt8#,wInt8#, (l x0 x1)) === WTUP2(wInt8#,wInt8#, (r x0 x1))
+
+instance TestPrimop (Int8# -> Int#) where
+ testPrimop s l r = Property s $ \ (uInt8#-> x0) -> wInt# (l x0) === wInt# (r x0)
+
+instance TestPrimop (Int8# -> Int8#) where
+ testPrimop s l r = Property s $ \ (uInt8#-> x0) -> wInt8# (l x0) === wInt8# (r x0)
+
+instance TestPrimop (Int8# -> Word8#) where
+ testPrimop s l r = Property s $ \ (uInt8#-> x0) -> wWord8# (l x0) === wWord8# (r x0)
+
+instance TestPrimop (Word# -> Int# -> Word#) where
+ testPrimop s l r = Property s $ \ (uWord#-> x0) (uInt#-> x1) -> wWord# (l x0 x1) === wWord# (r x0 x1)
+
+instance TestPrimop (Word# -> Word# -> Int#) where
+ testPrimop s l r = Property s $ \ (uWord#-> x0) (uWord#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
+ testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord#-> x0) (uWord#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
+
+instance TestPrimop (Word# -> Word# -> Word#) where
+ testPrimop s l r = Property s $ \ (uWord#-> x0) (uWord#-> x1) -> wWord# (l x0 x1) === wWord# (r x0 x1)
+ testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord#-> x0) (uWord#-> x1) -> wWord# (l x0 x1) === wWord# (r x0 x1)
+
+instance TestPrimop (Word# -> Word# -> (# Word#,Int# #)) where
+ testPrimop s l r = Property s $ \ (uWord#-> x0) (uWord#-> x1) -> WTUP2(wWord#,wInt#, (l x0 x1)) === WTUP2(wWord#,wInt#, (r x0 x1))
+ testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord#-> x0) (uWord#-> x1) -> WTUP2(wWord#,wInt#, (l x0 x1)) === WTUP2(wWord#,wInt#, (r x0 x1))
+
+instance TestPrimop (Word# -> Word# -> (# Word#,Word# #)) where
+ testPrimop s l r = Property s $ \ (uWord#-> x0) (uWord#-> x1) -> WTUP2(wWord#,wWord#, (l x0 x1)) === WTUP2(wWord#,wWord#, (r x0 x1))
+ testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord#-> x0) (uWord#-> x1) -> WTUP2(wWord#,wWord#, (l x0 x1)) === WTUP2(wWord#,wWord#, (r x0 x1))
+
+instance TestPrimop (Word# -> Int#) where
+ testPrimop s l r = Property s $ \ (uWord#-> x0) -> wInt# (l x0) === wInt# (r x0)
+
+instance TestPrimop (Word# -> Word#) where
+ testPrimop s l r = Property s $ \ (uWord#-> x0) -> wWord# (l x0) === wWord# (r x0)
+
+instance TestPrimop (Word# -> Word16#) where
+ testPrimop s l r = Property s $ \ (uWord#-> x0) -> wWord16# (l x0) === wWord16# (r x0)
+
+instance TestPrimop (Word# -> Word32#) where
+ testPrimop s l r = Property s $ \ (uWord#-> x0) -> wWord32# (l x0) === wWord32# (r x0)
+
+instance TestPrimop (Word# -> Word64#) where
+ testPrimop s l r = Property s $ \ (uWord#-> x0) -> wWord64# (l x0) === wWord64# (r x0)
+
+instance TestPrimop (Word# -> Word8#) where
+ testPrimop s l r = Property s $ \ (uWord#-> x0) -> wWord8# (l x0) === wWord8# (r x0)
+
+instance TestPrimop (Word16# -> Int# -> Word16#) where
+ testPrimop s l r = Property s $ \ (uWord16#-> x0) (uInt#-> x1) -> wWord16# (l x0 x1) === wWord16# (r x0 x1)
+
+instance TestPrimop (Word16# -> Word16# -> Int#) where
+ testPrimop s l r = Property s $ \ (uWord16#-> x0) (uWord16#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
+ testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord16#-> x0) (uWord16#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
+
+instance TestPrimop (Word16# -> Word16# -> Word16#) where
+ testPrimop s l r = Property s $ \ (uWord16#-> x0) (uWord16#-> x1) -> wWord16# (l x0 x1) === wWord16# (r x0 x1)
+ testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord16#-> x0) (uWord16#-> x1) -> wWord16# (l x0 x1) === wWord16# (r x0 x1)
+
+instance TestPrimop (Word16# -> Word16# -> (# Word16#,Word16# #)) where
+ testPrimop s l r = Property s $ \ (uWord16#-> x0) (uWord16#-> x1) -> WTUP2(wWord16#,wWord16#, (l x0 x1)) === WTUP2(wWord16#,wWord16#, (r x0 x1))
+ testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord16#-> x0) (uWord16#-> x1) -> WTUP2(wWord16#,wWord16#, (l x0 x1)) === WTUP2(wWord16#,wWord16#, (r x0 x1))
+
+instance TestPrimop (Word16# -> Int16#) where
+ testPrimop s l r = Property s $ \ (uWord16#-> x0) -> wInt16# (l x0) === wInt16# (r x0)
+
+instance TestPrimop (Word16# -> Word#) where
+ testPrimop s l r = Property s $ \ (uWord16#-> x0) -> wWord# (l x0) === wWord# (r x0)
+
+instance TestPrimop (Word16# -> Word16#) where
+ testPrimop s l r = Property s $ \ (uWord16#-> x0) -> wWord16# (l x0) === wWord16# (r x0)
+
+instance TestPrimop (Word32# -> Int# -> Word32#) where
+ testPrimop s l r = Property s $ \ (uWord32#-> x0) (uInt#-> x1) -> wWord32# (l x0 x1) === wWord32# (r x0 x1)
+
+instance TestPrimop (Word32# -> Word32# -> Int#) where
+ testPrimop s l r = Property s $ \ (uWord32#-> x0) (uWord32#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
+ testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord32#-> x0) (uWord32#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
+
+instance TestPrimop (Word32# -> Word32# -> Word32#) where
+ testPrimop s l r = Property s $ \ (uWord32#-> x0) (uWord32#-> x1) -> wWord32# (l x0 x1) === wWord32# (r x0 x1)
+ testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord32#-> x0) (uWord32#-> x1) -> wWord32# (l x0 x1) === wWord32# (r x0 x1)
+
+instance TestPrimop (Word32# -> Word32# -> (# Word32#,Word32# #)) where
+ testPrimop s l r = Property s $ \ (uWord32#-> x0) (uWord32#-> x1) -> WTUP2(wWord32#,wWord32#, (l x0 x1)) === WTUP2(wWord32#,wWord32#, (r x0 x1))
+ testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord32#-> x0) (uWord32#-> x1) -> WTUP2(wWord32#,wWord32#, (l x0 x1)) === WTUP2(wWord32#,wWord32#, (r x0 x1))
+
+instance TestPrimop (Word32# -> Int32#) where
+ testPrimop s l r = Property s $ \ (uWord32#-> x0) -> wInt32# (l x0) === wInt32# (r x0)
+
+instance TestPrimop (Word32# -> Word#) where
+ testPrimop s l r = Property s $ \ (uWord32#-> x0) -> wWord# (l x0) === wWord# (r x0)
+
+instance TestPrimop (Word32# -> Word32#) where
+ testPrimop s l r = Property s $ \ (uWord32#-> x0) -> wWord32# (l x0) === wWord32# (r x0)
+
+instance TestPrimop (Word64# -> Int# -> Word64#) where
+ testPrimop s l r = Property s $ \ (uWord64#-> x0) (uInt#-> x1) -> wWord64# (l x0 x1) === wWord64# (r x0 x1)
+
+instance TestPrimop (Word64# -> Word64# -> Int#) where
+ testPrimop s l r = Property s $ \ (uWord64#-> x0) (uWord64#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
+ testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord64#-> x0) (uWord64#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
+
+instance TestPrimop (Word64# -> Word64# -> Word64#) where
+ testPrimop s l r = Property s $ \ (uWord64#-> x0) (uWord64#-> x1) -> wWord64# (l x0 x1) === wWord64# (r x0 x1)
+ testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord64#-> x0) (uWord64#-> x1) -> wWord64# (l x0 x1) === wWord64# (r x0 x1)
+
+instance TestPrimop (Word64# -> Int64#) where
+ testPrimop s l r = Property s $ \ (uWord64#-> x0) -> wInt64# (l x0) === wInt64# (r x0)
+
+instance TestPrimop (Word64# -> Word#) where
+ testPrimop s l r = Property s $ \ (uWord64#-> x0) -> wWord# (l x0) === wWord# (r x0)
+
+instance TestPrimop (Word64# -> Word64#) where
+ testPrimop s l r = Property s $ \ (uWord64#-> x0) -> wWord64# (l x0) === wWord64# (r x0)
+
+instance TestPrimop (Word8# -> Int# -> Word8#) where
+ testPrimop s l r = Property s $ \ (uWord8#-> x0) (uInt#-> x1) -> wWord8# (l x0 x1) === wWord8# (r x0 x1)
+
+instance TestPrimop (Word8# -> Word8# -> Int#) where
+ testPrimop s l r = Property s $ \ (uWord8#-> x0) (uWord8#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
+ testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord8#-> x0) (uWord8#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
+
+instance TestPrimop (Word8# -> Word8# -> Word8#) where
+ testPrimop s l r = Property s $ \ (uWord8#-> x0) (uWord8#-> x1) -> wWord8# (l x0 x1) === wWord8# (r x0 x1)
+ testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord8#-> x0) (uWord8#-> x1) -> wWord8# (l x0 x1) === wWord8# (r x0 x1)
+
+instance TestPrimop (Word8# -> Word8# -> (# Word8#,Word8# #)) where
+ testPrimop s l r = Property s $ \ (uWord8#-> x0) (uWord8#-> x1) -> WTUP2(wWord8#,wWord8#, (l x0 x1)) === WTUP2(wWord8#,wWord8#, (r x0 x1))
+ testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord8#-> x0) (uWord8#-> x1) -> WTUP2(wWord8#,wWord8#, (l x0 x1)) === WTUP2(wWord8#,wWord8#, (r x0 x1))
+
+instance TestPrimop (Word8# -> Int8#) where
+ testPrimop s l r = Property s $ \ (uWord8#-> x0) -> wInt8# (l x0) === wInt8# (r x0)
+instance TestPrimop (Word8# -> Word#) where
+ testPrimop s l r = Property s $ \ (uWord8#-> x0) -> wWord# (l x0) === wWord# (r x0)
-main = runTests testNumberRefs
+instance TestPrimop (Word8# -> Word8#) where
+ testPrimop s l r = Property s $ \ (uWord8#-> x0) -> wWord8# (l x0) === wWord8# (r x0)
=====================================
testsuite/tests/numeric/should_run/foundation.stdout
=====================================
@@ -1,540 +1,1050 @@
Group ALL
- Group Int
- Group Integral
- Running FromIntegral(Integer(a)) == a
- Passed 100 iterations
- Group Property
- Running Eq
- Passed 100 iterations
- Running Show
- Passed 100 iterations
- Running Ord
- Passed 100 iterations
- Running <
- Passed 100 iterations
- Group Additive
- Running a + azero == a
- Passed 100 iterations
- Running azero + a == a
- Passed 100 iterations
- Running a + b == b + a
- Passed 100 iterations
- Group Multiplicative
- Running a * 1 == a
- Passed 100 iterations
- Running 1 * a == a
- Passed 100 iterations
- Running multiplication commutative
- Passed 100 iterations
- Running a * b == Integer(a) * Integer(b)
- Passed 100 iterations
- Group Divisible
- Running (x `div` y) * y + (x `mod` y) == x
- Passed 100 iterations
- Group Precedence
- Running + and - (1)
- Passed 100 iterations
- Running + and - (2)
- Passed 100 iterations
- Running + and * (1)
- Passed 100 iterations
- Running + and * (2)
- Passed 100 iterations
- Running - and * (1)
- Passed 100 iterations
- Running - and * (2)
- Passed 100 iterations
- Running * and ^ (1)
- Passed 100 iterations
- Running * and ^ (2)
- Passed 100 iterations
- Group Int8
- Group Integral
- Running FromIntegral(Integer(a)) == a
- Passed 100 iterations
- Group Property
- Running Eq
- Passed 100 iterations
- Running Show
- Passed 100 iterations
- Running Ord
- Passed 100 iterations
- Running <
- Passed 100 iterations
- Group Additive
- Running a + azero == a
- Passed 100 iterations
- Running azero + a == a
- Passed 100 iterations
- Running a + b == b + a
- Passed 100 iterations
- Group Multiplicative
- Running a * 1 == a
- Passed 100 iterations
- Running 1 * a == a
- Passed 100 iterations
- Running multiplication commutative
- Passed 100 iterations
- Running a * b == Integer(a) * Integer(b)
- Passed 100 iterations
- Group Divisible
- Running (x `div` y) * y + (x `mod` y) == x
- Passed 100 iterations
- Group Precedence
- Running + and - (1)
- Passed 100 iterations
- Running + and - (2)
- Passed 100 iterations
- Running + and * (1)
- Passed 100 iterations
- Running + and * (2)
- Passed 100 iterations
- Running - and * (1)
- Passed 100 iterations
- Running - and * (2)
- Passed 100 iterations
- Running * and ^ (1)
- Passed 100 iterations
- Running * and ^ (2)
- Passed 100 iterations
- Group Int16
- Group Integral
- Running FromIntegral(Integer(a)) == a
- Passed 100 iterations
- Group Property
- Running Eq
- Passed 100 iterations
- Running Show
- Passed 100 iterations
- Running Ord
- Passed 100 iterations
- Running <
- Passed 100 iterations
- Group Additive
- Running a + azero == a
- Passed 100 iterations
- Running azero + a == a
- Passed 100 iterations
- Running a + b == b + a
- Passed 100 iterations
- Group Multiplicative
- Running a * 1 == a
- Passed 100 iterations
- Running 1 * a == a
- Passed 100 iterations
- Running multiplication commutative
- Passed 100 iterations
- Running a * b == Integer(a) * Integer(b)
- Passed 100 iterations
- Group Divisible
- Running (x `div` y) * y + (x `mod` y) == x
- Passed 100 iterations
- Group Precedence
- Running + and - (1)
- Passed 100 iterations
- Running + and - (2)
- Passed 100 iterations
- Running + and * (1)
- Passed 100 iterations
- Running + and * (2)
- Passed 100 iterations
- Running - and * (1)
- Passed 100 iterations
- Running - and * (2)
- Passed 100 iterations
- Running * and ^ (1)
- Passed 100 iterations
- Running * and ^ (2)
- Passed 100 iterations
- Group Int32
- Group Integral
- Running FromIntegral(Integer(a)) == a
- Passed 100 iterations
- Group Property
- Running Eq
- Passed 100 iterations
- Running Show
- Passed 100 iterations
- Running Ord
- Passed 100 iterations
- Running <
- Passed 100 iterations
- Group Additive
- Running a + azero == a
- Passed 100 iterations
- Running azero + a == a
- Passed 100 iterations
- Running a + b == b + a
- Passed 100 iterations
- Group Multiplicative
- Running a * 1 == a
- Passed 100 iterations
- Running 1 * a == a
- Passed 100 iterations
- Running multiplication commutative
- Passed 100 iterations
- Running a * b == Integer(a) * Integer(b)
- Passed 100 iterations
- Group Divisible
- Running (x `div` y) * y + (x `mod` y) == x
- Passed 100 iterations
- Group Precedence
- Running + and - (1)
- Passed 100 iterations
- Running + and - (2)
- Passed 100 iterations
- Running + and * (1)
- Passed 100 iterations
- Running + and * (2)
- Passed 100 iterations
- Running - and * (1)
- Passed 100 iterations
- Running - and * (2)
- Passed 100 iterations
- Running * and ^ (1)
- Passed 100 iterations
- Running * and ^ (2)
- Passed 100 iterations
- Group Int64
- Group Integral
- Running FromIntegral(Integer(a)) == a
- Passed 100 iterations
- Group Property
- Running Eq
- Passed 100 iterations
- Running Show
- Passed 100 iterations
- Running Ord
- Passed 100 iterations
- Running <
- Passed 100 iterations
- Group Additive
- Running a + azero == a
- Passed 100 iterations
- Running azero + a == a
- Passed 100 iterations
- Running a + b == b + a
- Passed 100 iterations
- Group Multiplicative
- Running a * 1 == a
- Passed 100 iterations
- Running 1 * a == a
- Passed 100 iterations
- Running multiplication commutative
- Passed 100 iterations
- Running a * b == Integer(a) * Integer(b)
- Passed 100 iterations
- Group Divisible
- Running (x `div` y) * y + (x `mod` y) == x
- Passed 100 iterations
- Group Precedence
- Running + and - (1)
- Passed 100 iterations
- Running + and - (2)
- Passed 100 iterations
- Running + and * (1)
- Passed 100 iterations
- Running + and * (2)
- Passed 100 iterations
- Running - and * (1)
- Passed 100 iterations
- Running - and * (2)
- Passed 100 iterations
- Running * and ^ (1)
- Passed 100 iterations
- Running * and ^ (2)
- Passed 100 iterations
- Group Integer
- Group Integral
- Running FromIntegral(Integer(a)) == a
- Passed 100 iterations
- Group Property
- Running Eq
- Passed 100 iterations
- Running Show
- Passed 100 iterations
- Running Ord
- Passed 100 iterations
- Running <
- Passed 100 iterations
- Group Additive
- Running a + azero == a
- Passed 100 iterations
- Running azero + a == a
- Passed 100 iterations
- Running a + b == b + a
- Passed 100 iterations
- Group Multiplicative
- Running a * 1 == a
- Passed 100 iterations
- Running 1 * a == a
- Passed 100 iterations
- Running multiplication commutative
- Passed 100 iterations
- Running a * b == Integer(a) * Integer(b)
- Passed 100 iterations
- Group Divisible
- Running (x `div` y) * y + (x `mod` y) == x
- Passed 100 iterations
- Group Precedence
- Running + and - (1)
- Passed 100 iterations
- Running + and - (2)
- Passed 100 iterations
- Running + and * (1)
- Passed 100 iterations
- Running + and * (2)
- Passed 100 iterations
- Running - and * (1)
- Passed 100 iterations
- Running - and * (2)
- Passed 100 iterations
- Running * and ^ (1)
- Passed 100 iterations
- Running * and ^ (2)
- Passed 100 iterations
- Group Word
- Group Integral
- Running FromIntegral(Integer(a)) == a
- Passed 100 iterations
- Group Property
- Running Eq
- Passed 100 iterations
- Running Show
- Passed 100 iterations
- Running Ord
- Passed 100 iterations
- Running <
- Passed 100 iterations
- Group Additive
- Running a + azero == a
- Passed 100 iterations
- Running azero + a == a
- Passed 100 iterations
- Running a + b == b + a
- Passed 100 iterations
- Group Multiplicative
- Running a * 1 == a
- Passed 100 iterations
- Running 1 * a == a
- Passed 100 iterations
- Running multiplication commutative
- Passed 100 iterations
- Running a * b == Integer(a) * Integer(b)
- Passed 100 iterations
- Group Divisible
- Running (x `div` y) * y + (x `mod` y) == x
- Passed 100 iterations
- Group Precedence
- Running + and - (1)
- Passed 100 iterations
- Running + and - (2)
- Passed 100 iterations
- Running + and * (1)
- Passed 100 iterations
- Running + and * (2)
- Passed 100 iterations
- Running - and * (1)
- Passed 100 iterations
- Running - and * (2)
- Passed 100 iterations
- Running * and ^ (1)
- Passed 100 iterations
- Running * and ^ (2)
- Passed 100 iterations
- Group Word8
- Group Integral
- Running FromIntegral(Integer(a)) == a
- Passed 100 iterations
- Group Property
- Running Eq
- Passed 100 iterations
- Running Show
- Passed 100 iterations
- Running Ord
- Passed 100 iterations
- Running <
- Passed 100 iterations
- Group Additive
- Running a + azero == a
- Passed 100 iterations
- Running azero + a == a
- Passed 100 iterations
- Running a + b == b + a
- Passed 100 iterations
- Group Multiplicative
- Running a * 1 == a
- Passed 100 iterations
- Running 1 * a == a
- Passed 100 iterations
- Running multiplication commutative
- Passed 100 iterations
- Running a * b == Integer(a) * Integer(b)
- Passed 100 iterations
- Group Divisible
- Running (x `div` y) * y + (x `mod` y) == x
- Passed 100 iterations
- Group Precedence
- Running + and - (1)
- Passed 100 iterations
- Running + and - (2)
- Passed 100 iterations
- Running + and * (1)
- Passed 100 iterations
- Running + and * (2)
- Passed 100 iterations
- Running - and * (1)
- Passed 100 iterations
- Running - and * (2)
- Passed 100 iterations
- Running * and ^ (1)
- Passed 100 iterations
- Running * and ^ (2)
- Passed 100 iterations
- Group Word16
- Group Integral
- Running FromIntegral(Integer(a)) == a
- Passed 100 iterations
- Group Property
- Running Eq
- Passed 100 iterations
- Running Show
- Passed 100 iterations
- Running Ord
- Passed 100 iterations
- Running <
- Passed 100 iterations
- Group Additive
- Running a + azero == a
- Passed 100 iterations
- Running azero + a == a
- Passed 100 iterations
- Running a + b == b + a
- Passed 100 iterations
- Group Multiplicative
- Running a * 1 == a
- Passed 100 iterations
- Running 1 * a == a
- Passed 100 iterations
- Running multiplication commutative
- Passed 100 iterations
- Running a * b == Integer(a) * Integer(b)
- Passed 100 iterations
- Group Divisible
- Running (x `div` y) * y + (x `mod` y) == x
- Passed 100 iterations
- Group Precedence
- Running + and - (1)
- Passed 100 iterations
- Running + and - (2)
- Passed 100 iterations
- Running + and * (1)
- Passed 100 iterations
- Running + and * (2)
- Passed 100 iterations
- Running - and * (1)
- Passed 100 iterations
- Running - and * (2)
- Passed 100 iterations
- Running * and ^ (1)
- Passed 100 iterations
- Running * and ^ (2)
- Passed 100 iterations
- Group Word32
- Group Integral
- Running FromIntegral(Integer(a)) == a
- Passed 100 iterations
- Group Property
- Running Eq
- Passed 100 iterations
- Running Show
- Passed 100 iterations
- Running Ord
- Passed 100 iterations
- Running <
- Passed 100 iterations
- Group Additive
- Running a + azero == a
- Passed 100 iterations
- Running azero + a == a
- Passed 100 iterations
- Running a + b == b + a
- Passed 100 iterations
- Group Multiplicative
- Running a * 1 == a
- Passed 100 iterations
- Running 1 * a == a
- Passed 100 iterations
- Running multiplication commutative
- Passed 100 iterations
- Running a * b == Integer(a) * Integer(b)
- Passed 100 iterations
- Group Divisible
- Running (x `div` y) * y + (x `mod` y) == x
- Passed 100 iterations
- Group Precedence
- Running + and - (1)
- Passed 100 iterations
- Running + and - (2)
- Passed 100 iterations
- Running + and * (1)
- Passed 100 iterations
- Running + and * (2)
- Passed 100 iterations
- Running - and * (1)
- Passed 100 iterations
- Running - and * (2)
- Passed 100 iterations
- Running * and ^ (1)
- Passed 100 iterations
- Running * and ^ (2)
- Passed 100 iterations
- Group Word64
- Group Integral
- Running FromIntegral(Integer(a)) == a
- Passed 100 iterations
- Group Property
- Running Eq
- Passed 100 iterations
- Running Show
- Passed 100 iterations
- Running Ord
- Passed 100 iterations
- Running <
- Passed 100 iterations
- Group Additive
- Running a + azero == a
- Passed 100 iterations
- Running azero + a == a
- Passed 100 iterations
- Running a + b == b + a
- Passed 100 iterations
- Group Multiplicative
- Running a * 1 == a
- Passed 100 iterations
- Running 1 * a == a
- Passed 100 iterations
- Running multiplication commutative
- Passed 100 iterations
- Running a * b == Integer(a) * Integer(b)
- Passed 100 iterations
- Group Divisible
- Running (x `div` y) * y + (x `mod` y) == x
- Passed 100 iterations
- Group Precedence
- Running + and - (1)
- Passed 100 iterations
- Running + and - (2)
- Passed 100 iterations
- Running + and * (1)
- Passed 100 iterations
- Running + and * (2)
- Passed 100 iterations
- Running - and * (1)
- Passed 100 iterations
- Running - and * (2)
- Passed 100 iterations
- Running * and ^ (1)
- Passed 100 iterations
- Running * and ^ (2)
- Passed 100 iterations
+ Group ALL
+ Group Int
+ Group Integral
+ Running FromIntegral(Integer(a)) == a
+ Passed 100 iterations
+ Group Property
+ Running Eq
+ Passed 100 iterations
+ Running Show
+ Passed 100 iterations
+ Running Ord
+ Passed 100 iterations
+ Running <
+ Passed 100 iterations
+ Group Additive
+ Running a + azero == a
+ Passed 100 iterations
+ Running azero + a == a
+ Passed 100 iterations
+ Running a + b == b + a
+ Passed 100 iterations
+ Group Multiplicative
+ Running a * 1 == a
+ Passed 100 iterations
+ Running 1 * a == a
+ Passed 100 iterations
+ Running multiplication commutative
+ Passed 100 iterations
+ Running a * b == Integer(a) * Integer(b)
+ Passed 100 iterations
+ Group Divisible
+ Running (x `div` y) * y + (x `mod` y) == x
+ Passed 100 iterations
+ Group Precedence
+ Running + and - (1)
+ Passed 100 iterations
+ Running + and - (2)
+ Passed 100 iterations
+ Running + and * (1)
+ Passed 100 iterations
+ Running + and * (2)
+ Passed 100 iterations
+ Running - and * (1)
+ Passed 100 iterations
+ Running - and * (2)
+ Passed 100 iterations
+ Running * and ^ (1)
+ Passed 100 iterations
+ Running * and ^ (2)
+ Passed 100 iterations
+ Group Int8
+ Group Integral
+ Running FromIntegral(Integer(a)) == a
+ Passed 100 iterations
+ Group Property
+ Running Eq
+ Passed 100 iterations
+ Running Show
+ Passed 100 iterations
+ Running Ord
+ Passed 100 iterations
+ Running <
+ Passed 100 iterations
+ Group Additive
+ Running a + azero == a
+ Passed 100 iterations
+ Running azero + a == a
+ Passed 100 iterations
+ Running a + b == b + a
+ Passed 100 iterations
+ Group Multiplicative
+ Running a * 1 == a
+ Passed 100 iterations
+ Running 1 * a == a
+ Passed 100 iterations
+ Running multiplication commutative
+ Passed 100 iterations
+ Running a * b == Integer(a) * Integer(b)
+ Passed 100 iterations
+ Group Divisible
+ Running (x `div` y) * y + (x `mod` y) == x
+ Passed 100 iterations
+ Group Precedence
+ Running + and - (1)
+ Passed 100 iterations
+ Running + and - (2)
+ Passed 100 iterations
+ Running + and * (1)
+ Passed 100 iterations
+ Running + and * (2)
+ Passed 100 iterations
+ Running - and * (1)
+ Passed 100 iterations
+ Running - and * (2)
+ Passed 100 iterations
+ Running * and ^ (1)
+ Passed 100 iterations
+ Running * and ^ (2)
+ Passed 100 iterations
+ Group Int16
+ Group Integral
+ Running FromIntegral(Integer(a)) == a
+ Passed 100 iterations
+ Group Property
+ Running Eq
+ Passed 100 iterations
+ Running Show
+ Passed 100 iterations
+ Running Ord
+ Passed 100 iterations
+ Running <
+ Passed 100 iterations
+ Group Additive
+ Running a + azero == a
+ Passed 100 iterations
+ Running azero + a == a
+ Passed 100 iterations
+ Running a + b == b + a
+ Passed 100 iterations
+ Group Multiplicative
+ Running a * 1 == a
+ Passed 100 iterations
+ Running 1 * a == a
+ Passed 100 iterations
+ Running multiplication commutative
+ Passed 100 iterations
+ Running a * b == Integer(a) * Integer(b)
+ Passed 100 iterations
+ Group Divisible
+ Running (x `div` y) * y + (x `mod` y) == x
+ Passed 100 iterations
+ Group Precedence
+ Running + and - (1)
+ Passed 100 iterations
+ Running + and - (2)
+ Passed 100 iterations
+ Running + and * (1)
+ Passed 100 iterations
+ Running + and * (2)
+ Passed 100 iterations
+ Running - and * (1)
+ Passed 100 iterations
+ Running - and * (2)
+ Passed 100 iterations
+ Running * and ^ (1)
+ Passed 100 iterations
+ Running * and ^ (2)
+ Passed 100 iterations
+ Group Int32
+ Group Integral
+ Running FromIntegral(Integer(a)) == a
+ Passed 100 iterations
+ Group Property
+ Running Eq
+ Passed 100 iterations
+ Running Show
+ Passed 100 iterations
+ Running Ord
+ Passed 100 iterations
+ Running <
+ Passed 100 iterations
+ Group Additive
+ Running a + azero == a
+ Passed 100 iterations
+ Running azero + a == a
+ Passed 100 iterations
+ Running a + b == b + a
+ Passed 100 iterations
+ Group Multiplicative
+ Running a * 1 == a
+ Passed 100 iterations
+ Running 1 * a == a
+ Passed 100 iterations
+ Running multiplication commutative
+ Passed 100 iterations
+ Running a * b == Integer(a) * Integer(b)
+ Passed 100 iterations
+ Group Divisible
+ Running (x `div` y) * y + (x `mod` y) == x
+ Passed 100 iterations
+ Group Precedence
+ Running + and - (1)
+ Passed 100 iterations
+ Running + and - (2)
+ Passed 100 iterations
+ Running + and * (1)
+ Passed 100 iterations
+ Running + and * (2)
+ Passed 100 iterations
+ Running - and * (1)
+ Passed 100 iterations
+ Running - and * (2)
+ Passed 100 iterations
+ Running * and ^ (1)
+ Passed 100 iterations
+ Running * and ^ (2)
+ Passed 100 iterations
+ Group Int64
+ Group Integral
+ Running FromIntegral(Integer(a)) == a
+ Passed 100 iterations
+ Group Property
+ Running Eq
+ Passed 100 iterations
+ Running Show
+ Passed 100 iterations
+ Running Ord
+ Passed 100 iterations
+ Running <
+ Passed 100 iterations
+ Group Additive
+ Running a + azero == a
+ Passed 100 iterations
+ Running azero + a == a
+ Passed 100 iterations
+ Running a + b == b + a
+ Passed 100 iterations
+ Group Multiplicative
+ Running a * 1 == a
+ Passed 100 iterations
+ Running 1 * a == a
+ Passed 100 iterations
+ Running multiplication commutative
+ Passed 100 iterations
+ Running a * b == Integer(a) * Integer(b)
+ Passed 100 iterations
+ Group Divisible
+ Running (x `div` y) * y + (x `mod` y) == x
+ Passed 100 iterations
+ Group Precedence
+ Running + and - (1)
+ Passed 100 iterations
+ Running + and - (2)
+ Passed 100 iterations
+ Running + and * (1)
+ Passed 100 iterations
+ Running + and * (2)
+ Passed 100 iterations
+ Running - and * (1)
+ Passed 100 iterations
+ Running - and * (2)
+ Passed 100 iterations
+ Running * and ^ (1)
+ Passed 100 iterations
+ Running * and ^ (2)
+ Passed 100 iterations
+ Group Integer
+ Group Integral
+ Running FromIntegral(Integer(a)) == a
+ Passed 100 iterations
+ Group Property
+ Running Eq
+ Passed 100 iterations
+ Running Show
+ Passed 100 iterations
+ Running Ord
+ Passed 100 iterations
+ Running <
+ Passed 100 iterations
+ Group Additive
+ Running a + azero == a
+ Passed 100 iterations
+ Running azero + a == a
+ Passed 100 iterations
+ Running a + b == b + a
+ Passed 100 iterations
+ Group Multiplicative
+ Running a * 1 == a
+ Passed 100 iterations
+ Running 1 * a == a
+ Passed 100 iterations
+ Running multiplication commutative
+ Passed 100 iterations
+ Running a * b == Integer(a) * Integer(b)
+ Passed 100 iterations
+ Group Divisible
+ Running (x `div` y) * y + (x `mod` y) == x
+ Passed 100 iterations
+ Group Precedence
+ Running + and - (1)
+ Passed 100 iterations
+ Running + and - (2)
+ Passed 100 iterations
+ Running + and * (1)
+ Passed 100 iterations
+ Running + and * (2)
+ Passed 100 iterations
+ Running - and * (1)
+ Passed 100 iterations
+ Running - and * (2)
+ Passed 100 iterations
+ Running * and ^ (1)
+ Passed 100 iterations
+ Running * and ^ (2)
+ Passed 100 iterations
+ Group Word
+ Group Integral
+ Running FromIntegral(Integer(a)) == a
+ Passed 100 iterations
+ Group Property
+ Running Eq
+ Passed 100 iterations
+ Running Show
+ Passed 100 iterations
+ Running Ord
+ Passed 100 iterations
+ Running <
+ Passed 100 iterations
+ Group Additive
+ Running a + azero == a
+ Passed 100 iterations
+ Running azero + a == a
+ Passed 100 iterations
+ Running a + b == b + a
+ Passed 100 iterations
+ Group Multiplicative
+ Running a * 1 == a
+ Passed 100 iterations
+ Running 1 * a == a
+ Passed 100 iterations
+ Running multiplication commutative
+ Passed 100 iterations
+ Running a * b == Integer(a) * Integer(b)
+ Passed 100 iterations
+ Group Divisible
+ Running (x `div` y) * y + (x `mod` y) == x
+ Passed 100 iterations
+ Group Precedence
+ Running + and - (1)
+ Passed 100 iterations
+ Running + and - (2)
+ Passed 100 iterations
+ Running + and * (1)
+ Passed 100 iterations
+ Running + and * (2)
+ Passed 100 iterations
+ Running - and * (1)
+ Passed 100 iterations
+ Running - and * (2)
+ Passed 100 iterations
+ Running * and ^ (1)
+ Passed 100 iterations
+ Running * and ^ (2)
+ Passed 100 iterations
+ Group Word8
+ Group Integral
+ Running FromIntegral(Integer(a)) == a
+ Passed 100 iterations
+ Group Property
+ Running Eq
+ Passed 100 iterations
+ Running Show
+ Passed 100 iterations
+ Running Ord
+ Passed 100 iterations
+ Running <
+ Passed 100 iterations
+ Group Additive
+ Running a + azero == a
+ Passed 100 iterations
+ Running azero + a == a
+ Passed 100 iterations
+ Running a + b == b + a
+ Passed 100 iterations
+ Group Multiplicative
+ Running a * 1 == a
+ Passed 100 iterations
+ Running 1 * a == a
+ Passed 100 iterations
+ Running multiplication commutative
+ Passed 100 iterations
+ Running a * b == Integer(a) * Integer(b)
+ Passed 100 iterations
+ Group Divisible
+ Running (x `div` y) * y + (x `mod` y) == x
+ Passed 100 iterations
+ Group Precedence
+ Running + and - (1)
+ Passed 100 iterations
+ Running + and - (2)
+ Passed 100 iterations
+ Running + and * (1)
+ Passed 100 iterations
+ Running + and * (2)
+ Passed 100 iterations
+ Running - and * (1)
+ Passed 100 iterations
+ Running - and * (2)
+ Passed 100 iterations
+ Running * and ^ (1)
+ Passed 100 iterations
+ Running * and ^ (2)
+ Passed 100 iterations
+ Group Word16
+ Group Integral
+ Running FromIntegral(Integer(a)) == a
+ Passed 100 iterations
+ Group Property
+ Running Eq
+ Passed 100 iterations
+ Running Show
+ Passed 100 iterations
+ Running Ord
+ Passed 100 iterations
+ Running <
+ Passed 100 iterations
+ Group Additive
+ Running a + azero == a
+ Passed 100 iterations
+ Running azero + a == a
+ Passed 100 iterations
+ Running a + b == b + a
+ Passed 100 iterations
+ Group Multiplicative
+ Running a * 1 == a
+ Passed 100 iterations
+ Running 1 * a == a
+ Passed 100 iterations
+ Running multiplication commutative
+ Passed 100 iterations
+ Running a * b == Integer(a) * Integer(b)
+ Passed 100 iterations
+ Group Divisible
+ Running (x `div` y) * y + (x `mod` y) == x
+ Passed 100 iterations
+ Group Precedence
+ Running + and - (1)
+ Passed 100 iterations
+ Running + and - (2)
+ Passed 100 iterations
+ Running + and * (1)
+ Passed 100 iterations
+ Running + and * (2)
+ Passed 100 iterations
+ Running - and * (1)
+ Passed 100 iterations
+ Running - and * (2)
+ Passed 100 iterations
+ Running * and ^ (1)
+ Passed 100 iterations
+ Running * and ^ (2)
+ Passed 100 iterations
+ Group Word32
+ Group Integral
+ Running FromIntegral(Integer(a)) == a
+ Passed 100 iterations
+ Group Property
+ Running Eq
+ Passed 100 iterations
+ Running Show
+ Passed 100 iterations
+ Running Ord
+ Passed 100 iterations
+ Running <
+ Passed 100 iterations
+ Group Additive
+ Running a + azero == a
+ Passed 100 iterations
+ Running azero + a == a
+ Passed 100 iterations
+ Running a + b == b + a
+ Passed 100 iterations
+ Group Multiplicative
+ Running a * 1 == a
+ Passed 100 iterations
+ Running 1 * a == a
+ Passed 100 iterations
+ Running multiplication commutative
+ Passed 100 iterations
+ Running a * b == Integer(a) * Integer(b)
+ Passed 100 iterations
+ Group Divisible
+ Running (x `div` y) * y + (x `mod` y) == x
+ Passed 100 iterations
+ Group Precedence
+ Running + and - (1)
+ Passed 100 iterations
+ Running + and - (2)
+ Passed 100 iterations
+ Running + and * (1)
+ Passed 100 iterations
+ Running + and * (2)
+ Passed 100 iterations
+ Running - and * (1)
+ Passed 100 iterations
+ Running - and * (2)
+ Passed 100 iterations
+ Running * and ^ (1)
+ Passed 100 iterations
+ Running * and ^ (2)
+ Passed 100 iterations
+ Group Word64
+ Group Integral
+ Running FromIntegral(Integer(a)) == a
+ Passed 100 iterations
+ Group Property
+ Running Eq
+ Passed 100 iterations
+ Running Show
+ Passed 100 iterations
+ Running Ord
+ Passed 100 iterations
+ Running <
+ Passed 100 iterations
+ Group Additive
+ Running a + azero == a
+ Passed 100 iterations
+ Running azero + a == a
+ Passed 100 iterations
+ Running a + b == b + a
+ Passed 100 iterations
+ Group Multiplicative
+ Running a * 1 == a
+ Passed 100 iterations
+ Running 1 * a == a
+ Passed 100 iterations
+ Running multiplication commutative
+ Passed 100 iterations
+ Running a * b == Integer(a) * Integer(b)
+ Passed 100 iterations
+ Group Divisible
+ Running (x `div` y) * y + (x `mod` y) == x
+ Passed 100 iterations
+ Group Precedence
+ Running + and - (1)
+ Passed 100 iterations
+ Running + and - (2)
+ Passed 100 iterations
+ Running + and * (1)
+ Passed 100 iterations
+ Running + and * (2)
+ Passed 100 iterations
+ Running - and * (1)
+ Passed 100 iterations
+ Running - and * (2)
+ Passed 100 iterations
+ Running * and ^ (1)
+ Passed 100 iterations
+ Running * and ^ (2)
+ Passed 100 iterations
+ Group primop
+ Running gtChar#
+ Passed 100 iterations
+ Running geChar#
+ Passed 100 iterations
+ Running eqChar#
+ Passed 100 iterations
+ Running neChar#
+ Passed 100 iterations
+ Running ltChar#
+ Passed 100 iterations
+ Running leChar#
+ Passed 100 iterations
+ Running ord#
+ Passed 100 iterations
+ Running int8ToInt#
+ Passed 100 iterations
+ Running intToInt8#
+ Passed 100 iterations
+ Running negateInt8#
+ Passed 100 iterations
+ Running plusInt8#
+ Passed 100 iterations
+ Running subInt8#
+ Passed 100 iterations
+ Running timesInt8#
+ Passed 100 iterations
+ Running quotInt8#
+ Passed 100 iterations
+ Running remInt8#
+ Passed 100 iterations
+ Running quotRemInt8#
+ Passed 100 iterations
+ Running uncheckedShiftLInt8#
+ Passed 100 iterations
+ Running uncheckedShiftRAInt8#
+ Passed 100 iterations
+ Running uncheckedShiftRLInt8#
+ Passed 100 iterations
+ Running int8ToWord8#
+ Passed 100 iterations
+ Running eqInt8#
+ Passed 100 iterations
+ Running geInt8#
+ Passed 100 iterations
+ Running gtInt8#
+ Passed 100 iterations
+ Running leInt8#
+ Passed 100 iterations
+ Running ltInt8#
+ Passed 100 iterations
+ Running neInt8#
+ Passed 100 iterations
+ Running word8ToWord#
+ Passed 100 iterations
+ Running wordToWord8#
+ Passed 100 iterations
+ Running plusWord8#
+ Passed 100 iterations
+ Running subWord8#
+ Passed 100 iterations
+ Running timesWord8#
+ Passed 100 iterations
+ Running quotWord8#
+ Passed 100 iterations
+ Running remWord8#
+ Passed 100 iterations
+ Running quotRemWord8#
+ Passed 100 iterations
+ Running andWord8#
+ Passed 100 iterations
+ Running orWord8#
+ Passed 100 iterations
+ Running xorWord8#
+ Passed 100 iterations
+ Running notWord8#
+ Passed 100 iterations
+ Running uncheckedShiftLWord8#
+ Passed 100 iterations
+ Running uncheckedShiftRLWord8#
+ Passed 100 iterations
+ Running word8ToInt8#
+ Passed 100 iterations
+ Running eqWord8#
+ Passed 100 iterations
+ Running geWord8#
+ Passed 100 iterations
+ Running gtWord8#
+ Passed 100 iterations
+ Running leWord8#
+ Passed 100 iterations
+ Running ltWord8#
+ Passed 100 iterations
+ Running neWord8#
+ Passed 100 iterations
+ Running int16ToInt#
+ Passed 100 iterations
+ Running intToInt16#
+ Passed 100 iterations
+ Running negateInt16#
+ Passed 100 iterations
+ Running plusInt16#
+ Passed 100 iterations
+ Running subInt16#
+ Passed 100 iterations
+ Running timesInt16#
+ Passed 100 iterations
+ Running quotInt16#
+ Passed 100 iterations
+ Running remInt16#
+ Passed 100 iterations
+ Running quotRemInt16#
+ Passed 100 iterations
+ Running uncheckedShiftLInt16#
+ Passed 100 iterations
+ Running uncheckedShiftRAInt16#
+ Passed 100 iterations
+ Running uncheckedShiftRLInt16#
+ Passed 100 iterations
+ Running int16ToWord16#
+ Passed 100 iterations
+ Running eqInt16#
+ Passed 100 iterations
+ Running geInt16#
+ Passed 100 iterations
+ Running gtInt16#
+ Passed 100 iterations
+ Running leInt16#
+ Passed 100 iterations
+ Running ltInt16#
+ Passed 100 iterations
+ Running neInt16#
+ Passed 100 iterations
+ Running word16ToWord#
+ Passed 100 iterations
+ Running wordToWord16#
+ Passed 100 iterations
+ Running plusWord16#
+ Passed 100 iterations
+ Running subWord16#
+ Passed 100 iterations
+ Running timesWord16#
+ Passed 100 iterations
+ Running quotWord16#
+ Passed 100 iterations
+ Running remWord16#
+ Passed 100 iterations
+ Running quotRemWord16#
+ Passed 100 iterations
+ Running andWord16#
+ Passed 100 iterations
+ Running orWord16#
+ Passed 100 iterations
+ Running xorWord16#
+ Passed 100 iterations
+ Running notWord16#
+ Passed 100 iterations
+ Running uncheckedShiftLWord16#
+ Passed 100 iterations
+ Running uncheckedShiftRLWord16#
+ Passed 100 iterations
+ Running word16ToInt16#
+ Passed 100 iterations
+ Running eqWord16#
+ Passed 100 iterations
+ Running geWord16#
+ Passed 100 iterations
+ Running gtWord16#
+ Passed 100 iterations
+ Running leWord16#
+ Passed 100 iterations
+ Running ltWord16#
+ Passed 100 iterations
+ Running neWord16#
+ Passed 100 iterations
+ Running int32ToInt#
+ Passed 100 iterations
+ Running intToInt32#
+ Passed 100 iterations
+ Running negateInt32#
+ Passed 100 iterations
+ Running plusInt32#
+ Passed 100 iterations
+ Running subInt32#
+ Passed 100 iterations
+ Running timesInt32#
+ Passed 100 iterations
+ Running quotInt32#
+ Passed 100 iterations
+ Running remInt32#
+ Passed 100 iterations
+ Running quotRemInt32#
+ Passed 100 iterations
+ Running uncheckedShiftLInt32#
+ Passed 100 iterations
+ Running uncheckedShiftRAInt32#
+ Passed 100 iterations
+ Running uncheckedShiftRLInt32#
+ Passed 100 iterations
+ Running int32ToWord32#
+ Passed 100 iterations
+ Running eqInt32#
+ Passed 100 iterations
+ Running geInt32#
+ Passed 100 iterations
+ Running gtInt32#
+ Passed 100 iterations
+ Running leInt32#
+ Passed 100 iterations
+ Running ltInt32#
+ Passed 100 iterations
+ Running neInt32#
+ Passed 100 iterations
+ Running word32ToWord#
+ Passed 100 iterations
+ Running wordToWord32#
+ Passed 100 iterations
+ Running plusWord32#
+ Passed 100 iterations
+ Running subWord32#
+ Passed 100 iterations
+ Running timesWord32#
+ Passed 100 iterations
+ Running quotWord32#
+ Passed 100 iterations
+ Running remWord32#
+ Passed 100 iterations
+ Running quotRemWord32#
+ Passed 100 iterations
+ Running andWord32#
+ Passed 100 iterations
+ Running orWord32#
+ Passed 100 iterations
+ Running xorWord32#
+ Passed 100 iterations
+ Running notWord32#
+ Passed 100 iterations
+ Running uncheckedShiftLWord32#
+ Passed 100 iterations
+ Running uncheckedShiftRLWord32#
+ Passed 100 iterations
+ Running word32ToInt32#
+ Passed 100 iterations
+ Running eqWord32#
+ Passed 100 iterations
+ Running geWord32#
+ Passed 100 iterations
+ Running gtWord32#
+ Passed 100 iterations
+ Running leWord32#
+ Passed 100 iterations
+ Running ltWord32#
+ Passed 100 iterations
+ Running neWord32#
+ Passed 100 iterations
+ Running int64ToInt#
+ Passed 100 iterations
+ Running intToInt64#
+ Passed 100 iterations
+ Running negateInt64#
+ Passed 100 iterations
+ Running plusInt64#
+ Passed 100 iterations
+ Running subInt64#
+ Passed 100 iterations
+ Running timesInt64#
+ Passed 100 iterations
+ Running quotInt64#
+ Passed 100 iterations
+ Running remInt64#
+ Passed 100 iterations
+ Running uncheckedIShiftL64#
+ Passed 100 iterations
+ Running uncheckedIShiftRA64#
+ Passed 100 iterations
+ Running uncheckedIShiftRL64#
+ Passed 100 iterations
+ Running int64ToWord64#
+ Passed 100 iterations
+ Running eqInt64#
+ Passed 100 iterations
+ Running geInt64#
+ Passed 100 iterations
+ Running gtInt64#
+ Passed 100 iterations
+ Running leInt64#
+ Passed 100 iterations
+ Running ltInt64#
+ Passed 100 iterations
+ Running neInt64#
+ Passed 100 iterations
+ Running word64ToWord#
+ Passed 100 iterations
+ Running wordToWord64#
+ Passed 100 iterations
+ Running plusWord64#
+ Passed 100 iterations
+ Running subWord64#
+ Passed 100 iterations
+ Running timesWord64#
+ Passed 100 iterations
+ Running quotWord64#
+ Passed 100 iterations
+ Running remWord64#
+ Passed 100 iterations
+ Running and64#
+ Passed 100 iterations
+ Running or64#
+ Passed 100 iterations
+ Running xor64#
+ Passed 100 iterations
+ Running not64#
+ Passed 100 iterations
+ Running uncheckedShiftL64#
+ Passed 100 iterations
+ Running uncheckedShiftRL64#
+ Passed 100 iterations
+ Running word64ToInt64#
+ Passed 100 iterations
+ Running eqWord64#
+ Passed 100 iterations
+ Running geWord64#
+ Passed 100 iterations
+ Running gtWord64#
+ Passed 100 iterations
+ Running leWord64#
+ Passed 100 iterations
+ Running ltWord64#
+ Passed 100 iterations
+ Running neWord64#
+ Passed 100 iterations
+ Running +#
+ Passed 100 iterations
+ Running -#
+ Passed 100 iterations
+ Running *#
+ Passed 100 iterations
+ Running timesInt2#
+ Passed 100 iterations
+ Running mulIntMayOflo#
+ Passed 100 iterations
+ Running quotInt#
+ Passed 100 iterations
+ Running remInt#
+ Passed 100 iterations
+ Running quotRemInt#
+ Passed 100 iterations
+ Running andI#
+ Passed 100 iterations
+ Running orI#
+ Passed 100 iterations
+ Running xorI#
+ Passed 100 iterations
+ Running notI#
+ Passed 100 iterations
+ Running negateInt#
+ Passed 100 iterations
+ Running addIntC#
+ Passed 100 iterations
+ Running subIntC#
+ Passed 100 iterations
+ Running >#
+ Passed 100 iterations
+ Running >=#
+ Passed 100 iterations
+ Running ==#
+ Passed 100 iterations
+ Running /=#
+ Passed 100 iterations
+ Running <#
+ Passed 100 iterations
+ Running <=#
+ Passed 100 iterations
+ Running chr#
+ Passed 100 iterations
+ Running int2Word#
+ Passed 100 iterations
+ Running uncheckedIShiftL#
+ Passed 100 iterations
+ Running uncheckedIShiftRA#
+ Passed 100 iterations
+ Running uncheckedIShiftRL#
+ Passed 100 iterations
+ Running plusWord#
+ Passed 100 iterations
+ Running addWordC#
+ Passed 100 iterations
+ Running subWordC#
+ Passed 100 iterations
+ Running plusWord2#
+ Passed 100 iterations
+ Running minusWord#
+ Passed 100 iterations
+ Running timesWord#
+ Passed 100 iterations
+ Running timesWord2#
+ Passed 100 iterations
+ Running quotWord#
+ Passed 100 iterations
+ Running remWord#
+ Passed 100 iterations
+ Running quotRemWord#
+ Passed 100 iterations
+ Running and#
+ Passed 100 iterations
+ Running or#
+ Passed 100 iterations
+ Running xor#
+ Passed 100 iterations
+ Running not#
+ Passed 100 iterations
+ Running uncheckedShiftL#
+ Passed 100 iterations
+ Running uncheckedShiftRL#
+ Passed 100 iterations
+ Running word2Int#
+ Passed 100 iterations
+ Running gtWord#
+ Passed 100 iterations
+ Running geWord#
+ Passed 100 iterations
+ Running eqWord#
+ Passed 100 iterations
+ Running neWord#
+ Passed 100 iterations
+ Running ltWord#
+ Passed 100 iterations
+ Running leWord#
+ Passed 100 iterations
+ Running popCnt8#
+ Passed 100 iterations
+ Running popCnt16#
+ Passed 100 iterations
+ Running popCnt32#
+ Passed 100 iterations
+ Running popCnt64#
+ Passed 100 iterations
+ Running popCnt#
+ Passed 100 iterations
+ Running pdep8#
+ Passed 100 iterations
+ Running pdep16#
+ Passed 100 iterations
+ Running pdep32#
+ Passed 100 iterations
+ Running pdep64#
+ Passed 100 iterations
+ Running pdep#
+ Passed 100 iterations
+ Running pext8#
+ Passed 100 iterations
+ Running pext16#
+ Passed 100 iterations
+ Running pext32#
+ Passed 100 iterations
+ Running pext64#
+ Passed 100 iterations
+ Running pext#
+ Passed 100 iterations
+ Running clz8#
+ Passed 100 iterations
+ Running clz16#
+ Passed 100 iterations
+ Running clz32#
+ Passed 100 iterations
+ Running clz64#
+ Passed 100 iterations
+ Running clz#
+ Passed 100 iterations
+ Running ctz8#
+ Passed 100 iterations
+ Running ctz16#
+ Passed 100 iterations
+ Running ctz32#
+ Passed 100 iterations
+ Running ctz64#
+ Passed 100 iterations
+ Running ctz#
+ Passed 100 iterations
+ Running byteSwap16#
+ Passed 100 iterations
+ Running byteSwap32#
+ Passed 100 iterations
+ Running byteSwap64#
+ Passed 100 iterations
+ Running byteSwap#
+ Passed 100 iterations
+ Running bitReverse8#
+ Passed 100 iterations
+ Running bitReverse16#
+ Passed 100 iterations
+ Running bitReverse32#
+ Passed 100 iterations
+ Running bitReverse64#
+ Passed 100 iterations
+ Running bitReverse#
+ Passed 100 iterations
+ Running narrow8Int#
+ Passed 100 iterations
+ Running narrow16Int#
+ Passed 100 iterations
+ Running narrow32Int#
+ Passed 100 iterations
+ Running narrow8Word#
+ Passed 100 iterations
+ Running narrow16Word#
+ Passed 100 iterations
+ Running narrow32Word#
+ Passed 100 iterations
=====================================
utils/genprimopcode/Main.hs
=====================================
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -Wno-x-partial #-}
------------------------------------------------------------------
-- A primop-table mangling program --
--
@@ -10,11 +11,12 @@ import Parser
import Syntax
import Data.Char
-import Data.List (union, intersperse, intercalate, nub)
-import Data.Maybe ( catMaybes )
+import Data.List (union, intersperse, intercalate, nub, sort)
+import Data.Maybe ( catMaybes, mapMaybe )
import System.Environment ( getArgs )
import System.IO ( hSetEncoding, stdin, stdout, utf8 )
+
vecOptions :: Entry -> [(String,String,Int)]
vecOptions i =
concat [vecs | OptionVector vecs <- opts i]
@@ -204,6 +206,9 @@ main = getArgs >>= \args ->
"--wired-in-deprecations"
-> putStr (gen_wired_in_deprecations p_o_specs)
+ "--foundation-tests"
+ -> putStr (gen_foundation_tests p_o_specs)
+
_ -> error "Should not happen, known_args out of sync?"
)
@@ -229,7 +234,8 @@ known_args
"--make-haskell-source",
"--make-latex-doc",
"--wired-in-docs",
- "--wired-in-deprecations"
+ "--wired-in-deprecations",
+ "--foundation-tests"
]
------------------------------------------------------------------
@@ -679,6 +685,92 @@ gen_wired_in_deprecations (Info _ entries)
| otherwise = Nothing
+gen_foundation_tests :: Info -> String
+gen_foundation_tests (Info _ entries)
+ = "tests =\n [ "
+ ++ intercalate "\n , " (catMaybes $ map mkTest entries)
+ ++ "\n ]\n"
+ ++ "\n" ++ intercalate "\n" (map mkInstances testable_tys)
+ where
+ testable_tys = nub (sort (mapMaybe (\po -> ty po <$ mkTest po) entries))
+
+ mkInstances inst_ty =
+ let test_lambda = "\\ " ++ intercalate " " (zipWith mkArg [0::Int ..] (arg_tys)) ++ " -> " ++ mk_body "l" ++ " === " ++ mk_body "r"
+ in unlines $
+ [ "instance TestPrimop (" ++ pprTy inst_ty ++ ") where"
+ , " testPrimop s l r = Property s $ " ++ test_lambda ]
+ ++ (if mb_divable_tys
+ then [" testPrimopDivLike s l r = Property s $ twoNonZero $ " ++ test_lambda]
+ else [])
+ where
+ arg_tys = args inst_ty
+ -- eg Int -> Int -> a
+ mb_divable_tys = case arg_tys of
+ [ty1,ty2] -> ty1 == ty2 && ty1 `elem` divableTyCons
+ _ -> False
+
+ mk_body s = res_ty inst_ty (" (" ++ s ++ " " ++ intercalate " " vs ++ ")")
+
+ vs = zipWith (\n _ -> "x" ++ show n) [0::Int ..] (arg_tys)
+
+ mkArg n t = "(" ++ unwrapper t ++ "-> x" ++ show n ++ ")"
+
+
+ wrapper s = "w" ++ s
+ unwrapper s = "u" ++ s
+
+
+ args (TyF (TyApp (TyCon c) []) t2) = c : args t2
+ args (TyApp {}) = []
+ args (TyUTup {}) = []
+ -- If you hit this you will need to handle the foundation tests to handle the
+ -- type it failed on.
+ args arg_ty = error ("Unexpected primop type:" ++ pprTy arg_ty)
+
+ res_ty (TyF _ t2) x = res_ty t2 x
+ res_ty (TyApp (TyCon c) []) x = wrapper c ++ x
+ res_ty (TyUTup tup_tys) x =
+ let wtup = case length tup_tys of
+ 2 -> "WTUP2"
+ 3 -> "WTUP3"
+ -- Only handles primops returning unboxed tuples up to 3 args currently
+ _ -> error "Unexpected primop result type"
+ in wtup ++"(" ++ intercalate "," (map (\a -> res_ty a "") tup_tys ++ [x]) ++ ")"
+ -- If you hit this you will need to handle the foundation tests to handle the
+ -- type it failed on.
+ res_ty unexpected_ty x = error ("Unexpected primop result type:" ++ pprTy unexpected_ty ++ "," ++ x)
+
+
+ wrap qual nm | isLower (head nm) = qual ++ "." ++ nm
+ | otherwise = "(" ++ qual ++ "." ++ nm ++ ")"
+ mkTest po
+ | Just poName <- getName po
+ , is_primop po
+ , not $ is_vector po
+ , poName /= "tagToEnum#"
+ , poName /= "quotRemWord2#"
+ , (testable (ty po))
+ = let testPrimOpHow = if is_divLikeOp po
+ then "testPrimopDivLike"
+ else "testPrimop"
+ in Just $ intercalate " " [testPrimOpHow, "\"" ++ poName ++ "\"", wrap "Primop" poName, wrap "Wrapper" poName]
+ | otherwise = Nothing
+
+
+
+ testable (TyF t1 t2) = testable t1 && testable t2
+ testable (TyC _ t2) = testable t2
+ testable (TyApp tc tys) = testableTyCon tc && all testable tys
+ testable (TyVar _a) = False
+ testable (TyUTup tys) = all testable tys
+
+ testableTyCon (TyCon c) =
+ c `elem` ["Int#", "Word#", "Word8#", "Word16#", "Word32#", "Word64#"
+ , "Int8#", "Int16#", "Int32#", "Int64#", "Char#"]
+ testableTyCon _ = False
+ divableTyCons = ["Int#", "Word#", "Word8#", "Word16#", "Word32#", "Word64#"
+ ,"Int8#", "Int16#", "Int32#", "Int64#"]
+
------------------------------------------------------------------
-- Create PrimOpInfo text from PrimOpSpecs -----------------------
------------------------------------------------------------------
=====================================
utils/genprimopcode/Syntax.hs
=====================================
@@ -53,6 +53,19 @@ is_primtype :: Entry -> Bool
is_primtype (PrimTypeSpec {}) = True
is_primtype _ = False
+is_divLikeOp :: Entry -> Bool
+is_divLikeOp entry = case entry of
+ PrimOpSpec{} -> has_div_like
+ PseudoOpSpec{} -> has_div_like
+ PrimVecOpSpec{} -> has_div_like
+ PrimTypeSpec{} -> False
+ PrimVecTypeSpec{} -> False
+ Section{} -> False
+ where
+ has_div_like = case lookup_attrib "div_like" (opts entry) of
+ Just (OptionTrue{}) -> True
+ _ -> False
+
-- a binding of property to value
data Option
= OptionFalse String -- name = False
@@ -78,7 +91,7 @@ data Ty
| TyVar TyVar
| TyUTup [Ty] -- unboxed tuples; just a TyCon really,
-- but convenient like this
- deriving (Eq,Show)
+ deriving (Eq,Show, Ord)
type TyVar = String
type TyVarBinder = String
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/13b97782cb25bcc98d0a87d666748fa…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/13b97782cb25bcc98d0a87d666748fa…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/T25974] Put updated clang toolchain into bootstrap compiler's `mingw` folder
by Serge S. Gulin (＠gulin.serge) 09 May '25
by Serge S. Gulin (＠gulin.serge) 09 May '25
09 May '25
Serge S. Gulin pushed to branch wip/T25974 at Glasgow Haskell Compiler / GHC
Commits:
3ccf3c01 by Serge S. Gulin at 2025-05-09T15:41:07+04:00
Put updated clang toolchain into bootstrap compiler's `mingw` folder
- - - - -
3 changed files:
- .gitlab-ci.yml
- .gitlab/generate-ci/gen_ci.hs
- .gitlab/jobs.yaml
Changes:
=====================================
.gitlab-ci.yml
=====================================
@@ -2,7 +2,7 @@ variables:
GIT_SSL_NO_VERIFY: "1"
# Commit of ghc/ci-images repository from which to pull Docker images
- DOCKER_REV: 14b23867eebc6d5f43e79dab32304175e2416797
+ DOCKER_REV: 8f318609d86acfbf3f0cc6a05784e14ba259080d
# Sequential version number of all cached things.
# Bump to invalidate GitLab CI cache.
=====================================
.gitlab/generate-ci/gen_ci.hs
=====================================
@@ -1361,7 +1361,7 @@ cross_jobs = [
makeWineArmJobs =
let
- llvm_path = "C:/msys64/opt/llvm-mingw-windows/bin"
+ llvm_path = "C:/msys64/opt/ghc-bootstrap/mingw/bin"
llvm_prefix = llvm_path ++ "/aarch64-w64-mingw32-"
exe_suffix = ".exe"
-- See Note [Windows Toolchain Standard Library Options]
=====================================
.gitlab/jobs.yaml
=====================================
@@ -530,37 +530,37 @@
"aarch64-linux"
],
"variables": {
- "AR": "C:/msys64/opt/llvm-mingw-windows/bin/aarch64-w64-mingw32-llvm-ar.exe",
+ "AR": "C:/msys64/opt/ghc-bootstrap/mingw/bin/aarch64-w64-mingw32-llvm-ar.exe",
"BIGNUM_BACKEND": "native",
"BIN_DIST_NAME": "ghc-aarch64-linux-deb12-wine-int_native-cross_aarch64-unknown-mingw32-validate-_wine_full_build",
"BUILD_FLAVOUR": "validate",
- "CC": "C:/msys64/opt/llvm-mingw-windows/bin/aarch64-w64-mingw32-clang",
- "CC_STAGE0": "C:/msys64/opt/llvm-mingw-windows/bin/x86_64-w64-mingw32-clang",
- "CFLAGS": "-fuse-ld=C:/msys64/opt/llvm-mingw-windows/bin/ld.lld --rtlib=compiler-rt -D_UCRT",
+ "CC": "C:/msys64/opt/ghc-bootstrap/mingw/bin/aarch64-w64-mingw32-clang",
+ "CC_STAGE0": "C:/msys64/opt/ghc-bootstrap/mingw/bin/x86_64-w64-mingw32-clang",
+ "CFLAGS": "-fuse-ld=C:/msys64/opt/ghc-bootstrap/mingw/bin/ld.lld --rtlib=compiler-rt -D_UCRT",
"CONFIGURE_ARGS": "--with-intree-gmp --enable-strict-ghc-toolchain-check --build=x86_64-unknown-mingw32 --host=x86_64-unknown-mingw32",
- "CONF_CC_OPTS_STAGE0": "--target=x86_64-unknown-mingw32 -fuse-ld=C:/msys64/opt/llvm-mingw-windows/bin/ld.lld --rtlib=compiler-rt -D_UCRT",
- "CONF_CC_OPTS_STAGE1": "-fuse-ld=C:/msys64/opt/llvm-mingw-windows/bin/ld.lld --rtlib=compiler-rt -D_UCRT",
- "CONF_CC_OPTS_STAGE2": "-fuse-ld=C:/msys64/opt/llvm-mingw-windows/bin/ld.lld --rtlib=compiler-rt -D_UCRT",
+ "CONF_CC_OPTS_STAGE0": "--target=x86_64-unknown-mingw32 -fuse-ld=C:/msys64/opt/ghc-bootstrap/mingw/bin/ld.lld --rtlib=compiler-rt -D_UCRT",
+ "CONF_CC_OPTS_STAGE1": "-fuse-ld=C:/msys64/opt/ghc-bootstrap/mingw/bin/ld.lld --rtlib=compiler-rt -D_UCRT",
+ "CONF_CC_OPTS_STAGE2": "-fuse-ld=C:/msys64/opt/ghc-bootstrap/mingw/bin/ld.lld --rtlib=compiler-rt -D_UCRT",
"CROSS_EMULATOR": "/opt/wine-arm64ec-msys2-deb12/bin/wine",
"CROSS_TARGET": "aarch64-unknown-mingw32",
- "CXX": "C:/msys64/opt/llvm-mingw-windows/bin/aarch64-w64-mingw32-clang++",
- "DLLTOOL": "C:/msys64/opt/llvm-mingw-windows/bin/dlltool.exe",
+ "CXX": "C:/msys64/opt/ghc-bootstrap/mingw/bin/aarch64-w64-mingw32-clang++",
+ "DLLTOOL": "C:/msys64/opt/ghc-bootstrap/mingw/bin/dlltool.exe",
"HADRIAN_ARGS": "--docs=none",
"INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
- "LD": "C:/msys64/opt/llvm-mingw-windows/bin/aarch64-w64-mingw32-ld",
- "LLVMAS": "C:/msys64/opt/llvm-mingw-windows/bin/aarch64-w64-mingw32-clang",
+ "LD": "C:/msys64/opt/ghc-bootstrap/mingw/bin/aarch64-w64-mingw32-ld",
+ "LLVMAS": "C:/msys64/opt/ghc-bootstrap/mingw/bin/aarch64-w64-mingw32-clang",
"MergeObjsCmd": "",
- "NM": "C:/msys64/opt/llvm-mingw-windows/bin/aarch64-w64-mingw32-nm.exe",
- "OBJCOPY": "C:/msys64/opt/llvm-mingw-windows/bin/aarch64-w64-mingw32-objcopy",
- "OBJDUMP": "C:/msys64/opt/llvm-mingw-windows/bin/aarch64-w64-mingw32-objdump",
- "RANLIB": "C:/msys64/opt/llvm-mingw-windows/bin/aarch64-w64-mingw32-llvm-ranlib.exe",
+ "NM": "C:/msys64/opt/ghc-bootstrap/mingw/bin/aarch64-w64-mingw32-nm.exe",
+ "OBJCOPY": "C:/msys64/opt/ghc-bootstrap/mingw/bin/aarch64-w64-mingw32-objcopy",
+ "OBJDUMP": "C:/msys64/opt/ghc-bootstrap/mingw/bin/aarch64-w64-mingw32-objdump",
+ "RANLIB": "C:/msys64/opt/ghc-bootstrap/mingw/bin/aarch64-w64-mingw32-llvm-ranlib.exe",
"RUNTEST_ARGS": "",
- "SIZE": "C:/msys64/opt/llvm-mingw-windows/bin/aarch64-w64-mingw32-size",
- "STRINGS": "C:/msys64/opt/llvm-mingw-windows/bin/aarch64-w64-mingw32-strings",
- "STRIP": "C:/msys64/opt/llvm-mingw-windows/bin/aarch64-w64-mingw32-strip",
+ "SIZE": "C:/msys64/opt/ghc-bootstrap/mingw/bin/aarch64-w64-mingw32-size",
+ "STRINGS": "C:/msys64/opt/ghc-bootstrap/mingw/bin/aarch64-w64-mingw32-strings",
+ "STRIP": "C:/msys64/opt/ghc-bootstrap/mingw/bin/aarch64-w64-mingw32-strip",
"TEST_ENV": "aarch64-linux-deb12-wine-int_native-cross_aarch64-unknown-mingw32-validate-_wine_full_build",
"TOOLCHAIN_SOURCE": "env",
- "WindresCmd": "C:/msys64/opt/llvm-mingw-windows/bin/aarch64-w64-mingw32-windres"
+ "WindresCmd": "C:/msys64/opt/ghc-bootstrap/mingw/bin/aarch64-w64-mingw32-windres"
}
},
"i386-linux-alpine3_20-validate": {
@@ -1287,37 +1287,37 @@
"aarch64-linux"
],
"variables": {
- "AR": "C:/msys64/opt/llvm-mingw-windows/bin/aarch64-w64-mingw32-llvm-ar.exe",
+ "AR": "C:/msys64/opt/ghc-bootstrap/mingw/bin/aarch64-w64-mingw32-llvm-ar.exe",
"BIGNUM_BACKEND": "native",
"BIN_DIST_NAME": "ghc-aarch64-linux-deb12-wine-int_native-cross_aarch64-unknown-mingw32-validate-_wine_full_build",
"BUILD_FLAVOUR": "validate",
- "CC": "C:/msys64/opt/llvm-mingw-windows/bin/aarch64-w64-mingw32-clang",
- "CC_STAGE0": "C:/msys64/opt/llvm-mingw-windows/bin/x86_64-w64-mingw32-clang",
- "CFLAGS": "-fuse-ld=C:/msys64/opt/llvm-mingw-windows/bin/ld.lld --rtlib=compiler-rt -D_UCRT",
+ "CC": "C:/msys64/opt/ghc-bootstrap/mingw/bin/aarch64-w64-mingw32-clang",
+ "CC_STAGE0": "C:/msys64/opt/ghc-bootstrap/mingw/bin/x86_64-w64-mingw32-clang",
+ "CFLAGS": "-fuse-ld=C:/msys64/opt/ghc-bootstrap/mingw/bin/ld.lld --rtlib=compiler-rt -D_UCRT",
"CONFIGURE_ARGS": "--with-intree-gmp --enable-strict-ghc-toolchain-check --build=x86_64-unknown-mingw32 --host=x86_64-unknown-mingw32",
- "CONF_CC_OPTS_STAGE0": "--target=x86_64-unknown-mingw32 -fuse-ld=C:/msys64/opt/llvm-mingw-windows/bin/ld.lld --rtlib=compiler-rt -D_UCRT",
- "CONF_CC_OPTS_STAGE1": "-fuse-ld=C:/msys64/opt/llvm-mingw-windows/bin/ld.lld --rtlib=compiler-rt -D_UCRT",
- "CONF_CC_OPTS_STAGE2": "-fuse-ld=C:/msys64/opt/llvm-mingw-windows/bin/ld.lld --rtlib=compiler-rt -D_UCRT",
+ "CONF_CC_OPTS_STAGE0": "--target=x86_64-unknown-mingw32 -fuse-ld=C:/msys64/opt/ghc-bootstrap/mingw/bin/ld.lld --rtlib=compiler-rt -D_UCRT",
+ "CONF_CC_OPTS_STAGE1": "-fuse-ld=C:/msys64/opt/ghc-bootstrap/mingw/bin/ld.lld --rtlib=compiler-rt -D_UCRT",
+ "CONF_CC_OPTS_STAGE2": "-fuse-ld=C:/msys64/opt/ghc-bootstrap/mingw/bin/ld.lld --rtlib=compiler-rt -D_UCRT",
"CROSS_EMULATOR": "/opt/wine-arm64ec-msys2-deb12/bin/wine",
"CROSS_TARGET": "aarch64-unknown-mingw32",
- "CXX": "C:/msys64/opt/llvm-mingw-windows/bin/aarch64-w64-mingw32-clang++",
- "DLLTOOL": "C:/msys64/opt/llvm-mingw-windows/bin/dlltool.exe",
+ "CXX": "C:/msys64/opt/ghc-bootstrap/mingw/bin/aarch64-w64-mingw32-clang++",
+ "DLLTOOL": "C:/msys64/opt/ghc-bootstrap/mingw/bin/dlltool.exe",
"HADRIAN_ARGS": "--docs=none",
"INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
- "LD": "C:/msys64/opt/llvm-mingw-windows/bin/aarch64-w64-mingw32-ld",
- "LLVMAS": "C:/msys64/opt/llvm-mingw-windows/bin/aarch64-w64-mingw32-clang",
+ "LD": "C:/msys64/opt/ghc-bootstrap/mingw/bin/aarch64-w64-mingw32-ld",
+ "LLVMAS": "C:/msys64/opt/ghc-bootstrap/mingw/bin/aarch64-w64-mingw32-clang",
"MergeObjsCmd": "",
- "NM": "C:/msys64/opt/llvm-mingw-windows/bin/aarch64-w64-mingw32-nm.exe",
- "OBJCOPY": "C:/msys64/opt/llvm-mingw-windows/bin/aarch64-w64-mingw32-objcopy",
- "OBJDUMP": "C:/msys64/opt/llvm-mingw-windows/bin/aarch64-w64-mingw32-objdump",
- "RANLIB": "C:/msys64/opt/llvm-mingw-windows/bin/aarch64-w64-mingw32-llvm-ranlib.exe",
+ "NM": "C:/msys64/opt/ghc-bootstrap/mingw/bin/aarch64-w64-mingw32-nm.exe",
+ "OBJCOPY": "C:/msys64/opt/ghc-bootstrap/mingw/bin/aarch64-w64-mingw32-objcopy",
+ "OBJDUMP": "C:/msys64/opt/ghc-bootstrap/mingw/bin/aarch64-w64-mingw32-objdump",
+ "RANLIB": "C:/msys64/opt/ghc-bootstrap/mingw/bin/aarch64-w64-mingw32-llvm-ranlib.exe",
"RUNTEST_ARGS": "",
- "SIZE": "C:/msys64/opt/llvm-mingw-windows/bin/aarch64-w64-mingw32-size",
- "STRINGS": "C:/msys64/opt/llvm-mingw-windows/bin/aarch64-w64-mingw32-strings",
- "STRIP": "C:/msys64/opt/llvm-mingw-windows/bin/aarch64-w64-mingw32-strip",
+ "SIZE": "C:/msys64/opt/ghc-bootstrap/mingw/bin/aarch64-w64-mingw32-size",
+ "STRINGS": "C:/msys64/opt/ghc-bootstrap/mingw/bin/aarch64-w64-mingw32-strings",
+ "STRIP": "C:/msys64/opt/ghc-bootstrap/mingw/bin/aarch64-w64-mingw32-strip",
"TEST_ENV": "aarch64-linux-deb12-wine-int_native-cross_aarch64-unknown-mingw32-validate-_wine_full_build",
"TOOLCHAIN_SOURCE": "env",
- "WindresCmd": "C:/msys64/opt/llvm-mingw-windows/bin/aarch64-w64-mingw32-windres",
+ "WindresCmd": "C:/msys64/opt/ghc-bootstrap/mingw/bin/aarch64-w64-mingw32-windres",
"XZ_OPT": "-9"
}
},
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3ccf3c0143ab62d346703c3a088b165…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3ccf3c0143ab62d346703c3a088b165…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
09 May '25
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
51b0ce8f by Simon Peyton Jones at 2025-05-09T03:19:07-04:00
Slighty improve `dropMisleading`
Fix #26105, by upgrading the (horrible, hacky) `dropMisleading`
function.
This fix makes things a bit better but does not cure the underlying
problem.
- - - - -
4 changed files:
- compiler/GHC/Tc/Types/Constraint.hs
- compiler/GHC/Tc/Utils/Monad.hs
- + testsuite/tests/typecheck/should_fail/T26015.hs
- + testsuite/tests/typecheck/should_fail/T26015.stderr
Changes:
=====================================
compiler/GHC/Tc/Types/Constraint.hs
=====================================
@@ -1181,9 +1181,12 @@ dropMisleading (WC { wc_simple = simples, wc_impl = implics, wc_errors = errors
, wc_impl = mapBag drop_implic implics
, wc_errors = filterBag keep_delayed_error errors }
- keep_ct ct = case classifyPredType (ctPred ct) of
- ClassPred {} -> False
- _ -> True
+ keep_ct ct
+ = case classifyPredType (ctPred ct) of
+ ClassPred cls _ -> isEqualityClass cls
+ -- isEqualityClass: see (CERR2) in Note [Constraints and errors]
+ -- in GHC.Tc.Utils.Monad
+ _ -> True
keep_delayed_error (DE_Hole hole) = isOutOfScopeHole hole
keep_delayed_error (DE_NotConcrete {}) = True
=====================================
compiler/GHC/Tc/Utils/Monad.hs
=====================================
@@ -1385,11 +1385,13 @@ tryCaptureConstraints thing_inside
tcTryM thing_inside
-- See Note [Constraints and errors]
- ; let lie_to_keep = case mb_res of
- Nothing -> dropMisleading lie
- Just {} -> lie
-
- ; return (mb_res, lie_to_keep) }
+ ; case mb_res of
+ Just {} -> return (mb_res, lie)
+ Nothing -> do { let pruned_lie = dropMisleading lie
+ ; traceTc "tryCaptureConstraints" $
+ vcat [ text "lie:" <+> ppr lie
+ , text "dropMisleading lie:" <+> ppr pruned_lie ]
+ ; return (Nothing, pruned_lie) } }
captureConstraints :: TcM a -> TcM (a, WantedConstraints)
-- (captureConstraints m) runs m, and returns the type constraints it generates
@@ -2066,28 +2068,51 @@ It's distressingly delicate though:
emitted some constraints with skolem-escape problems.
* If we discard too /few/ constraints, we may get the misleading
- class constraints mentioned above. But we may /also/ end up taking
- constraints built at some inner level, and emitting them at some
- outer level, and then breaking the TcLevel invariants
- See Note [TcLevel invariants] in GHC.Tc.Utils.TcType
-
-So dropMisleading has a horridly ad-hoc structure. It keeps only
-/insoluble/ flat constraints (which are unlikely to very visibly trip
-up on the TcLevel invariant, but all /implication/ constraints (except
-the class constraints inside them). The implication constraints are
-OK because they set the ambient level before attempting to solve any
-inner constraints. Ugh! I hate this. But it seems to work.
-
-However note that freshly-generated constraints like (Int ~ Bool), or
-((a -> b) ~ Int) are all CNonCanonical, and hence won't be flagged as
-insoluble. The constraint solver does that. So they'll be discarded.
-That's probably ok; but see th/5358 as a not-so-good example:
- t1 :: Int
- t1 x = x -- Manifestly wrong
-
- foo = $(...raises exception...)
-We report the exception, but not the bug in t1. Oh well. Possible
-solution: make GHC.Tc.Utils.Unify.uType spot manifestly-insoluble constraints.
+ class constraints mentioned above.
+
+ We may /also/ end up taking constraints built at some inner level, and
+ emitting them (via the exception catching in `tryCaptureConstraints` at some
+ outer level, and then breaking the TcLevel invariants See Note [TcLevel
+ invariants] in GHC.Tc.Utils.TcType
+
+So `dropMisleading` has a horridly ad-hoc structure:
+
+* It keeps only /insoluble/ flat constraints (which are unlikely to very visibly
+ trip up on the TcLevel invariant
+
+* But it keeps all /implication/ constraints (except the class constraints
+ inside them). The implication constraints are OK because they set the ambient
+ level before attempting to solve any inner constraints.
+
+Ugh! I hate this. But it seems to work.
+
+Other wrinkles
+
+(CERR1) Note that freshly-generated constraints like (Int ~ Bool), or
+ ((a -> b) ~ Int) are all CNonCanonical, and hence won't be flagged as
+ insoluble. The constraint solver does that. So they'll be discarded.
+ That's probably ok; but see th/5358 as a not-so-good example:
+ t1 :: Int
+ t1 x = x -- Manifestly wrong
+
+ foo = $(...raises exception...)
+ We report the exception, but not the bug in t1. Oh well. Possible
+ solution: make GHC.Tc.Utils.Unify.uType spot manifestly-insoluble constraints.
+
+(CERR2) In #26015 I found that from the constraints
+ [W] alpha ~ Int -- A class constraint
+ [W] F alpha ~# Bool -- An equality constraint
+ we were dropping the first (becuase it's a class constraint) but not the
+ second, and then getting a misleading error message from the second. As
+ #25607 shows, we can get not just one but a zillion bogus messages, which
+ conceal the one genuine error. Boo.
+
+ For now I have added an even more ad-hoc "drop class constraints except
+ equality classes (~) and (~~)"; see `dropMisleading`. That just kicks the can
+ down the road; but this problem seems somewhat rare anyway. The code in
+ `dropMisleading` hasn't changed for years.
+
+It would be great to have a more systematic solution to this entire mess.
************************************************************************
=====================================
testsuite/tests/typecheck/should_fail/T26015.hs
=====================================
@@ -0,0 +1,17 @@
+{-# LANGUAGE MonoLocalBinds, GADTs, TypeFamilies #-}
+
+module Foo where
+
+type family F a
+type instance F Int = Bool
+
+data T where
+ T1 :: a -> T
+ T2 :: Int -> T
+
+woo :: (a ~ Int) => Int -> F a
+woo = error "urk"
+
+f x = case x of
+ T1 y -> not (woo 3)
+ T2 -> True
=====================================
testsuite/tests/typecheck/should_fail/T26015.stderr
=====================================
@@ -0,0 +1,9 @@
+T26015.hs:17:10: error: [GHC-27346]
+ • The data constructor ‘T2’ should have 1 argument, but has been given none
+ • In the pattern: T2
+ In a case alternative: T2 -> True
+ In the expression:
+ case x of
+ T1 y -> not (woo 3)
+ T2 -> True
+
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/51b0ce8fcaf2efedcac752e347883a7…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/51b0ce8fcaf2efedcac752e347883a7…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] Take subordinate 'type' specifiers into account
by Marge Bot (＠marge-bot) 09 May '25
by Marge Bot (＠marge-bot) 09 May '25
09 May '25
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
282df905 by Vladislav Zavialov at 2025-05-09T03:18:25-04:00
Take subordinate 'type' specifiers into account
This patch fixes multiple bugs (#22581, #25983, #25984, #25991)
in name resolution of subordinate import lists.
Bug #22581
----------
In subordinate import lists, the use of the `type` namespace specifier
used to be ignored. For example, this import statement was incorrectly
accepted:
import Prelude (Bool(type True))
Now it results in an error message:
<interactive>:2:17: error: [GHC-51433]
In the import of ‘Prelude’:
a data type called ‘Bool’ is exported,
but its subordinate item ‘True’ is not in the type namespace.
Bug #25983
----------
In subordinate import lists within a `hiding` clause, non-existent
items led to a poor warning message with -Wdodgy-imports. Consider:
import Prelude hiding (Bool(X))
The warning message for this import statement used to misreport the
cause of the problem:
<interactive>:3:24: warning: [GHC-56449] [-Wdodgy-imports]
In the import of ‘Prelude’:
an item called ‘Bool’ is exported, but it is a type.
Now the warning message is correct:
<interactive>:2:24: warning: [GHC-10237] [-Wdodgy-imports]
In the import of ‘Prelude’:
a data type called ‘Bool’ is exported, but it does not export
any constructors or record fields called ‘X’.
Bug #25984
----------
In subordinate import lists within a `hiding` clause, non-existent
items resulted in the entire import declaration being discarded.
For example, this program was incorrectly accepted:
import Prelude hiding (Bool(True,X))
t = True
Now it results in an error message:
<interactive>:2:5: error: [GHC-88464]
Data constructor not in scope: True
Bug #25991
----------
In subordinate import lists, it was not possible to refer to a class
method if there was an associated type of the same name:
module M_helper where
class C a b where
type a # b
(#) :: a -> b -> ()
module M where
import M_helper (C((#)))
This import declaration failed with:
M.hs:2:28: error: [GHC-10237]
In the import of ‘M_helper’:
an item called ‘C’ is exported, but it does not export any children
(constructors, class methods or field names) called ‘#’.
Now it is accepted.
Summary
-------
The changes required to fix these bugs are almost entirely confined to
GHC.Rename.Names. Other than that, there is a new error constructor
BadImportNonTypeSubordinates with error code [GHC-51433].
Test cases:
T22581a T22581b T22581c T22581d
T25983a T25983b T25983c T25983d T25983e T25983f T25983g
T25984a T25984b
T25991a T25991b1 T25991b2
- - - - -
50 changed files:
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Types/Error/Codes.hs
- docs/users_guide/9.14.1-notes.rst
- docs/users_guide/exts/explicit_namespaces.rst
- testsuite/tests/driver/RecompExports/RecompExports1.stderr
- testsuite/tests/driver/RecompExports/RecompExports4.stderr
- testsuite/tests/module/T21826.stderr
- testsuite/tests/module/mod81.stderr
- testsuite/tests/module/mod91.stderr
- + testsuite/tests/rename/should_compile/T22581c.hs
- + testsuite/tests/rename/should_compile/T22581c_helper.hs
- + testsuite/tests/rename/should_compile/T22581d.script
- + testsuite/tests/rename/should_compile/T22581d.stdout
- + testsuite/tests/rename/should_compile/T25983a.hs
- + testsuite/tests/rename/should_compile/T25983a.stderr
- + testsuite/tests/rename/should_compile/T25983b.hs
- + testsuite/tests/rename/should_compile/T25983b.stderr
- + testsuite/tests/rename/should_compile/T25983c.hs
- + testsuite/tests/rename/should_compile/T25983c.stderr
- + testsuite/tests/rename/should_compile/T25983d.hs
- + testsuite/tests/rename/should_compile/T25983d.stderr
- + testsuite/tests/rename/should_compile/T25983e.hs
- + testsuite/tests/rename/should_compile/T25983e.stderr
- + testsuite/tests/rename/should_compile/T25983f.hs
- + testsuite/tests/rename/should_compile/T25983f.stderr
- + testsuite/tests/rename/should_compile/T25983g.hs
- + testsuite/tests/rename/should_compile/T25983g.stderr
- + testsuite/tests/rename/should_compile/T25984a.hs
- + testsuite/tests/rename/should_compile/T25984a.stderr
- + testsuite/tests/rename/should_compile/T25984a_helper.hs
- + testsuite/tests/rename/should_compile/T25991a.hs
- + testsuite/tests/rename/should_compile/T25991a_helper.hs
- testsuite/tests/rename/should_compile/all.T
- + testsuite/tests/rename/should_fail/T22581a.hs
- + testsuite/tests/rename/should_fail/T22581a.stderr
- + testsuite/tests/rename/should_fail/T22581a_helper.hs
- + testsuite/tests/rename/should_fail/T22581b.hs
- + testsuite/tests/rename/should_fail/T22581b.stderr
- + testsuite/tests/rename/should_fail/T22581b_helper.hs
- + testsuite/tests/rename/should_fail/T25984b.hs
- + testsuite/tests/rename/should_fail/T25984b.stderr
- + testsuite/tests/rename/should_fail/T25991b1.hs
- + testsuite/tests/rename/should_fail/T25991b1.stderr
- + testsuite/tests/rename/should_fail/T25991b2.hs
- + testsuite/tests/rename/should_fail/T25991b2.stderr
- + testsuite/tests/rename/should_fail/T25991b_helper.hs
- testsuite/tests/rename/should_fail/T9006.stderr
- testsuite/tests/rename/should_fail/all.T
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/282df90570fa9c777c914ae543fea29…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/282df90570fa9c777c914ae543fea29…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 7 commits: llvmGen: Fix built-in variable predicate
by Marge Bot (＠marge-bot) 08 May '25
by Marge Bot (＠marge-bot) 08 May '25
08 May '25
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
6e67fa08 by Ben Gamari at 2025-05-08T06:21:21-04:00
llvmGen: Fix built-in variable predicate
Previously the predicate to identify LLVM builtin global variables was
checking for `$llvm` rather than `@llvm` as it should.
- - - - -
a9d0a22c by Ben Gamari at 2025-05-08T06:21:22-04:00
llvmGen: Fix linkage of built-in arrays
LLVM now insists that built-in arrays use Appending linkage, not
Internal.
Fixes #25769.
- - - - -
9c6d2b1b by sheaf at 2025-05-08T06:22:11-04:00
Use mkTrAppChecked in ds_ev_typeable
This change avoids violating the invariant of mkTrApp according to which
the argument should not be a fully saturated function type.
This ensures we don't return false negatives for type equality
involving function types.
Fixes #25998
- - - - -
75cadf81 by Ryan Hendrickson at 2025-05-08T06:22:55-04:00
haddock: Preserve indentation in multiline examples
Intended for use with :{ :}, but doesn't look for those characters. Any
consecutive lines with birdtracks will only have initial whitespace
stripped up to the column of the first line.
- - - - -
fee9b351 by Cheng Shao at 2025-05-08T06:23:36-04:00
ci: re-enable chrome for wasm ghci browser tests
Currently only firefox is enabled for wasm ghci browser tests, for
some reason testing with chrome works on my machine but gets stuck on
gitlab instance runners. This patch re-enables testing with chrome by
passing `--no-sandbox`, since chrome sandboxing doesn't work in
containers without `--cap-add=SYS_ADMIN`.
- - - - -
f87b3fef by Vladislav Zavialov at 2025-05-08T17:37:54-04:00
Take subordinate 'type' specifiers into account
This patch fixes multiple bugs (#22581, #25983, #25984, #25991)
in name resolution of subordinate import lists.
Bug #22581
----------
In subordinate import lists, the use of the `type` namespace specifier
used to be ignored. For example, this import statement was incorrectly
accepted:
import Prelude (Bool(type True))
Now it results in an error message:
<interactive>:2:17: error: [GHC-51433]
In the import of ‘Prelude’:
a data type called ‘Bool’ is exported,
but its subordinate item ‘True’ is not in the type namespace.
Bug #25983
----------
In subordinate import lists within a `hiding` clause, non-existent
items led to a poor warning message with -Wdodgy-imports. Consider:
import Prelude hiding (Bool(X))
The warning message for this import statement used to misreport the
cause of the problem:
<interactive>:3:24: warning: [GHC-56449] [-Wdodgy-imports]
In the import of ‘Prelude’:
an item called ‘Bool’ is exported, but it is a type.
Now the warning message is correct:
<interactive>:2:24: warning: [GHC-10237] [-Wdodgy-imports]
In the import of ‘Prelude’:
a data type called ‘Bool’ is exported, but it does not export
any constructors or record fields called ‘X’.
Bug #25984
----------
In subordinate import lists within a `hiding` clause, non-existent
items resulted in the entire import declaration being discarded.
For example, this program was incorrectly accepted:
import Prelude hiding (Bool(True,X))
t = True
Now it results in an error message:
<interactive>:2:5: error: [GHC-88464]
Data constructor not in scope: True
Bug #25991
----------
In subordinate import lists, it was not possible to refer to a class
method if there was an associated type of the same name:
module M_helper where
class C a b where
type a # b
(#) :: a -> b -> ()
module M where
import M_helper (C((#)))
This import declaration failed with:
M.hs:2:28: error: [GHC-10237]
In the import of ‘M_helper’:
an item called ‘C’ is exported, but it does not export any children
(constructors, class methods or field names) called ‘#’.
Now it is accepted.
Summary
-------
The changes required to fix these bugs are almost entirely confined to
GHC.Rename.Names. Other than that, there is a new error constructor
BadImportNonTypeSubordinates with error code [GHC-51433].
Test cases:
T22581a T22581b T22581c T22581d
T25983a T25983b T25983c T25983d T25983e T25983f T25983g
T25984a T25984b
T25991a T25991b1 T25991b2
- - - - -
d150a3b0 by Simon Peyton Jones at 2025-05-08T17:37:55-04:00
Slighty improve `dropMisleading`
Fix #26105, by upgrading the (horrible, hacky) `dropMisleading`
function.
This fix makes things a bit better but does not cure the underlying
problem.
- - - - -
65 changed files:
- .gitlab/generate-ci/gen_ci.hs
- .gitlab/jobs.yaml
- compiler/GHC/Builtin/Names.hs
- compiler/GHC/CmmToLlvm/Base.hs
- compiler/GHC/CmmToLlvm/Data.hs
- compiler/GHC/HsToCore/Binds.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Types/Constraint.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Types/Error/Codes.hs
- docs/users_guide/9.14.1-notes.rst
- docs/users_guide/exts/explicit_namespaces.rst
- testsuite/tests/driver/RecompExports/RecompExports1.stderr
- testsuite/tests/driver/RecompExports/RecompExports4.stderr
- testsuite/tests/module/T21826.stderr
- testsuite/tests/module/mod81.stderr
- testsuite/tests/module/mod91.stderr
- + testsuite/tests/rename/should_compile/T22581c.hs
- + testsuite/tests/rename/should_compile/T22581c_helper.hs
- + testsuite/tests/rename/should_compile/T22581d.script
- + testsuite/tests/rename/should_compile/T22581d.stdout
- + testsuite/tests/rename/should_compile/T25983a.hs
- + testsuite/tests/rename/should_compile/T25983a.stderr
- + testsuite/tests/rename/should_compile/T25983b.hs
- + testsuite/tests/rename/should_compile/T25983b.stderr
- + testsuite/tests/rename/should_compile/T25983c.hs
- + testsuite/tests/rename/should_compile/T25983c.stderr
- + testsuite/tests/rename/should_compile/T25983d.hs
- + testsuite/tests/rename/should_compile/T25983d.stderr
- + testsuite/tests/rename/should_compile/T25983e.hs
- + testsuite/tests/rename/should_compile/T25983e.stderr
- + testsuite/tests/rename/should_compile/T25983f.hs
- + testsuite/tests/rename/should_compile/T25983f.stderr
- + testsuite/tests/rename/should_compile/T25983g.hs
- + testsuite/tests/rename/should_compile/T25983g.stderr
- + testsuite/tests/rename/should_compile/T25984a.hs
- + testsuite/tests/rename/should_compile/T25984a.stderr
- + testsuite/tests/rename/should_compile/T25984a_helper.hs
- + testsuite/tests/rename/should_compile/T25991a.hs
- + testsuite/tests/rename/should_compile/T25991a_helper.hs
- testsuite/tests/rename/should_compile/all.T
- + testsuite/tests/rename/should_fail/T22581a.hs
- + testsuite/tests/rename/should_fail/T22581a.stderr
- + testsuite/tests/rename/should_fail/T22581a_helper.hs
- + testsuite/tests/rename/should_fail/T22581b.hs
- + testsuite/tests/rename/should_fail/T22581b.stderr
- + testsuite/tests/rename/should_fail/T22581b_helper.hs
- + testsuite/tests/rename/should_fail/T25984b.hs
- + testsuite/tests/rename/should_fail/T25984b.stderr
- + testsuite/tests/rename/should_fail/T25991b1.hs
- + testsuite/tests/rename/should_fail/T25991b1.stderr
- + testsuite/tests/rename/should_fail/T25991b2.hs
- + testsuite/tests/rename/should_fail/T25991b2.stderr
- + testsuite/tests/rename/should_fail/T25991b_helper.hs
- testsuite/tests/rename/should_fail/T9006.stderr
- testsuite/tests/rename/should_fail/all.T
- + testsuite/tests/typecheck/should_fail/T26015.hs
- + testsuite/tests/typecheck/should_fail/T26015.stderr
- + testsuite/tests/typecheck/should_run/T25998.hs
- + testsuite/tests/typecheck/should_run/T25998.stdout
- testsuite/tests/typecheck/should_run/all.T
- utils/haddock/haddock-library/src/Documentation/Haddock/Parser.hs
- utils/haddock/haddock-library/test/Documentation/Haddock/ParserSpec.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3b5267fd0ae28212b44dd9e81e2bad…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3b5267fd0ae28212b44dd9e81e2bad…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/fendor/ghci-multiple-home-units] 4 commits: Make GHCi commands compatible with multiple home units
by Hannes Siebenhandl (＠fendor) 08 May '25
by Hannes Siebenhandl (＠fendor) 08 May '25
08 May '25
Hannes Siebenhandl pushed to branch wip/fendor/ghci-multiple-home-units at Glasgow Haskell Compiler / GHC
Commits:
00e2c7f4 by fendor at 2025-05-08T19:27:58+02:00
Make GHCi commands compatible with multiple home units
FIXME: proper commit message
There is one metric increase in this commit:
-------------------------
Metric Increase:
T4029
-------------------------
It is an increase from 14.4 MB to 16.1 MB (+11.8%) which sounds like a
pretty big regression at first.
However, we argue this increase is solely caused by using more data
structures for managing multiple home units in the GHCi session.
In particular, due to the design decision of using three home units, the
base memory usage increases... but by how much?
A big contributor is the `UnitState`, of which we have three now, which
on its own 260 KB per instance. That makes an additional memory usage of
520 KB, already explaining a third of the overall memory usage increase.
FIXME: re-investigate what the remaining 1 MB is.
- - - - -
02358e50 by fendor at 2025-05-08T19:27:58+02:00
FIXME: these test cases can be fixed by exploiting internals
- - - - -
4d18769c by fendor at 2025-05-08T19:28:03+02:00
Fixup: Add documentation and refactor
- - - - -
387db537 by fendor at 2025-05-08T19:28:03+02:00
FIXUP: Multiple Home Units is no longer a special case
- - - - -
59 changed files:
- compiler/GHC.hs
- compiler/GHC/Driver/Downsweep.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Rename/Unbound.hs
- compiler/GHC/Runtime/Context.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/StgToByteCode.hs
- compiler/GHC/StgToJS/Linker/Linker.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Types/Name/Ppr.hs
- compiler/GHC/Unit/Env.hs
- compiler/GHC/Unit/Home/Graph.hs
- compiler/GHC/Unit/Types.hs
- ghc/GHCi/UI.hs
- ghc/GHCi/UI/Exception.hs
- ghc/GHCi/UI/Info.hs
- ghc/GHCi/UI/Monad.hs
- ghc/Main.hs
- testsuite/tests/backpack/cabal/bkpcabal08/bkpcabal08.stdout
- testsuite/tests/driver/T8526/T8526.stdout
- testsuite/tests/driver/fat-iface/fat014.stdout
- testsuite/tests/driver/multipleHomeUnits/multiGHCi.stderr
- testsuite/tests/ghc-api/T6145.hs
- testsuite/tests/ghc-api/annotations-literals/literals.hs
- testsuite/tests/ghc-api/annotations-literals/parsed.hs
- testsuite/tests/ghc-api/apirecomp001/myghc.hs
- testsuite/tests/ghc-api/fixed-nodes/T1.hs
- testsuite/tests/ghci.debugger/scripts/break031/all.T
- testsuite/tests/ghci/linking/dyn/T3372.hs
- testsuite/tests/ghci/prog-mhu001/all.T
- testsuite/tests/ghci/prog-mhu001/e/E.hs
- testsuite/tests/ghci/prog-mhu001/prog-mhu001c.stdout
- + testsuite/tests/ghci/prog-mhu001/prog-mhu001d.script
- + testsuite/tests/ghci/prog-mhu001/prog-mhu001d.stdout
- + testsuite/tests/ghci/prog-mhu001/prog-mhu001e.script
- + testsuite/tests/ghci/prog-mhu001/prog-mhu001e.stdout
- + testsuite/tests/ghci/prog-mhu001/prog-mhu001f.script
- + testsuite/tests/ghci/prog-mhu001/prog-mhu001f.stdout
- + testsuite/tests/ghci/prog-mhu001/unitE-main-is
- testsuite/tests/ghci/prog010/ghci.prog010.script
- testsuite/tests/ghci/prog018/prog018.stdout
- testsuite/tests/ghci/scripts/T13869.stdout
- testsuite/tests/ghci/scripts/T13997.stdout
- testsuite/tests/ghci/scripts/T17669.stdout
- testsuite/tests/ghci/scripts/T18330.stdout
- testsuite/tests/ghci/scripts/T1914.stdout
- testsuite/tests/ghci/scripts/T20217.stdout
- testsuite/tests/ghci/scripts/T20587.stdout
- testsuite/tests/ghci/scripts/T21110.stderr
- testsuite/tests/ghci/scripts/T6105.stdout
- testsuite/tests/ghci/scripts/T8042.stdout
- testsuite/tests/ghci/scripts/T8042recomp.stdout
- testsuite/tests/ghci/scripts/ghci024.stdout
- testsuite/tests/ghci/scripts/ghci024.stdout-mingw32
- testsuite/tests/ghci/scripts/ghci058.script
- testsuite/tests/ghci/should_run/TopEnvIface.stdout
- testsuite/tests/linters/notes.stdout
- testsuite/tests/quasiquotation/T7918.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bafe6aade1a3e33c7499cb0edd76dd…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bafe6aade1a3e33c7499cb0edd76dd…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/T23109a] Be keen on postInlineUnconditionally into bottoming expressions
by Simon Peyton Jones (＠simonpj) 08 May '25
by Simon Peyton Jones (＠simonpj) 08 May '25
08 May '25
Simon Peyton Jones pushed to branch wip/T23109a at Glasgow Haskell Compiler / GHC
Commits:
f0432100 by Simon Peyton Jones at 2025-05-08T17:23:19+01:00
Be keen on postInlineUnconditionally into bottoming expressions
Probably little or no effect
- - - - -
4 changed files:
- compiler/GHC/Core/Opt/OccurAnal.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Types/Basic.hs
Changes:
=====================================
compiler/GHC/Core/Opt/OccurAnal.hs
=====================================
@@ -33,7 +33,7 @@ import GHC.Prelude hiding ( head, init, last, tail )
import GHC.Core
import GHC.Core.FVs
-import GHC.Core.Utils ( exprIsTrivial, isDefaultAlt, isExpandableApp,
+import GHC.Core.Utils ( exprIsTrivial, isExpandableApp,
mkCastMCo, mkTicks )
import GHC.Core.Opt.Arity ( joinRhsArity, isOneShotBndr )
import GHC.Core.Coercion
@@ -2605,9 +2605,9 @@ occAnalArgs !env fun args !one_shots
-- Make bottoming functions interesting
-- See Note [Bottoming function calls]
--- encl | Var f <- fun, isDeadEndSig (idDmdSig f) = OccScrut
--- | otherwise = OccVanilla
- encl = OccVanilla
+ encl | Var f <- fun, isDeadEndId f = OccBot
+ | otherwise = OccVanilla
+-- encl = OccVanilla
go uds fun [] _ = WUD uds fun
go uds fun (arg:args) one_shots
@@ -2680,7 +2680,7 @@ occAnalApp !env (Var fun, args, ticks)
occAnalApp env (Var fun_id, args, ticks)
= WUD all_uds (mkTicks ticks app')
where
- -- Lots of banged bindings: this is a very heavily bit of code,
+ -- Lots of banged bindings: this is a very heavily-used bit of code,
-- so it pays not to make lots of thunks here, all of which
-- will ultimately be forced.
!(fun', fun_id') = lookupBndrSwap env fun_id
@@ -2709,7 +2709,7 @@ occAnalApp env (Var fun_id, args, ticks)
!n_val_args = valArgCount args
!n_args = length args
!int_cxt = case occ_encl env of
- OccScrut -> IsInteresting
+ OccBot -> IsInteresting
_other | n_val_args > 0 -> IsInteresting
| otherwise -> NotInteresting
@@ -2893,14 +2893,20 @@ OccEncl is used to control whether to inline into constructor arguments.
data OccEncl -- See Note [OccEncl]
= OccRhs -- RHS of let(rec), albeit perhaps inside a type lambda
- | OccScrut -- Scrutintee of a case
+ | OccBot -- We are in a bottoming expression
| OccVanilla -- Everything else
instance Outputable OccEncl where
ppr OccRhs = text "occRhs"
- ppr OccScrut = text "occScrut"
+ ppr OccBot = text "occBot"
ppr OccVanilla = text "occVanilla"
+setOccEncl :: OccEncl -> OccEncl -> OccEncl
+-- (outer_encl `setOccEncl` inner_encl)
+-- If we are in a bottoming context, don't forget it!
+setOccEncl OccBot _ = OccBot
+setOccEncl _ inner_encl = inner_encl
+
-- See Note [OneShots]
type OneShots = [OneShotInfo]
@@ -2922,16 +2928,17 @@ noBinderSwaps :: OccEnv -> Bool
noBinderSwaps (OccEnv { occ_bs_env = bs_env }) = isEmptyVarEnv bs_env
setScrutCtxt :: OccEnv -> [CoreAlt] -> OccEnv
-setScrutCtxt !env alts
+setScrutCtxt !env _alts
= setNonTailCtxt encl env
where
- encl | interesting_alts = OccScrut
- | otherwise = OccVanilla
+ encl = OccVanilla
+-- encl | interesting_alts = OccScrut
+-- | otherwise = OccVanilla
- interesting_alts = case alts of
- [] -> False
- [alt] -> not (isDefaultAlt alt)
- _ -> True
+-- interesting_alts = case alts of
+-- [] -> False
+-- [alt] -> not (isDefaultAlt alt)
+-- _ -> True
-- 'interesting_alts' is True if the case has at least one
-- non-default alternative. That in turn influences
-- pre/postInlineUnconditionally. Grep for "occ_int_cxt"!
@@ -2974,13 +2981,14 @@ For a join point binding, j x = rhs
-}
setNonTailCtxt :: OccEncl -> OccEnv -> OccEnv
-setNonTailCtxt ctxt !env
- = env { occ_encl = ctxt
+setNonTailCtxt inner_encl env@(OccEnv { occ_encl = outer_encl })
+ = env { occ_encl = outer_encl `setOccEncl` inner_encl
, occ_one_shots = []
, occ_join_points = zapJoinPointInfo (occ_join_points env) }
setTailCtxt :: OccEnv -> OccEnv
-setTailCtxt !env = env { occ_encl = OccVanilla }
+setTailCtxt env@(OccEnv { occ_encl = outer_encl })
+ = env { occ_encl = outer_encl `setOccEncl` OccVanilla }
-- Preserve occ_one_shots, occ_join points
-- Do not use OccRhs for the RHS of a join point (which is a tail ctxt):
@@ -3619,7 +3627,7 @@ data LocalOcc -- See Note [LocalOcc]
, lo_tail :: !TailCallInfo
-- Combining (AlwaysTailCalled 2) and (AlwaysTailCalled 3)
-- gives NoTailCallInfo
- , lo_int_cxt :: !InterestingCxt }
+ , lo_int_cxt :: !OccCtxt }
| ManyOccL !TailCallInfo
instance Outputable LocalOcc where
@@ -3676,7 +3684,7 @@ andUDs, orUDs
andUDs = combineUsageDetailsWith andLocalOcc
orUDs = combineUsageDetailsWith orLocalOcc
-mkOneOcc :: OccEnv -> Id -> InterestingCxt -> JoinArity -> UsageDetails
+mkOneOcc :: OccEnv -> Id -> OccCtxt -> JoinArity -> UsageDetails
mkOneOcc !env id int_cxt arity
| not (isLocalId id)
= emptyDetails
@@ -4087,7 +4095,7 @@ orLocalOcc :: LocalOcc -> LocalOcc -> LocalOcc
orLocalOcc (OneOccL { lo_n_br = nbr1, lo_int_cxt = int_cxt1, lo_tail = tci1 })
(OneOccL { lo_n_br = nbr2, lo_int_cxt = int_cxt2, lo_tail = tci2 })
= OneOccL { lo_n_br = nbr1 + nbr2
- , lo_int_cxt = int_cxt1 `mappend` int_cxt2
+ , lo_int_cxt = int_cxt1 `orOccCtxt` int_cxt2
, lo_tail = tci1 `andTailCallInfo` tci2 }
orLocalOcc occ1 occ2 = andLocalOcc occ1 occ2
=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -3940,6 +3940,8 @@ mkDupableContWithDmds env _
; (floats, join_rhs) <- rebuildCall env' (addValArgTo fun (Var arg_bndr) fun_ty) cont
; mkDupableStrictBind env' arg_bndr (wrapFloats floats join_rhs) rhs_ty }
where
+ thumbsUpPlanA _ = False
+ {-
thumbsUpPlanA (StrictArg {}) = False
thumbsUpPlanA (StrictBind {}) = True
thumbsUpPlanA (Stop {}) = True
@@ -3948,6 +3950,7 @@ mkDupableContWithDmds env _
thumbsUpPlanA (TickIt _ k) = thumbsUpPlanA k
thumbsUpPlanA (ApplyToVal { sc_cont = k }) = thumbsUpPlanA k
thumbsUpPlanA (ApplyToTy { sc_cont = k }) = thumbsUpPlanA k
+ -}
mkDupableContWithDmds env dmds
(ApplyToTy { sc_cont = cont, sc_arg_ty = arg_ty, sc_hole_ty = hole_ty })
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -1630,8 +1630,8 @@ postInlineUnconditionally env bind_cxt old_bndr bndr rhs
is_demanded = isStrUsedDmd (idDemandInfo bndr)
occ_info = idOccInfo old_bndr
unfolding = idUnfolding bndr
- arity = idArity bndr
--- is_cheap = isCheapUnfolding unfolding
+-- arity = idArity bndr
+ is_cheap = isCheapUnfolding unfolding
uf_opts = seUnfoldingOpts env
phase = sePhase env
active = isActive phase (idInlineActivation bndr)
@@ -1649,7 +1649,7 @@ postInlineUnconditionally env bind_cxt old_bndr bndr rhs
check_one_occ NotInsideLam NotInteresting n_br = not is_top_lvl && code_dup_ok n_br
check_one_occ NotInsideLam IsInteresting n_br = code_dup_ok n_br
check_one_occ IsInsideLam NotInteresting _ = False
- check_one_occ IsInsideLam IsInteresting n_br = arity > 0 && code_dup_ok n_br
+ check_one_occ IsInsideLam IsInteresting n_br = is_cheap && code_dup_ok n_br
-- IsInteresting: inlining inside a lambda only with good reason
-- See the notes on int_cxt in preInlineUnconditionally
-- arity>0: do not inline data strutures under lambdas, only functions
=====================================
compiler/GHC/Types/Basic.hs
=====================================
@@ -75,7 +75,7 @@ module GHC.Types.Basic (
InsideLam(..),
BranchCount, oneBranch,
- InterestingCxt(..),
+ OccCtxt(..), orOccCtxt,
TailCallInfo(..), tailCallInfo, zapOccTailCallInfo,
isAlwaysTailCalled,
@@ -1190,7 +1190,7 @@ data OccInfo -- See Note [OccInfo]
| OneOcc { occ_in_lam :: !InsideLam
, occ_n_br :: {-# UNPACK #-} !BranchCount
- , occ_int_cxt :: !InterestingCxt
+ , occ_int_cxt :: !OccCtxt
, occ_tail :: !TailCallInfo }
-- ^ Occurs exactly once (per branch), not inside a rule
@@ -1241,22 +1241,15 @@ seqOccInfo occ = occ `seq` ()
-----------------
-- | Interesting Context
-data InterestingCxt
- = IsInteresting
- -- ^ Function: is applied
- -- Data value: scrutinised by a case with at least one non-DEFAULT branch
- | NotInteresting
+data OccCtxt
+ = IsInteresting -- ^ All occurrences are in a bottoming context
+ -- or are applied to a value argument
+ | NotInteresting -- ^ Neither of the above
deriving (Eq)
--- | If there is any 'interesting' identifier occurrence, then the
--- aggregated occurrence info of that identifier is considered interesting.
-instance Semi.Semigroup InterestingCxt where
- NotInteresting <> x = x
- IsInteresting <> _ = IsInteresting
-
-instance Monoid InterestingCxt where
- mempty = NotInteresting
- mappend = (Semi.<>)
+orOccCtxt :: OccCtxt -> OccCtxt -> OccCtxt
+orOccCtxt IsInteresting IsInteresting = IsInteresting
+orOccCtxt _ _ = NotInteresting
-----------------
-- | Inside Lambda
@@ -1340,11 +1333,11 @@ instance Outputable OccInfo where
ppr (OneOcc inside_lam one_branch int_cxt tail_info)
= text "Once" <> pp_lam inside_lam <> ppr one_branch <> pp_args int_cxt <> pp_tail
where
- pp_lam IsInsideLam = char 'L'
- pp_lam NotInsideLam = empty
- pp_args IsInteresting = char '!'
- pp_args NotInteresting = empty
- pp_tail = pprShortTailCallInfo tail_info
+ pp_lam IsInsideLam = char 'L'
+ pp_lam NotInsideLam = empty
+ pp_args NotInteresting = empty
+ pp_args IsInteresting = char '!'
+ pp_tail = pprShortTailCallInfo tail_info
pprShortTailCallInfo :: TailCallInfo -> SDoc
pprShortTailCallInfo (AlwaysTailCalled ar) = char 'T' <> brackets (int ar)
@@ -2461,4 +2454,4 @@ convImportLevel NotLevelled = NormalLevel
convImportLevelSpec :: ImportDeclLevel -> ImportLevel
convImportLevelSpec ImportDeclQuote = QuoteLevel
-convImportLevelSpec ImportDeclSplice = SpliceLevel
\ No newline at end of file
+convImportLevelSpec ImportDeclSplice = SpliceLevel
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f04321002d120f66b062972642a3386…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f04321002d120f66b062972642a3386…
You're receiving this email because of your account on gitlab.haskell.org.
1
0