Simon Peyton Jones pushed to branch wip/T26115 at Glasgow Haskell Compiler / GHC
Commits:
86014575 by Simon Peyton Jones at 2025-06-13T00:06:18+01:00
More
- - - - -
1 changed file:
- compiler/GHC/Core/Opt/Specialise.hs
Changes:
=====================================
compiler/GHC/Core/Opt/Specialise.hs
=====================================
@@ -1628,13 +1628,11 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
do { let all_call_args | is_dfun = saturating_call_args -- See Note [Specialising DFuns]
| otherwise = call_args
saturating_call_args = call_args ++ map mk_extra_dfun_arg (dropList call_args rhs_bndrs)
- mk_extra_dfun_arg bndr | isTyVar bndr = UnspecType
- | otherwise = UnspecArg
+ mk_extra_dfun_arg bndr | isTyVar bndr = UnspecType (tyVarKind bndr) -- ToDo: right?
+ | otherwise = UnspecArg (idType bndr)
; (useful, rule_bndrs, rule_lhs_args, spec_bndrs1, spec_args) <- specHeader env all_call_args
-
-
-- ; pprTrace "spec_call" (vcat
-- [ text "fun: " <+> ppr fn
-- , text "call info: " <+> ppr _ci
@@ -1642,7 +1640,6 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
-- , text "rule_bndrs:" <+> ppr rule_bndrs
-- , text "lhs_args: " <+> ppr rule_lhs_args
-- , text "spec_bndrs1:" <+> ppr spec_bndrs1
--- , text "leftover_bndrs:" <+> pprIds leftover_bndrs
-- , text "spec_args: " <+> ppr spec_args
-- , text "dx_binds: " <+> ppr dx_binds
-- , text "rhs_bndrs" <+> ppr rhs_bndrs
@@ -1664,12 +1661,9 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
; (rhs_body', rhs_uds) <- specRhs env rhs_bndrs rhs_body spec_args
-- Add the { d1' = dx1; d2' = dx2 } usage stuff
-- to the rhs_uds; see Note [Specialising Calls]
- ; let rhs_uds_w_dx = dx_binds `consDictBinds` rhs_uds
- spec_rhs_bndrs = spec_bndrs1 ++ leftover_bndrs
- (spec_uds, dumped_dbs) = dumpUDs spec_rhs_bndrs rhs_uds_w_dx
- spec_rhs1 = mkLams spec_rhs_bndrs $
+ ; let (spec_uds, dumped_dbs) = dumpUDs spec_bndrs1 rhs_uds
+ spec_rhs1 = mkLams spec_bndrs1 $
wrapDictBindsE dumped_dbs rhs_body'
-
spec_fn_ty1 = exprType spec_rhs1
-- Maybe add a void arg to the specialised function,
@@ -1690,7 +1684,7 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
-- The wrap_unf_body applies the original unfolding to the specialised
-- arguments, not forgetting to wrap the dx_binds around the outside (#22358)
simpl_opts = initSimpleOpts dflags
- wrap_unf_body body = foldr (Let . db_bind) (body `mkApps` spec_args) dx_binds
+ wrap_unf_body body = body `mkApps` spec_args
spec_unf = specUnfolding simpl_opts spec_bndrs wrap_unf_body
rule_lhs_args fn_unf
@@ -1769,6 +1763,33 @@ alreadyCovered env bndrs fn args is_active rules
where
in_scope = substInScopeSet (se_subst env)
+specRhs :: SpecEnv -> [Var] -> CoreExpr -> [CoreExpr]
+ -> SpecM (CoreExpr, UsageDetails)
+
+specRhs env bndrs body []
+ = specLam env bndrs body
+
+specRhs env [] body args
+ = -- The caller should have ensured that there are no more
+ -- args than we have binders on the RHS
+ pprPanic "specRhs:too many args" (ppr args $$ ppr body)
+
+specRhs env@(SE { se_subst = subst }) (bndr:bndrs) body (arg:args)
+ | exprIsTrivial arg
+ , let env' = env { se_subst = Core.extendSubst subst bndr arg }
+ = specRhs env' bndrs body args
+
+
+ | otherwise -- Non-trivial argument; it must be a dictionary
+ = do { fresh_dict_id <- newIdBndr "dx" (idType bndr)
+ ; let fresh_dict_id' = fresh_dict_id `addDictUnfolding` arg
+ dict_bind = mkDB (NonRec fresh_dict_id' arg)
+ env2 = env1 { se_subst = Core.extendSubst subst bndr (Var fresh_dict_id')
+ `Core.extendSubstInScope` fresh_dict_id' }
+ -- Ensure the new unfolding is in the in-scope set
+ ; (body', uds) <- specRhs env2 bndrs body args
+ ; return (body', dict_bind `consDictBind` uds) }
+
-- Convenience function for invoking lookupRule from Specialise
-- The SpecEnv's InScopeSet should include all the Vars in the [CoreExpr]
specLookupRule :: SpecEnv -> Id -> [CoreExpr]
@@ -2426,7 +2447,7 @@ data SpecArg
SpecType Type
-- | Type arguments that should remain polymorphic.
- | UnspecType
+ | UnspecType Kind
-- | Dictionaries that should be specialised. mkCallUDs ensures
-- that only "interesting" dictionary arguments get a SpecDict;
@@ -2434,25 +2455,25 @@ data SpecArg
| SpecDict DictExpr
-- | Value arguments that should not be specialised.
- | UnspecArg
+ | UnspecArg Type
instance Outputable SpecArg where
- ppr (SpecType t) = text "SpecType" <+> ppr t
- ppr UnspecType = text "UnspecType"
- ppr (SpecDict d) = text "SpecDict" <+> ppr d
- ppr UnspecArg = text "UnspecArg"
+ ppr (SpecType t) = text "SpecType" <+> ppr t
+ ppr (UnspecType k) = text "UnspecType"
+ ppr (SpecDict d) = text "SpecDict" <+> ppr d
+ ppr (UnspecArg t) = text "UnspecArg"
specArgFreeIds :: SpecArg -> IdSet
-specArgFreeIds (SpecType {}) = emptyVarSet
-specArgFreeIds (SpecDict dx) = exprFreeIds dx
-specArgFreeIds UnspecType = emptyVarSet
-specArgFreeIds UnspecArg = emptyVarSet
+specArgFreeIds (SpecType {}) = emptyVarSet
+specArgFreeIds (SpecDict dx) = exprFreeIds dx
+specArgFreeIds (UnspecType {}) = emptyVarSet
+specArgFreeIds (UnspecArg {}) = emptyVarSet
specArgFreeVars :: SpecArg -> VarSet
-specArgFreeVars (SpecType ty) = tyCoVarsOfType ty
-specArgFreeVars (SpecDict dx) = exprFreeVars dx
-specArgFreeVars UnspecType = emptyVarSet
-specArgFreeVars UnspecArg = emptyVarSet
+specArgFreeVars (SpecType ty) = tyCoVarsOfType ty
+specArgFreeVars (UnspecType ki) = tyCoVarsOfType ki
+specArgFreeVars (SpecDict dx) = exprFreeVars dx
+specArgFreeVars (UnspecArg ty) = tyCoVarsOfType ty
isSpecDict :: SpecArg -> Bool
isSpecDict (SpecDict {}) = True
@@ -2521,7 +2542,7 @@ specHeader
-- We want to specialise on type 'T1', and so we must construct a substitution
-- 'a->T1', as well as a LHS argument for the resulting RULE and unfolding
-- details.
-specHeader env (bndr : bndrs) (SpecType ty : args)
+specHeader env (SpecType ty : args)
= do { -- Find qvars, the type variables to add to the binders for the rule
-- Namely those free in `ty` that aren't in scope
-- See (MP2) in Note [Specialising polymorphic dictionaries]
@@ -2529,7 +2550,7 @@ specHeader env (bndr : bndrs) (SpecType ty : args)
qvars = scopedSort $
filterOut (`elemInScopeSet` in_scope) $
tyCoVarsOfTypeList ty
- ; (useful, rule_bs, rule_args, spec_bs, spec_args) <- specHeader env2 args
+ ; (useful, rule_bs, rule_args, spec_bs, spec_args) <- specHeader env args
; pure ( useful
, qvars ++ rule_bs
, Type ty : rule_args
@@ -2542,17 +2563,13 @@ specHeader env (bndr : bndrs) (SpecType ty : args)
-- a substitution on it (in case the type refers to 'a'). Additionally, we need
-- to produce a binder, LHS argument and RHS argument for the resulting rule,
-- /and/ a binder for the specialised body.
-specHeader env (bndr : bndrs) (UnspecType : args)
- = do { let (env', bndr') = substBndr env bndr
- ; (useful, env'', leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args)
- <- specHeader env' bndrs args
+specHeader env (UnspecType kind : args)
+ = do { (useful, rule_bs, rule_es, spec_bs, spec_args) <- specHeader env' bndrs args
+ ; tv <- newTyVarBndr kind
; pure ( useful
- , env''
- , leftover_bndrs
, bndr' : rule_bs
, varToCoreExpr bndr' : rule_es
- , bndr' : bs'
- , dx
+ , bndr' : spec_bs
, varToCoreExpr bndr' : spec_args
)
}
@@ -2560,27 +2577,21 @@ specHeader env (bndr : bndrs) (UnspecType : args)
-- Next we want to specialise the 'Eq a' dict away. We need to construct
-- a wildcard binder to match the dictionary (See Note [Specialising Calls] for
-- the nitty-gritty), as a LHS rule and unfolding details.
-specHeader env (bndr : bndrs) (SpecDict d : args)
+specHeader env (SpecDict dict_arg : args)
| not (isDeadBinder bndr)
, allVarSet (`elemInScopeSet` in_scope) (exprFreeVars d)
-- See Note [Weird special case for SpecDict]
- = do { (env1, bndr') <- newDictBndr env bndr -- See Note [Zap occ info in rule binders]
- ; let (env2, dx_bind, spec_dict) = bindAuxiliaryDict env1 bndr bndr' d
- ; (_, env3, leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args)
- <- specHeader env2 bndrs args
+ = do { (_, rule_bs, rule_es, spec_bs, spec_args) <- specHeader env bndrs args
+ ; new_dict_id <- newIdBndr "dx" (exprType dict_arg)
+ ; let new_dict_expr = varToCoreExpr new_dict_id
+ -- See Note [Evidence foralls]
; pure ( True -- Ha! A useful specialisation!
- , env3
- , leftover_bndrs
- -- See Note [Evidence foralls]
- , exprFreeIdsList (varToCoreExpr bndr') ++ rule_bs
- , varToCoreExpr bndr' : rule_es
- , bs'
- , maybeToList dx_bind ++ dx
- , spec_dict : spec_args
+ , exprFreeIdsList new_dict_expr ++ rule_bs
+ , new_dict_expr : rule_es
+ , spec_bs
+ , dict_arg : spec_args
)
}
- where
- in_scope = Core.substInScopeSet (se_subst env)
-- Finally, we don't want to specialise on this argument 'i':
-- - It's an UnSpecArg, or
@@ -2592,13 +2603,14 @@ specHeader env (bndr : bndrs) (SpecDict d : args)
-- why 'i' doesn't appear in our RULE above. But we have no guarantee that
-- there aren't 'UnspecArg's which come /before/ all of the dictionaries, so
-- this case must be here.
-specHeader env (bndr : bndrs) (_ : args)
+specHeader env (arg : args)
-- The "_" can be UnSpecArg, or SpecDict where the bndr is dead
= do { -- see Note [Zap occ info in rule binders]
- let (env', bndr') = substBndr env (zapIdOccInfo bndr)
- ; (useful, env'', leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args)
- <- specHeader env' bndrs args
+ ; (useful, rule_bs, rule_es, spec_bs, spec_args) <- specHeader env bndrs args
+ ; spec_bndr <- case arg of
+ SpecDict d -> newIdBndr "dx" (exprType d)
+ UnspecArg t -> newIdBndr "x" t
; let bndr_ty = idType bndr'
-- See Note [Drop dead args from specialisations]
@@ -2611,14 +2623,11 @@ specHeader env (bndr : bndrs) (_ : args)
= (Just bndr', varToCoreExpr bndr')
; pure ( useful
- , env''
- , leftover_bndrs
, bndr' : rule_bs
, varToCoreExpr bndr' : rule_es
, case mb_spec_bndr of
- Just b' -> b' : bs'
- Nothing -> bs'
- , dx
+ Just b -> b : spec_bs
+ Nothing -> spec_bs
, spec_arg : spec_args
)
}
@@ -2636,6 +2645,7 @@ specHeader env bndrs []
(env', bndrs') = substBndrs env bndrs
+{-
-- | Binds a dictionary argument to a fresh name, to preserve sharing
bindAuxiliaryDict
:: SpecEnv
@@ -2662,7 +2672,7 @@ bindAuxiliaryDict env@(SE { se_subst = subst })
-- Ensure the new unfolding is in the in-scope set
in -- pprTrace "bindAuxiliaryDict:non-trivial" (ppr orig_dict_id <+> ppr fresh_dict_id') $
(env', Just dict_bind, Var fresh_dict_id')
-
+-}
addDictUnfolding :: Id -> CoreExpr -> Id
-- Add unfolding for freshly-bound Ids: see Note [Make the new dictionaries interesting]
-- and Note [Specialisation modulo dictionary selectors]
@@ -2977,16 +2987,13 @@ singleCall spec_env id args
unitBag (CI { ci_key = args
, ci_fvs = call_fvs }) }
where
- call_fvs =
- foldr (unionVarSet . free_var_fn) emptyVarSet args
+ call_fvs = foldr (unionVarSet . free_var_fn) emptyVarSet args
free_var_fn =
if gopt Opt_PolymorphicSpecialisation (se_dflags spec_env)
then specArgFreeIds
else specArgFreeVars
-
-
-- specArgFreeIds: we specifically look for free Ids, not TyVars
-- see (MP1) in Note [Specialising polymorphic dictionaries]
--
@@ -3022,12 +3029,13 @@ mkCallUDs' env f args
-- Establish (CI-KEY): drop trailing args until we get to a SpecDict
mk_spec_arg :: OutExpr -> PiTyBinder -> SpecArg
- mk_spec_arg arg (Named bndr)
+ mk_spec_arg (Type ty) (Named bndr)
| binderVar bndr `elemVarSet` constrained_tyvars
- = case arg of
- Type ty -> SpecType ty
- _ -> pprPanic "ci_key" $ ppr arg
- | otherwise = UnspecType
+ = SpecType ty
+ | otherwise
+ = UnspecType (typeKind ty)
+ mk_spec_arg non_type_arg (Named bndr)
+ = = pprPanic "ci_key" $ (ppr non_type_arg $$ ppr bndr)
-- For "invisibleFunArg", which are the type-class dictionaries,
-- we decide on a case by case basis if we want to specialise
@@ -3038,7 +3046,7 @@ mkCallUDs' env f args
-- See Note [Interesting dictionary arguments]
= SpecDict arg
- | otherwise = UnspecArg
+ | otherwise = UnspecArg (exprType arg)
{-
Note [Ticks on applications]
@@ -3277,10 +3285,10 @@ snocDictBinds uds@MkUD{ud_binds=FDB{ fdb_binds = binds, fdb_bndrs = bs }} dbs
= uds { ud_binds = FDB { fdb_binds = binds `appOL` (toOL dbs)
, fdb_bndrs = bs `extendVarSetList` bindersOfDictBinds dbs } }
-consDictBinds :: [DictBind] -> UsageDetails -> UsageDetails
-consDictBinds dbs uds@MkUD{ud_binds=FDB{fdb_binds = binds, fdb_bndrs = bs}}
- = uds { ud_binds = FDB{ fdb_binds = toOL dbs `appOL` binds
- , fdb_bndrs = bs `extendVarSetList` bindersOfDictBinds dbs } }
+consDictBind :: DictBind -> UsageDetails -> UsageDetails
+consDictBind db uds@MkUD{ud_binds=FDB{fdb_binds = binds, fdb_bndrs = bs}}
+ = uds { ud_binds = FDB{ fdb_binds = db `consOL` binds
+ , fdb_bndrs = bs `extendVarSetList` bindersOfDictBind db } }
wrapDictBinds :: FloatedDictBinds -> [CoreBind] -> [CoreBind]
wrapDictBinds (FDB { fdb_binds = dbs }) binds
@@ -3394,10 +3402,10 @@ beats_or_same (CI { ci_key = args1 }) (CI { ci_key = args2 })
go _ _ = False
go_arg (SpecType ty1) (SpecType ty2) = isJust (tcMatchTy ty1 ty2)
- go_arg UnspecType UnspecType = True
- go_arg (SpecDict {}) (SpecDict {}) = True
- go_arg UnspecArg UnspecArg = True
- go_arg _ _ = False
+ go_arg (UnspecType {}) (UnspecType {}) = True
+ go_arg (SpecDict {}) (SpecDict {}) = True
+ go_arg (UnspecArg {}) (UnspecArg {}) = True
+ go_arg _ _ = False
----------------------
splitDictBinds :: FloatedDictBinds -> IdSet -> (FloatedDictBinds, OrdList DictBind, IdSet)
@@ -3504,17 +3512,6 @@ cloneRecBndrsSM env@(SE { se_subst = subst }) bndrs
; let env' = env { se_subst = subst' }
; return (env', bndrs') }
-newDictBndr :: SpecEnv -> CoreBndr -> SpecM (SpecEnv, CoreBndr)
--- Make up completely fresh binders for the dictionaries
--- Their bindings are going to float outwards
-newDictBndr env@(SE { se_subst = subst }) b
- = do { uniq <- getUniqueM
- ; let n = idName b
- ty' = substTyUnchecked subst (idType b)
- b' = mkUserLocal (nameOccName n) uniq ManyTy ty' (getSrcSpan n)
- env' = env { se_subst = subst `Core.extendSubstInScope` b' }
- ; pure (env', b') }
-
newSpecIdSM :: Name -> Type -> IdDetails -> IdInfo -> SpecM Id
-- Give the new Id a similar occurrence name to the old one
newSpecIdSM old_name new_ty details info
@@ -3524,6 +3521,19 @@ newSpecIdSM old_name new_ty details info
; return (assert (not (isCoVarType new_ty)) $
mkLocalVar details new_name ManyTy new_ty info) }
+newIdBndr :: String -> Type -> SpecM (SpecEnv, CoreBndr)
+-- Make up completely fresh binders for the dictionaries
+-- Their bindings are going to float outwards
+newIdBndr env@(SE { se_subst = subst }) str ty
+ = do { uniq <- getUniqueM
+ ; return (mkUserLocal (mkVarOcc str) uniq ManyTy ty noSrcSpan) }
+
+newTyVarBndr :: Kind -> SpecM TyVar
+newTyVarBndr kind
+ = do { uniq <- getUniqueM
+ ; let name = mkInternalName uniq (mkTyVarOcc "a") noSrcSpan
+ ; return (mkTyVar name kind }
+
{-
Old (but interesting) stuff about unboxed bindings
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -3535,7 +3545,7 @@ What should we do when a value is specialised to a *strict* unboxed value?
in h:t
Could convert let to case:
-
+
map_*_Int# f (x:xs) = case f x of h# ->
let t = map f xs
in h#:t
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/860145751c943d8045670465fc2796f…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/860145751c943d8045670465fc2796f…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/boot-lib-testing] 2 commits: check-submodules: initial commit
by Ben Gamari (＠bgamari) 12 Jun '25
by Ben Gamari (＠bgamari) 12 Jun '25
12 Jun '25
Ben Gamari pushed to branch wip/boot-lib-testing at Glasgow Haskell Compiler / GHC
Commits:
ed246211 by Ben Gamari at 2025-06-12T18:44:05-04:00
check-submodules: initial commit
- - - - -
5ff1aeba by Ben Gamari at 2025-06-12T18:44:05-04:00
gitlab-ci: Add boot library linting steps
- - - - -
15 changed files:
- .gitlab-ci.yml
- + utils/check-submodules/LICENSE
- + utils/check-submodules/README.mkd
- + utils/check-submodules/app/Main.hs
- + utils/check-submodules/check-submodules.cabal
- + utils/check-submodules/flake.lock
- + utils/check-submodules/flake.nix
- + utils/check-submodules/hie.yaml
- + utils/check-submodules/src/CheckTags.hs
- + utils/check-submodules/src/CheckVersions.hs
- + utils/check-submodules/src/Git.hs
- + utils/check-submodules/src/Hackage.hs
- + utils/check-submodules/src/Package.hs
- + utils/check-submodules/src/Packages.hs
- + utils/check-submodules/src/Pretty.hs
Changes:
=====================================
.gitlab-ci.yml
=====================================
@@ -205,6 +205,25 @@ not-interruptible:
- if: $NIGHTLY
when: always
+.nix:
+ image: nixos/nix:2.25.2
+ variables:
+ LANG: "C.UTF-8"
+ before_script:
+ - echo "experimental-features = nix-command flakes" >> /etc/nix/nix.conf
+ # Note [Nix-in-Docker]
+ # ~~~~~~~~~~~~~~~~~~~~
+ # The nixos/nix default config is max-jobs=1 and cores=$(logical
+ # cores num) which doesn't play nice with our $CPUS convention. We
+ # fix it before invoking any nix build to avoid oversubscribing
+ # while allowing a reasonable degree of parallelism.
+ # FIXME: Disabling build-users-group=nixbld is a workaround for a Nix-in-Docker issue. See
+ # https://gitlab.haskell.org/ghc/head.hackage/-/issues/38#note_560487 for
+ # discussion.
+ - echo "cores = $CPUS" >> /etc/nix/nix.conf
+ - echo "max-jobs = $CPUS" >> /etc/nix/nix.conf
+ - nix run nixpkgs#gnused -- -i -e 's/ nixbld//' /etc/nix/nix.conf
+
############################################################
# Validate jobs
@@ -255,6 +274,24 @@ typecheck-testsuite:
- mypy testsuite/driver/runtests.py
dependencies: []
+lint-boot-tags:
+ extends: [.lint, .nix]
+ script:
+ - nix run ./utils/check-submodules# -- check-tags
+ rules:
+ - if: $RELEASE_JOB
+ allow_failure: false
+ - allow_failure: true
+
+lint-boot-versions:
+ extends: [.lint, .nix]
+ script:
+ - nix run ./utils/check-submodules# -- check-versions
+ rules:
+ - if: $RELEASE_JOB
+ allow_failure: false
+ - allow_failure: true
+
# We allow the submodule checker to fail when run on merge requests (to
# accommodate, e.g., haddock changes not yet upstream) but not on `master` or
# Marge jobs.
@@ -292,26 +329,11 @@ lint-author:
- *drafts-can-fail-lint
lint-ci-config:
- image: nixos/nix:2.25.2
- extends: .lint
+ extends: [.lint, .nix]
# We don't need history/submodules in this job
variables:
GIT_DEPTH: 1
GIT_SUBMODULE_STRATEGY: none
- before_script:
- - echo "experimental-features = nix-command flakes" >> /etc/nix/nix.conf
- # Note [Nix-in-Docker]
- # ~~~~~~~~~~~~~~~~~~~~
- # The nixos/nix default config is max-jobs=1 and cores=$(logical
- # cores num) which doesn't play nice with our $CPUS convention. We
- # fix it before invoking any nix build to avoid oversubscribing
- # while allowing a reasonable degree of parallelism.
- # FIXME: Disabling build-users-group=nixbld is a workaround for a Nix-in-Docker issue. See
- # https://gitlab.haskell.org/ghc/head.hackage/-/issues/38#note_560487 for
- # discussion.
- - echo "cores = $CPUS" >> /etc/nix/nix.conf
- - echo "max-jobs = $CPUS" >> /etc/nix/nix.conf
- - nix run nixpkgs#gnused -- -i -e 's/ nixbld//' /etc/nix/nix.conf
script:
- nix run .gitlab/generate-ci#generate-jobs
# 1 if .gitlab/generate_jobs changed the output of the generated config
=====================================
utils/check-submodules/LICENSE
=====================================
@@ -0,0 +1,30 @@
+Copyright (c) 2024, Ben Gamari
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Ben Gamari nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
=====================================
utils/check-submodules/README.mkd
=====================================
@@ -0,0 +1,47 @@
+# check-submodules
+
+`check-submodules` is a utility automating several common tasks encountered
+when check and maintaining GHC's boot library dependencies. It has several
+modes.
+
+
+## `check-versions`
+
+The `check-versions` mode verifies that GHC is up-to-date with each
+library's Hackage releases. Specifically, it checks that:
+
+ * the referenced commits are released on Hackage
+ * that the Hackage version has not been deprecated
+ * that there is not a more recent version in the same major series
+
+
+## `check-tags`
+
+The `check-tags` mode is used to verify that GHC does not differ from the
+upstream releases in non-trivial ways.
+
+Specifically, it compares each submodule's `HEAD` commit against the most
+recent predecessor release tag. If there are non-trivial differences (that is,
+changes outside of dot-files), then the check fails and emits a summary of the
+differing files.
+
+
+## `summarize`
+
+The `summarize` mode produces a convenient summary of the current submodule
+state.
+
+
+## `email`
+
+The `email` mode produces a correctly-formatted email recipient list containing
+the maintainers of all boot libraries.
+
+
+## Usage
+
+The tool can be readily run via the included nix flake from the root of the GHC
+tree:
+```bash
+nix run ./utils/check-submodules# -- check-versions
+```
=====================================
utils/check-submodules/app/Main.hs
=====================================
@@ -0,0 +1,15 @@
+module Main (main) where
+
+import CheckVersions
+import CheckTags
+import System.Environment (getArgs)
+
+main :: IO ()
+main = do
+ args <- getArgs
+ case args of
+ ["check-versions"] -> checkVersions
+ ["check-tags"] -> checkTags
+ ["summarize"] -> summarize
+ ["email"] -> maintainerEmails >>= putStrLn
+ _ -> fail "invalid mode (valid modes: check-versions, check-tags, summarize, email)"
=====================================
utils/check-submodules/check-submodules.cabal
=====================================
@@ -0,0 +1,50 @@
+cabal-version: 3.0
+name: check-submodules
+version: 0.1.0.0
+-- synopsis:
+-- description:
+homepage: https://gitlab.haskell.org/ghc/ghc
+license: BSD-3-Clause
+license-file: LICENSE
+author: Ben Gamari
+maintainer: ben(a)smart-cactus.org
+copyright: (c) 2024 Ben Gamari
+category: Development
+build-type: Simple
+-- extra-source-files:
+
+common warnings
+ ghc-options: -Wall
+
+executable check-submodules
+ import: warnings
+ main-is: Main.hs
+ build-depends: base,
+ check-submodules
+ hs-source-dirs: app
+ default-language: Haskell2010
+
+library
+ import: warnings
+ exposed-modules: Git,
+ Hackage,
+ CheckVersions,
+ CheckTags,
+ Packages,
+ Package,
+ Pretty
+ build-depends: base,
+ wreq,
+ aeson,
+ bytestring,
+ text,
+ transformers,
+ prettyprinter,
+ prettyprinter-ansi-terminal,
+ filepath,
+ microlens,
+ containers,
+ typed-process,
+ Cabal
+ hs-source-dirs: src
+ default-language: Haskell2010
=====================================
utils/check-submodules/flake.lock
=====================================
@@ -0,0 +1,58 @@
+{
+ "nodes": {
+ "flake-utils": {
+ "inputs": {
+ "systems": "systems"
+ },
+ "locked": {
+ "lastModified": 1731533236,
+ "narHash": "sha256-l0KFg5HjrsfsO/JpG+r7fRrqm12kzFHyUHqHCVpMMbI=",
+ "owner": "numtide",
+ "repo": "flake-utils",
+ "rev": "11707dc2f618dd54ca8739b309ec4fc024de578b",
+ "type": "github"
+ },
+ "original": {
+ "owner": "numtide",
+ "repo": "flake-utils",
+ "type": "github"
+ }
+ },
+ "nixpkgs": {
+ "locked": {
+ "lastModified": 1734083684,
+ "narHash": "sha256-5fNndbndxSx5d+C/D0p/VF32xDiJCJzyOqorOYW4JEo=",
+ "path": "/nix/store/0xbni69flk8380w0apw4h640n37wn1i9-source",
+ "rev": "314e12ba369ccdb9b352a4db26ff419f7c49fa84",
+ "type": "path"
+ },
+ "original": {
+ "id": "nixpkgs",
+ "type": "indirect"
+ }
+ },
+ "root": {
+ "inputs": {
+ "flake-utils": "flake-utils",
+ "nixpkgs": "nixpkgs"
+ }
+ },
+ "systems": {
+ "locked": {
+ "lastModified": 1681028828,
+ "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=",
+ "owner": "nix-systems",
+ "repo": "default",
+ "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e",
+ "type": "github"
+ },
+ "original": {
+ "owner": "nix-systems",
+ "repo": "default",
+ "type": "github"
+ }
+ }
+ },
+ "root": "root",
+ "version": 7
+}
=====================================
utils/check-submodules/flake.nix
=====================================
@@ -0,0 +1,26 @@
+{
+ description = "GHC boot library linting";
+
+ inputs.flake-utils.url = "github:numtide/flake-utils";
+
+ outputs = { self, nixpkgs, flake-utils }:
+ flake-utils.lib.eachDefaultSystem (system:
+ let pkgs = nixpkgs.legacyPackages.${system}; in
+ {
+ packages = rec {
+ check-submodules = pkgs.haskellPackages.callCabal2nix "generate-ci" ./. {};
+ default = check-submodules;
+ };
+
+ devShells.default = self.packages.${system}.default.env;
+
+ apps = rec {
+ check-submodules = flake-utils.lib.mkApp {
+ drv = self.packages.${system}.check-submodules;
+ };
+ default = check-submodules;
+ };
+ }
+ );
+}
+
=====================================
utils/check-submodules/hie.yaml
=====================================
@@ -0,0 +1,2 @@
+cradle:
+ cabal:
=====================================
utils/check-submodules/src/CheckTags.hs
=====================================
@@ -0,0 +1,68 @@
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
+
+module CheckTags
+ ( checkTags
+ ) where
+
+import Data.List (isPrefixOf, isSuffixOf)
+import Git qualified
+import Package (Package(..))
+import Packages (packages)
+import Pretty
+import Control.Monad (unless)
+
+findReleaseTag :: Git.GitRepo -> Package -> IO (Maybe Git.Tag)
+findReleaseTag repo pkg = do
+ allTags <- Git.reachableTags repo "HEAD"
+ case filter (\tag -> pkgIsReleaseTag pkg tag || isGhcTag tag) allTags of
+ [] -> return Nothing
+ tag:_ -> return (Just tag)
+
+isGhcTag :: Git.Tag -> Bool
+isGhcTag tag = "-ghc" `isSuffixOf` tag
+
+checkTag :: Git.GitRepo -> Package -> IO (Maybe Doc)
+checkTag repo pkg = do
+ mb_tag <- findReleaseTag repo pkg
+ case mb_tag of
+ Nothing -> return $ Just "No release tags found"
+ Just tag -> checkChanges repo tag
+
+-- | Check whether the tag only deviates from HEAD in trivial ways.
+checkChanges :: Git.GitRepo -> Git.Ref -> IO (Maybe Doc)
+checkChanges repo tag = do
+ files <- Git.changedFiles repo tag "HEAD"
+ case filter (not . okayChange) files of
+ [] -> return Nothing
+ badFiles -> do
+ described <- Git.describeRef repo "HEAD"
+ let msg = vsep
+ [ "Tag" <+> ppCommit (pretty tag) <+> "differs from" <+> ppCommit (pretty described) <+> "in:"
+ , bulletList fileList
+ ]
+ maxFiles = 5
+ fileList
+ | n > 0 =
+ take maxFiles (map pretty badFiles) ++
+ ["... and" <+> pretty n <+> "other" <+> plural "file" "files" n]
+ | otherwise = map pretty badFiles
+ where n = length badFiles - maxFiles
+ return $ Just msg
+
+okayChange :: FilePath -> Bool
+okayChange path
+ | "." `isPrefixOf` path = True
+ | ".gitignore" `isSuffixOf` path = True
+ | otherwise = False
+
+checkTags :: IO ()
+checkTags = do
+ let ghcRepo = Git.GitRepo "."
+ errs <- mapM (\pkg -> (pkg,) <$> checkTag (Git.submoduleIn ghcRepo (pkgPath pkg)) pkg) packages
+ putDoc $ bulletList
+ [ severityIcon Error <+> ppPackage pkg <> ":" <+> err
+ | (pkg, Just err) <- errs
+ ]
+ unless (null errs) $ fail "Tag issues above"
=====================================
utils/check-submodules/src/CheckVersions.hs
=====================================
@@ -0,0 +1,83 @@
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
+
+module CheckVersions
+ ( checkVersions
+ , summarize
+ , maintainerEmails
+ ) where
+
+import Control.Monad (forM_)
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Writer
+import Data.Function (on)
+import Data.List (intercalate, sort, sortOn, nubBy)
+import Data.Map.Strict qualified as M
+import Data.Text qualified as T
+import Data.Version
+import Distribution.Types.PackageName qualified as C
+import System.Exit
+
+import Hackage (getVersions, PackageState (..))
+import Pretty
+import Package
+import Packages
+
+isPvpCompatible :: Version -> Version -> Bool
+isPvpCompatible a b =
+ take 2 (versionBranch a) == take 2 (versionBranch b)
+
+updateVersion :: M.Map Version PackageState -> Version -> Maybe Version
+updateVersion available v
+ | [] <- compatible = Nothing
+ | otherwise = Just $ maximum compatible
+ where
+ compatible =
+ [ v'
+ | (v', Normal) <- M.assocs available -- non-deprecated versions available via Hackage...
+ , v' > v -- that are newer than the submodule...
+ , v' `isPvpCompatible` v -- and are compatible with the submodule
+ ]
+
+checkPackage :: Package -> WriterT [(Severity, Doc)] IO ()
+checkPackage pkg = do
+ v <- liftIO $ getPackageVersion pkg
+ available <- liftIO $ getVersions (pkgName pkg)
+
+ case M.lookup v available of
+ Nothing -> tellMsg Error $ "Version" <+> ppVersion v <+> "is not on Hackage"
+ Just Deprecated -> tellMsg Error $ "Version" <+> ppVersion v <+> "has been deprecated"
+ Just Normal -> return ()
+
+ case updateVersion available v of
+ Nothing -> return ()
+ Just v' -> tellMsg Warning $ "Shipping with" <+> ppVersion v <+> "but newer version" <+> ppVersion v' <+> "is available"
+
+tellMsg :: Severity -> Doc -> WriterT [(Severity, Doc)] IO ()
+tellMsg sev msg = tell [(sev, msg)]
+
+summarizeSubmodules :: [Package] -> IO ()
+summarizeSubmodules pkgs = forM_ (sortOn pkgName pkgs) $ \pkg -> do
+ v <- getPackageVersion pkg
+ putStrLn $ " " <> C.unPackageName (pkgName pkg) <> " " <> showVersion v <> " @ " <> pkgPath pkg
+
+maintainerEmails :: IO String
+maintainerEmails = do
+ maintainers <- concat <$> mapM getPackageMaintainers packages
+ return $ intercalate ", " $ map (T.unpack . contactRecipient) $ nubBy ((==) `on` contactEmail) $ sort maintainers
+
+summarize :: IO ()
+summarize =
+ summarizeSubmodules packages
+
+checkVersions :: IO ()
+checkVersions = do
+ errs <- mapM (\pkg -> map (pkg, ) <$> execWriterT (checkPackage pkg)) packages
+ putDoc $ bulletList
+ [ severityIcon sev <+> ppPackage pkg <> ":" <+> err
+ | (pkg, (sev, err)) <- concat errs
+ ]
+ putStrLn ""
+ exitWith $ if null errs then ExitSuccess else ExitFailure 1
+
=====================================
utils/check-submodules/src/Git.hs
=====================================
@@ -0,0 +1,52 @@
+{-# LANGUAGE ImportQualifiedPost #-}
+
+module Git
+ ( GitRepo(..)
+ , submoduleIn
+
+ , Ref
+ , describeRef
+ , submoduleCommit
+ , Tag
+ , reachableTags
+ , changedFiles
+ ) where
+
+import System.Process.Typed
+import Data.ByteString.Lazy.Char8 qualified as BSL
+import System.FilePath ((</>))
+
+newtype GitRepo = GitRepo { gitRepoPath :: FilePath }
+
+submoduleIn :: GitRepo -> FilePath -> GitRepo
+submoduleIn (GitRepo path) submod =
+ GitRepo $ path </> submod
+
+type Ref = String
+type Tag = String
+
+runGit :: GitRepo -> [String] -> IO BSL.ByteString
+runGit (GitRepo path) args = do
+ readProcessStdout_ $ setWorkingDir path (proc "git" args)
+
+describeRef :: GitRepo -> Ref -> IO String
+describeRef repo ref =
+ head . lines . BSL.unpack <$> runGit repo ["describe", "--always", ref]
+
+-- | Get the commit of the given submodule.
+submoduleCommit :: GitRepo -> FilePath -> IO Ref
+submoduleCommit repo submodule = do
+ out <- runGit repo ["submodule", "status", submodule]
+ case BSL.words $ BSL.drop 1 out of
+ commit:_ -> return $ BSL.unpack commit
+ _ -> fail "Unrecognized output from `git submodule status`"
+
+-- | Get the most recent tags reacheable from the given commit.
+reachableTags :: GitRepo -> Ref -> IO [Tag]
+reachableTags repo ref =
+ reverse . map BSL.unpack . BSL.lines <$> runGit repo ["tag", "--sort=taggerdate", "--merged", ref]
+
+changedFiles :: GitRepo -> Ref -> Ref -> IO [FilePath]
+changedFiles repo a b = do
+ map BSL.unpack . BSL.lines <$> runGit repo ["diff", "--name-only", a, b]
+
=====================================
utils/check-submodules/src/Hackage.hs
=====================================
@@ -0,0 +1,32 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Hackage
+ ( PackageState(..)
+ , getVersions
+ ) where
+
+import qualified Data.Map.Strict as M
+import Lens.Micro
+import Network.Wreq
+import Distribution.Types.PackageName
+import qualified Data.Aeson as JSON
+import Data.Version
+
+data PackageState = Normal | Deprecated
+ deriving (Show)
+
+instance JSON.FromJSON PackageState where
+ parseJSON = JSON.withText "package state" $ \case
+ "normal" -> pure Normal
+ "deprecated" -> pure Deprecated
+ _ -> fail "unknown PackageState"
+
+getVersions :: PackageName -> IO (M.Map Version PackageState)
+getVersions pn = do
+ r <- asJSON =<< getWith opts url
+ maybe (fail "getVersions: failed") pure (r ^? responseBody)
+ where
+ opts = defaults & header "Accept" .~ ["application/json"]
+ url = "https://hackage.haskell.org/package/" <> unPackageName pn
+
=====================================
utils/check-submodules/src/Package.hs
=====================================
@@ -0,0 +1,62 @@
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Package
+ ( Contact(..)
+ , parseContact
+ , contactRecipient
+
+ , Package(..)
+ , getPackageVersion
+ , getPackageMaintainers
+ ) where
+
+import Data.ByteString qualified as BS
+import Data.Text qualified as T
+import Data.Version
+import Distribution.PackageDescription.Parsec qualified as C
+import Distribution.Types.GenericPackageDescription qualified as C
+import Distribution.Types.PackageDescription qualified as C
+import Distribution.Types.PackageId qualified as C
+import Distribution.Types.PackageName (PackageName)
+import Distribution.Types.PackageName qualified as C
+import Distribution.Types.Version qualified as C
+import Distribution.Utils.ShortText qualified as C
+import System.FilePath
+
+data Contact = Contact { contactName, contactEmail :: T.Text }
+ deriving (Eq, Ord, Show)
+
+parseContact :: T.Text -> Contact
+parseContact t
+ | '<' `T.elem` t =
+ let (name,email) = T.break (== '<') t
+ in Contact (T.strip name) (T.strip $ T.takeWhile (/= '>') $ T.drop 1 email)
+ | otherwise = Contact "" t
+
+contactRecipient :: Contact -> T.Text
+contactRecipient (Contact name email)
+ | T.null name = email
+ | otherwise = name <> " <" <> email <> ">"
+
+data Package = Package { pkgName :: PackageName
+ , pkgPath :: FilePath
+ , pkgIsReleaseTag :: String -> Bool
+ }
+
+getPackageDescription :: Package -> IO C.PackageDescription
+getPackageDescription pkg = do
+ Just gpd <- C.parseGenericPackageDescriptionMaybe <$> BS.readFile (pkgPath pkg </> C.unPackageName (pkgName pkg) <.> "cabal")
+ return $ C.packageDescription gpd
+
+getPackageMaintainers :: Package -> IO [Contact]
+getPackageMaintainers pkg =
+ map (parseContact . T.strip . T.filter (/= '\n')) . T.splitOn ","
+ . T.pack . C.fromShortText . C.maintainer
+ <$> getPackageDescription pkg
+
+getPackageVersion :: Package -> IO Version
+getPackageVersion pkg =
+ Data.Version.makeVersion . C.versionNumbers . C.pkgVersion . C.package
+ <$> getPackageDescription pkg
+
=====================================
utils/check-submodules/src/Packages.hs
=====================================
@@ -0,0 +1,56 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Packages (packages) where
+
+import Package
+import Data.Char (isDigit)
+import qualified Distribution.Types.PackageName as C
+import Data.List
+
+packages :: [Package]
+packages =
+ [ Package "Cabal" "libraries/Cabal/Cabal" (isStdPrefixTag "Cabal-")
+ , Package "Cabal-syntax" "libraries/Cabal/Cabal-syntax" (isStdPrefixTag "Cabal-syntax-")
+ , stdPackage "array" "libraries/array"
+ , stdPackage "binary" "libraries/binary"
+ , stdPackage "bytestring" "libraries/bytestring"
+ , stdPackage "containers" "libraries/containers/containers"
+ , stdPackage "deepseq" "libraries/deepseq"
+ , stdPackage "directory" "libraries/directory"
+ , stdPackage "file-io" "libraries/file-io"
+ , stdPackage "filepath" "libraries/filepath"
+ , stdPackage "haskeline" "libraries/haskeline"
+ , stdPackage "hpc" "libraries/hpc"
+ , stdPackage "hsc2hs" "utils/hsc2hs"
+ , stdPackage "mtl" "libraries/mtl"
+ , stdPackage "os-string" "libraries/os-string"
+ , stdPackage "parsec" "libraries/parsec"
+ , stdPackage "pretty" "libraries/pretty"
+ , stdPackage "process" "libraries/process"
+ , stdPackage "terminfo" "libraries/terminfo"
+ , stdPackage "text" "libraries/text"
+ , stdPackage "time" "libraries/time"
+ , stdPackage "unix" "libraries/unix"
+ , stdPackage "exceptions" "libraries/exceptions"
+ , stdPackage "semaphore-compat" "libraries/semaphore-compat"
+ , stdPackage "stm" "libraries/stm"
+ , stdPackage "Win32" "libraries/Win32"
+ , stdPackage "xhtml" "libraries/xhtml"
+ ]
+
+stdPackage :: C.PackageName -> FilePath -> Package
+stdPackage name path = Package name path (isStdPrefixTag "")
+
+looksLikeVersion :: String -> Bool
+looksLikeVersion =
+ all (\c -> isDigit c || c == '.')
+
+isPrefixTag :: String -> String -> Bool
+isPrefixTag prefix tag
+ | Just rest <- prefix `stripPrefix` tag = looksLikeVersion rest
+ | otherwise = False
+
+isStdPrefixTag :: String -> String -> Bool
+isStdPrefixTag prefix tag =
+ isPrefixTag (prefix <> "v") tag || isPrefixTag prefix tag
+
=====================================
utils/check-submodules/src/Pretty.hs
=====================================
@@ -0,0 +1,57 @@
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Pretty
+ ( module Prettyprinter
+ , Doc
+ , mkMsg
+ , Severity(..)
+ , severityIcon
+ , bulletList
+ , ppCommit
+ , ppPackage
+ , ppVersion
+ , ppHeading
+ , putDoc
+ ) where
+
+import Data.Version
+import Package
+import Prettyprinter hiding (Doc)
+import Prettyprinter qualified as PP
+import Prettyprinter.Render.Terminal
+import Distribution.Types.PackageName qualified as C
+
+type Doc = PP.Doc AnsiStyle
+
+ppPackage :: Package -> Doc
+ppPackage =
+ annotate (color Green) . pretty . C.unPackageName . pkgName
+
+ppVersion :: Version -> Doc
+ppVersion v =
+ annotate (color Blue) $ pretty $ showVersion v
+
+ppCommit :: Doc -> Doc
+ppCommit =
+ annotate (color Blue)
+
+ppHeading :: Doc -> Doc
+ppHeading =
+ annotate bold . ("#" <+>)
+
+bullet :: Doc
+bullet = "‣"
+
+bulletList :: [Doc] -> Doc
+bulletList xs = vcat [ " " <> bullet <+> align x | x <- xs ]
+
+data Severity = Info | Warning | Error
+
+severityIcon :: Severity -> Doc
+severityIcon Info = annotate (color Blue) "ℹ" -- "🔵"
+severityIcon Warning = "🟡"
+severityIcon Error = annotate (color Red) "✗" -- "🔴"
+
+mkMsg :: Severity -> Doc -> Doc
+mkMsg s msg = severityIcon s <+> msg
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/795105ee383d32e57c93aaf5868184…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/795105ee383d32e57c93aaf5868184…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/libffi-3.5.0] 6 commits: Add necessary flag for js linking
by Cheng Shao (＠TerrorJack) 12 Jun '25
by Cheng Shao (＠TerrorJack) 12 Jun '25
12 Jun '25
Cheng Shao pushed to branch wip/libffi-3.5.0 at Glasgow Haskell Compiler / GHC
Commits:
1d99d3e4 by maralorn at 2025-06-12T03:47:39-04:00
Add necessary flag for js linking
- - - - -
974d5734 by maralorn at 2025-06-12T03:47:39-04:00
Don’t use additional linker flags to detect presence of -fno-pie in configure.ac
This mirrors the behavior of ghc-toolchain
- - - - -
1e9eb118 by Andrew Lelechenko at 2025-06-12T03:48:21-04:00
Add HasCallStack to Control.Monad.Fail.fail
CLC proposal https://github.com/haskell/core-libraries-committee/issues/327
2% compile-time allocations increase in T3064, likely because `fail`
is now marginally more expensive to compile.
Metric Increase:
T3064
- - - - -
6d12060f by meooow25 at 2025-06-12T14:26:07-04:00
Bump containers submodule to 0.8
Also
* Disable -Wunused-imports for containers
* Allow containers-0.8 for in-tree packages
* Bump some submodules so that they allow containers-0.8. These are not
at any particular versions.
* Remove unused deps containers and split from ucd2haskell
* Fix tests affected by the new containers and hpc-bin
- - - - -
537bd233 by Peng Fan at 2025-06-12T14:27:02-04:00
NCG/LA64: Optimize code generation and reduce build-directory size.
1. makeFarBranches: Prioritize fewer instruction sequences.
2. Prefer instructions with immediate numbers to reduce register moves,
e.g. andi,ori,xori,addi.
3. Ppr: Remove unnecessary judgments.
4. genJump: Avoid "ld+jr" as much as possible.
5. BCOND and BCOND1: Implement conditional jumps with two jump ranges,
with limited choice of the shortest.
6. Implement FSQRT, CLT, CTZ.
7. Remove unnecessary code.
- - - - -
245a00ba by Cheng Shao at 2025-06-12T21:31:22+00:00
libffi: update to 3.5.1
Bumps libffi submodule.
- - - - -
47 changed files:
- compiler/GHC/CmmToAsm/LA64.hs
- compiler/GHC/CmmToAsm/LA64/CodeGen.hs
- compiler/GHC/CmmToAsm/LA64/Instr.hs
- compiler/GHC/CmmToAsm/LA64/Ppr.hs
- compiler/ghc.cabal.in
- ghc/ghc-bin.cabal.in
- hadrian/hadrian.cabal
- hadrian/src/Settings/Warnings.hs
- libffi-tarballs
- libraries/base/changelog.md
- libraries/base/tests/IO/withBinaryFile002.stderr
- libraries/base/tests/IO/withFile002.stderr
- libraries/base/tests/IO/withFileBlocking002.stderr
- libraries/containers
- libraries/ghc-boot/ghc-boot.cabal.in
- libraries/ghc-heap/ghc-heap.cabal.in
- libraries/ghc-internal/src/GHC/Internal/Control/Monad/Fail.hs
- libraries/ghc-internal/src/GHC/Internal/Exception/Type.hs-boot
- libraries/ghc-internal/src/GHC/Internal/IO.hs-boot
- libraries/ghc-internal/src/GHC/Internal/IO/Exception.hs-boot
- libraries/ghc-internal/tools/ucd2haskell/ucd2haskell.cabal
- libraries/ghci/ghci.cabal.in
- libraries/haskeline
- libraries/hpc
- m4/fp_gcc_supports_no_pie.m4
- m4/fptools_set_c_ld_flags.m4
- testsuite/tests/deSugar/should_run/DsDoExprFailMsg.stderr
- testsuite/tests/deSugar/should_run/DsMonadCompFailMsg.stderr
- testsuite/tests/hpc/fork/hpc_fork.stdout
- testsuite/tests/hpc/function/tough.stdout
- testsuite/tests/hpc/function2/tough2.stdout
- testsuite/tests/hpc/simple/hpc001.stdout
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/interface-stability/base-exports.stdout-ws-32
- testsuite/tests/partial-sigs/should_fail/T10999.stderr
- testsuite/tests/rebindable/DoRestrictedM.hs
- testsuite/tests/th/T15321.stderr
- testsuite/tests/typecheck/should_compile/subsumption_sort_hole_fits.stderr
- testsuite/tests/typecheck/should_compile/valid_hole_fits.stderr
- utils/ghc-toolchain/src/GHC/Toolchain/Tools/Link.hs
- utils/haddock/haddock-library/haddock-library.cabal
- utils/haddock/hypsrc-test/ref/src/Quasiquoter.html
- utils/hpc
- utils/hsc2hs
- utils/iserv/iserv.cabal.in
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4ebbaf164154b311a3d8c3bf8310fd…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4ebbaf164154b311a3d8c3bf8310fd…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
12 Jun '25
Ben Gamari pushed to branch wip/ghc-9.14 at Glasgow Haskell Compiler / GHC
Commits:
de5e7327 by Ben Gamari at 2025-06-12T17:06:18-04:00
base: Bump version to 4.22.0
- - - - -
26 changed files:
- compiler/ghc.cabal.in
- libraries/array
- libraries/base/base.cabal.in
- libraries/deepseq
- libraries/directory
- libraries/filepath
- libraries/ghc-boot-th/ghc-boot-th.cabal.in
- libraries/ghc-boot/ghc-boot.cabal.in
- libraries/ghc-compact/ghc-compact.cabal
- libraries/ghc-experimental/ghc-experimental.cabal.in
- libraries/ghci/ghci.cabal.in
- libraries/haskeline
- libraries/hpc
- libraries/os-string
- libraries/parsec
- libraries/process
- libraries/semaphore-compat
- libraries/stm
- libraries/template-haskell/template-haskell.cabal.in
- libraries/terminfo
- libraries/text
- utils/haddock/haddock-api/haddock-api.cabal
- utils/haddock/haddock-library/haddock-library.cabal
- utils/haddock/haddock-test/haddock-test.cabal
- utils/haddock/haddock.cabal
- utils/hsc2hs
Changes:
=====================================
compiler/ghc.cabal.in
=====================================
@@ -114,7 +114,7 @@ Library
extra-libraries: zstd
CPP-Options: -DHAVE_LIBZSTD
- Build-Depends: base >= 4.11 && < 4.22,
+ Build-Depends: base >= 4.11 && < 4.23,
deepseq >= 1.4 && < 1.6,
directory >= 1 && < 1.4,
process >= 1 && < 1.7,
=====================================
libraries/array
=====================================
@@ -1 +1 @@
-Subproject commit b362edee437c88f2ac38971b66631ed782caa275
+Subproject commit 6d59d5deb4f2a12656ab4c4371c0d12dac4875ef
=====================================
libraries/base/base.cabal.in
=====================================
@@ -4,7 +4,7 @@ cabal-version: 3.0
-- Make sure you are editing ghc-experimental.cabal.in, not ghc-experimental.cabal
name: base
-version: 4.21.0.0
+version: 4.22.0.0
-- NOTE: Don't forget to update ./changelog.md
license: BSD-3-Clause
=====================================
libraries/deepseq
=====================================
@@ -1 +1 @@
-Subproject commit af115cc226cc87fba89d0f6e2e9212e755c24983
+Subproject commit ae2762ac241a61852c9ff4c287af234fb1ad931f
=====================================
libraries/directory
=====================================
@@ -1 +1 @@
-Subproject commit eb40bbebcaf86153bbc60772fb2e0466d35c95c4
+Subproject commit ffd4fc248ee36095ddec55598b0f8e3a9ac762a8
=====================================
libraries/filepath
=====================================
@@ -1 +1 @@
-Subproject commit 65b0f8f31aac4a306135e27734988327f8eb1e6f
+Subproject commit cbcd0ccf92f47e6c10fb9cc513a7b26facfc19fe
=====================================
libraries/ghc-boot-th/ghc-boot-th.cabal.in
=====================================
@@ -49,8 +49,8 @@ Library
GHC.Lexeme
build-depends:
- base >= 4.7 && < 4.22,
- pretty == 1.1.*
+ base >= 4.7 && < 4.23,
+ pretty == 1.1.*
if flag(bootstrap)
cpp-options: -DBOOTSTRAP_TH
=====================================
libraries/ghc-boot/ghc-boot.cabal.in
=====================================
@@ -75,7 +75,7 @@ Library
GHC.Version
GHC.Platform.Host
- build-depends: base >= 4.7 && < 4.22,
+ build-depends: base >= 4.7 && < 4.23,
binary == 0.8.*,
bytestring >= 0.10 && < 0.13,
containers >= 0.5 && < 0.9,
=====================================
libraries/ghc-compact/ghc-compact.cabal
=====================================
@@ -39,7 +39,7 @@ library
UnboxedTuples
CPP
- build-depends: base >= 4.9.0 && < 4.22,
+ build-depends: base >= 4.9.0 && < 4.23,
bytestring >= 0.10.6.0 && <0.13
ghc-options: -Wall
=====================================
libraries/ghc-experimental/ghc-experimental.cabal.in
=====================================
@@ -41,7 +41,7 @@ library
if arch(wasm32)
exposed-modules: GHC.Wasm.Prim
other-extensions:
- build-depends: base >=4.20 && < 4.22,
+ build-depends: base >=4.20 && < 4.23,
ghc-internal == @ProjectVersionForLib@.*
hs-source-dirs: src
default-language: Haskell2010
=====================================
libraries/ghci/ghci.cabal.in
=====================================
@@ -84,7 +84,7 @@ library
Build-Depends:
rts,
array == 0.5.*,
- base >= 4.8 && < 4.22,
+ base >= 4.8 && < 4.23,
-- ghc-internal == @ProjectVersionForLib@.*
-- TODO: Use GHC.Internal.Desugar and GHC.Internal.Base from
-- ghc-internal instead of ignoring the deprecation warning in GHCi.TH
=====================================
libraries/haskeline
=====================================
@@ -1 +1 @@
-Subproject commit 1ef56b16d3ed1f063211982668329d9e3113fd5b
+Subproject commit 991953cd5d3bb9e8057de4a0d8f2cae3455865d8
=====================================
libraries/hpc
=====================================
@@ -1 +1 @@
-Subproject commit 304aaecec374fdfbf15bfb6c223a66e9730ea253
+Subproject commit 7b7aed397cbe2bb36824d8627527fa4d5abffaa6
=====================================
libraries/os-string
=====================================
@@ -1 +1 @@
-Subproject commit 4b5efedcd2da9314edda80d973a44e67020370db
+Subproject commit 2e693aad07540173a0169971b27c9acac28eeff1
=====================================
libraries/parsec
=====================================
@@ -1 +1 @@
-Subproject commit b87122c1c74b8240e65044a8f600f0427d4dd9c3
+Subproject commit 8daa3751e52d4f95a8f6c8d98460ae184d03fdf5
=====================================
libraries/process
=====================================
@@ -1 +1 @@
-Subproject commit fbbe60718736999db701c12528c85cbc605ab4fb
+Subproject commit ae50731b5fb221a7631f7e9d818fc6716c85c51e
=====================================
libraries/semaphore-compat
=====================================
@@ -1 +1 @@
-Subproject commit 54882cd9a07322a4cf95d4fc0627107eaf1eb051
+Subproject commit cae2b69eedf3b119e702e798cc3f768b38ac3125
=====================================
libraries/stm
=====================================
@@ -1 +1 @@
-Subproject commit def18948f42a2eb8c34efdf65f7e614d1f6d5703
+Subproject commit e7783cda50e9ee746565831443e200884fd9a466
=====================================
libraries/template-haskell/template-haskell.cabal.in
=====================================
@@ -51,7 +51,7 @@ Library
Language.Haskell.TH.CodeDo
build-depends:
- base >= 4.11 && < 4.22,
+ base >= 4.11 && < 4.23,
-- We don't directly depend on any of the modules from `ghc-internal`
-- But we need to depend on it to work around a hadrian bug.
-- See: https://gitlab.haskell.org/ghc/ghc/-/issues/25705
=====================================
libraries/terminfo
=====================================
@@ -1 +1 @@
-Subproject commit a76fac0c60cf6db7ed724d9b5c5067d77a23efc7
+Subproject commit 16db154e3e97e6bff62329574163851a7090f3b6
=====================================
libraries/text
=====================================
@@ -1 +1 @@
-Subproject commit b86564cae8d7262c7c4e7afe7a9163c83de3f175
+Subproject commit f453ea717a1b90a8647f74e6b629ae5cac457ce6
=====================================
utils/haddock/haddock-api/haddock-api.cabal
=====================================
@@ -78,7 +78,7 @@ library
build-depends: ghc-paths ^>= 0.1.0.12
-- this package typically supports only single major versions
- build-depends: base >= 4.16 && < 4.22
+ build-depends: base >= 4.16 && < 4.23
, ghc ^>= 9.14
, haddock-library ^>= 1.11
, xhtml ^>= 3000.2.2
=====================================
utils/haddock/haddock-library/haddock-library.cabal
=====================================
@@ -46,7 +46,7 @@ common ghc-options
-Wnoncanonical-monad-instances -Wmissing-home-modules
build-depends:
- , base >= 4.10 && < 4.22
+ , base >= 4.10 && < 4.23
, containers >= 0.4.2.1 && < 0.9
, text ^>= 1.2.3.0 || ^>= 2.0 || ^>= 2.1
, parsec ^>= 3.1.13.0
=====================================
utils/haddock/haddock-test/haddock-test.cabal
=====================================
@@ -16,7 +16,7 @@ library
default-language: Haskell2010
ghc-options: -Wall
hs-source-dirs: src
- build-depends: base >= 4.3 && < 4.22, bytestring, directory, process, filepath, Cabal
+ build-depends: base >= 4.3 && < 4.23, bytestring, directory, process, filepath, Cabal
exposed-modules:
Test.Haddock
=====================================
utils/haddock/haddock.cabal
=====================================
@@ -90,7 +90,7 @@ executable haddock
-- haddock typically only supports a single GHC major version
build-depends:
- base >= 4.13.0.0 && <4.22,
+ base >= 4.13.0.0 && <4.23,
-- in order for haddock's advertised version number to have proper meaning,
-- we pin down to a single haddock-api version.
haddock-api == 2.30.0
=====================================
utils/hsc2hs
=====================================
@@ -1 +1 @@
-Subproject commit 044e04f14ff886456837b9784b2972af71c66494
+Subproject commit fe3990b9f35000427b016a79330d9f195587cad8
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/de5e7327eb4b9778bbbffcbc2de6872…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/de5e7327eb4b9778bbbffcbc2de6872…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: Bump containers submodule to 0.8
by Marge Bot (＠marge-bot) 12 Jun '25
by Marge Bot (＠marge-bot) 12 Jun '25
12 Jun '25
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
6d12060f by meooow25 at 2025-06-12T14:26:07-04:00
Bump containers submodule to 0.8
Also
* Disable -Wunused-imports for containers
* Allow containers-0.8 for in-tree packages
* Bump some submodules so that they allow containers-0.8. These are not
at any particular versions.
* Remove unused deps containers and split from ucd2haskell
* Fix tests affected by the new containers and hpc-bin
- - - - -
537bd233 by Peng Fan at 2025-06-12T14:27:02-04:00
NCG/LA64: Optimize code generation and reduce build-directory size.
1. makeFarBranches: Prioritize fewer instruction sequences.
2. Prefer instructions with immediate numbers to reduce register moves,
e.g. andi,ori,xori,addi.
3. Ppr: Remove unnecessary judgments.
4. genJump: Avoid "ld+jr" as much as possible.
5. BCOND and BCOND1: Implement conditional jumps with two jump ranges,
with limited choice of the shortest.
6. Implement FSQRT, CLT, CTZ.
7. Remove unnecessary code.
- - - - -
7f7fe85e by Simon Peyton Jones at 2025-06-12T16:34:50-04:00
Improve redundant constraints for instance decls
Addresses #25992, which showed that the default methods
of an instance decl could make GHC fail to report redundant
constraints.
Figuring out how to do this led me to refactor the computation
of redundant constraints. See the entirely rewritten
Note [Tracking redundant constraints]
in GHC.Tc.Solver.Solve
- - - - -
f8a853be by Matthew Pickering at 2025-06-12T16:34:51-04:00
Refactor the treatment of nested Template Haskell splices
* The difference between a normal splice, a quasiquoter and implicit
splice caused by lifting is stored in the AST after renaming.
* Information that the renamer learns about splices is stored in the
relevant splice extension points (XUntypedSpliceExpr, XQuasiQuote).
* Normal splices and quasi quotes record the flavour of splice
(exp/pat/dec etc)
* Implicit lifting stores information about why the lift was attempted,
so if it fails, that can be reported to the user.
* After renaming, the decision taken to attempt to implicitly lift a
variable is stored in the `XXUntypedSplice` extension field in the
`HsImplicitLiftSplice` constructor.
* Since all the information is stored in the AST, in `HsUntypedSplice`,
the type of `PendingRnSplice` now just stores a `HsUntypedSplice`.
* Error messages since the original program can be easily
printed, this is noticeable in the case of implicit lifting.
* The user-written syntax is directly type-checked. Before, some
desugaring took place in the
* Fixes .hie files to work better with nested splices (nested splices
are not indexed)
* The location of the quoter in a quasiquote is now located, so error
messages will precisely point to it (and again, it is indexed by hie
files)
In the future, the typechecked AST should also retain information about
the splices and the specific desugaring being left to the desugarer.
Also, `runRnSplice` should call `tcUntypedSplice`, otherwise the
typechecking logic is duplicated (see the `QQError` and `QQTopError`
tests for a difference caused by this).
- - - - -
85 changed files:
- compiler/GHC/Builtin/Names/TH.hs
- compiler/GHC/CmmToAsm/LA64.hs
- compiler/GHC/CmmToAsm/LA64/CodeGen.hs
- compiler/GHC/CmmToAsm/LA64/Instr.hs
- compiler/GHC/CmmToAsm/LA64/Ppr.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Expr.hs-boot
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Lexer.x
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Rename/Splice.hs
- compiler/GHC/Tc/Errors.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/Tc/Gen/Splice.hs-boot
- compiler/GHC/Tc/Solver/Default.hs
- compiler/GHC/Tc/Solver/InertSet.hs
- compiler/GHC/Tc/Solver/Solve.hs
- compiler/GHC/Tc/TyCl/Instance.hs
- compiler/GHC/Tc/Types/Constraint.hs
- compiler/GHC/Tc/Types/ErrCtxt.hs
- compiler/GHC/Tc/Types/Evidence.hs
- compiler/GHC/Tc/Types/Origin.hs
- compiler/GHC/Tc/Types/TH.hs
- compiler/GHC/Tc/Utils/Concrete.hs
- compiler/GHC/Tc/Utils/Instantiate.hs
- compiler/GHC/Tc/Utils/TcMType.hs
- compiler/GHC/ThToHs.hs
- compiler/GHC/Types/Name/Reader.hs
- compiler/GHC/Types/ThLevelIndex.hs
- compiler/Language/Haskell/Syntax/Expr.hs
- compiler/Language/Haskell/Syntax/Extension.hs
- compiler/ghc.cabal.in
- ghc/ghc-bin.cabal.in
- hadrian/hadrian.cabal
- hadrian/src/Settings/Warnings.hs
- libraries/containers
- libraries/ghc-boot/ghc-boot.cabal.in
- libraries/ghc-heap/ghc-heap.cabal.in
- libraries/ghc-internal/tools/ucd2haskell/ucd2haskell.cabal
- libraries/ghci/ghci.cabal.in
- libraries/haskeline
- libraries/hpc
- testsuite/tests/dependent/should_fail/T13135_simple.stderr
- testsuite/tests/diagnostic-codes/codes.stdout
- testsuite/tests/hpc/fork/hpc_fork.stdout
- testsuite/tests/hpc/function/tough.stdout
- testsuite/tests/hpc/function2/tough2.stdout
- testsuite/tests/hpc/simple/hpc001.stdout
- testsuite/tests/linear/should_fail/LinearTHFail.stderr
- testsuite/tests/linters/notes.stdout
- testsuite/tests/partial-sigs/should_fail/T10999.stderr
- testsuite/tests/perf/compiler/hard_hole_fits.stderr
- testsuite/tests/quasiquotation/T3953.stderr
- + testsuite/tests/quotes/QQError.hs
- + testsuite/tests/quotes/QQError.stderr
- testsuite/tests/quotes/T10384.stderr
- testsuite/tests/quotes/TH_localname.stderr
- testsuite/tests/quotes/all.T
- testsuite/tests/rebindable/DoRestrictedM.hs
- + testsuite/tests/th/QQInQuote.hs
- + testsuite/tests/th/QQTopError.hs
- + testsuite/tests/th/QQTopError.stderr
- testsuite/tests/th/T10598_TH.stderr
- testsuite/tests/th/T14681.stderr
- testsuite/tests/th/T17804.stderr
- testsuite/tests/th/T5508.stderr
- testsuite/tests/th/TH_Lift.stderr
- testsuite/tests/th/all.T
- testsuite/tests/th/overloaded/TH_overloaded_constraints_fail.stderr
- + testsuite/tests/typecheck/should_compile/T25992.hs
- + testsuite/tests/typecheck/should_compile/T25992.stderr
- testsuite/tests/typecheck/should_compile/all.T
- testsuite/tests/typecheck/should_fail/tcfail097.stderr
- utils/check-exact/ExactPrint.hs
- utils/haddock/haddock-library/haddock-library.cabal
- utils/hpc
- utils/hsc2hs
- utils/iserv/iserv.cabal.in
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/faf968bb089132499bfd356ec3fe7e…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/faf968bb089132499bfd356ec3fe7e…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/T26118-remove-hptallfaminstances-usage-during-upsweep] reuse hugInstancesBelow to get hpt fam instances for checkFamInstConsistency
by Patrick (＠soulomoon) 12 Jun '25
by Patrick (＠soulomoon) 12 Jun '25
12 Jun '25
Patrick pushed to branch wip/T26118-remove-hptallfaminstances-usage-during-upsweep at Glasgow Haskell Compiler / GHC
Commits:
8b3c8036 by soulomoon at 2025-06-13T04:10:16+08:00
reuse hugInstancesBelow to get hpt fam instances for checkFamInstConsistency
- - - - -
3 changed files:
- compiler/GHC/Driver/Env.hs
- compiler/GHC/Tc/Instance/Family.hs
- compiler/GHC/Tc/Module.hs
Changes:
=====================================
compiler/GHC/Driver/Env.hs
=====================================
@@ -34,7 +34,6 @@ module GHC.Driver.Env
, hugInstancesBelow
, hugAnnsBelow
, hugCompleteSigsBelow
- , hugFamInstancesBelow
-- * Legacy API
, hscUpdateHPT
@@ -231,17 +230,6 @@ hugAnnsBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO AnnEnv
hugAnnsBelow hsc uid mn = foldr (flip extendAnnEnvList) emptyAnnEnv <$>
hugSomeThingsBelowUs (md_anns . hm_details) False hsc uid mn
-hugFamInstancesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO (ModuleEnv FamInstEnv)
-hugFamInstancesBelow = hugSomeThingsBelowUs' combine emptyModuleEnv True
- where
- hmiFamInstEnv = extendFamInstEnvList emptyFamInstEnv . (md_fam_insts . hm_details)
- hmiModule = mi_module . hm_iface
- combine :: HomeModInfo -> ModuleEnv FamInstEnv -> ModuleEnv FamInstEnv
- combine md acc = do
- let famInstEnv = hmiFamInstEnv md
- mod = hmiModule md
- in extendModuleEnvWith unionFamInstEnv acc mod famInstEnv
-
-- | Find all COMPLETE pragmas in modules that are in the transitive closure of the
-- given module.
hugCompleteSigsBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO CompleteMatches
@@ -249,7 +237,7 @@ hugCompleteSigsBelow hsc uid mn = foldr (++) [] <$>
hugSomeThingsBelowUs (md_complete_matches . hm_details) False hsc uid mn
-- | Find instances visible from the given set of imports
-hugInstancesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO (InstEnv, [FamInst])
+hugInstancesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO (InstEnv, [(Module, FamInstEnv)])
hugInstancesBelow hsc_env uid mnwib = do
let mn = gwib_mod mnwib
(insts, famInsts) <-
@@ -259,7 +247,7 @@ hugInstancesBelow hsc_env uid mnwib = do
-- Don't include instances for the current module
in if moduleName (mi_module (hm_iface mod_info)) == mn
then []
- else [(md_insts details, md_fam_insts details)])
+ else [(md_insts details, [(mi_module $ hm_iface mod_info, extendFamInstEnvList emptyFamInstEnv $ md_fam_insts details)])])
True -- Include -hi-boot
hsc_env
uid
@@ -269,19 +257,16 @@ hugInstancesBelow hsc_env uid mnwib = do
-- | Get things from modules in the transitive closure of the given module.
--
-- Note: Don't expose this function. This is a footgun if exposed!
-hugSomeThingsBelowUs' :: (HomeModInfo -> a -> a) -> a -> Bool -> HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO a
-hugSomeThingsBelowUs' _ acc _ hsc_env _ _ | isOneShot (ghcMode (hsc_dflags hsc_env)) = return acc
+hugSomeThingsBelowUs :: (HomeModInfo -> [a]) -> Bool -> HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO [[a]]
-- An explicit check to see if we are in one-shot mode to avoid poking the ModuleGraph thunk
-- These things are currently stored in the EPS for home packages. (See #25795 for
-- progress in removing these kind of checks)
-- See Note [Downsweep and the ModuleGraph]
-hugSomeThingsBelowUs' combine acc include_hi_boot hsc_env uid mn
+hugSomeThingsBelowUs _ _ hsc_env _ _ | isOneShot (ghcMode (hsc_dflags hsc_env)) = return []
+hugSomeThingsBelowUs extract include_hi_boot hsc_env uid mn
= let hug = hsc_HUG hsc_env
mg = hsc_mod_graph hsc_env
- combine' Nothing acc = acc
- combine' (Just hmi) acc = combine hmi acc
in
- foldr combine' acc <$>
sequence
[ things
-- "Finding each non-hi-boot module below me" maybe could be cached (well,
@@ -300,8 +285,8 @@ hugSomeThingsBelowUs' combine acc include_hi_boot hsc_env uid mn
-- Look it up in the HUG
, let things = lookupHug hug mod_uid mod >>= \case
- Just info -> return $ Just info
- Nothing -> pprTrace "WARNING in hugSomeThingsBelowUs" msg (pure Nothing)
+ Just info -> return $ extract info
+ Nothing -> pprTrace "WARNING in hugSomeThingsBelowUs" msg mempty
msg = vcat [text "missing module" <+> ppr mod,
text "When starting from" <+> ppr mn,
text "below:" <+> ppr (moduleGraphModulesBelow mg uid mn),
@@ -309,14 +294,6 @@ hugSomeThingsBelowUs' combine acc include_hi_boot hsc_env uid mn
-- This really shouldn't happen, but see #962
]
--- | Get things from modules in the transitive closure of the given module.
---
--- Note: Don't expose this function. This is a footgun if exposed!
-hugSomeThingsBelowUs :: (HomeModInfo -> [a]) -> Bool -> HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO [[a]]
-hugSomeThingsBelowUs f = hugSomeThingsBelowUs' combine []
- where
- combine hmi acc = f hmi : acc
-
-- | Deal with gathering annotations in from all possible places
-- and combining them into a single 'AnnEnv'
prepareAnnotations :: HscEnv -> Maybe ModGuts -> IO AnnEnv
=====================================
compiler/GHC/Tc/Instance/Family.hs
=====================================
@@ -25,7 +25,6 @@ import GHC.Core.TyCo.Rep
import GHC.Core.TyCo.FVs
import GHC.Iface.Load
-import GHC.IO (unsafeInterleaveIO)
import GHC.Tc.Errors.Types
import GHC.Tc.Types.Evidence
@@ -287,8 +286,8 @@ why we still do redundant checks.
-- We don't need to check the current module, this is done in
-- tcExtendLocalFamInstEnv.
-- See Note [The type family instance consistency story].
-checkFamInstConsistency :: [Module] -> HscEnv -> UnitId -> ModuleNameWithIsBoot -> TcM ()
-checkFamInstConsistency directlyImpMods hsc_env unitId mnwib
+checkFamInstConsistency :: ModuleEnv FamInstEnv -> [Module] -> TcM ()
+checkFamInstConsistency hpt_fam_insts directlyImpMods
= do { (eps, hug) <- getEpsAndHug
; traceTc "checkFamInstConsistency" (ppr directlyImpMods)
; let { -- Fetch the iface of a given module. Must succeed as
@@ -318,7 +317,6 @@ checkFamInstConsistency directlyImpMods hsc_env unitId mnwib
-- See Note [Order of type family consistency checks]
}
- ; hpt_fam_insts <- liftIO $ unsafeInterleaveIO $ hugFamInstancesBelow hsc_env unitId mnwib
; debug_consistent_set <- mapM (\x -> (\y -> (x, length y)) <$> modConsistent x) directlyImpMods
; traceTc "init_consistent_set" (ppr debug_consistent_set)
; let init_consistent_set = map fst (reverse (sortOn snd debug_consistent_set))
=====================================
compiler/GHC/Tc/Module.hs
=====================================
@@ -120,7 +120,7 @@ import GHC.Core.TyCo.Ppr( debugPprType )
import GHC.Core.TyCo.Tidy( tidyTopType )
import GHC.Core.FamInstEnv
( FamInst, pprFamInst, famInstsRepTyCons, orphNamesOfFamInst
- , famInstEnvElts, extendFamInstEnvList, normaliseType )
+ , famInstEnvElts, extendFamInstEnvList, normaliseType, emptyFamInstEnv, unionFamInstEnv )
import GHC.Parser.Header ( mkPrelImports )
@@ -467,8 +467,8 @@ tcRnImports hsc_env import_decls
= do { (rn_imports, imp_user_spec, rdr_env, imports) <- rnImports import_decls
-- Get the default declarations for the classes imported by this module
-- and group them by class.
- ; tc_defaults <-(NE.groupBy ((==) `on` cd_class) . (concatMap defaultList))
- <$> tcGetClsDefaults (M.keys $ imp_mods imports)
+ ; tc_defaults <- NE.groupBy ((==) `on` cd_class) . (concatMap defaultList)
+ <$> tcGetClsDefaults (M.keys $ imp_mods imports)
; this_mod <- getModule
; gbl_env <- getGblEnv
; let unitId = homeUnitId $ hsc_home_unit hsc_env
@@ -480,8 +480,10 @@ tcRnImports hsc_env import_decls
-- filtering also ensures that we don't see instances from
-- modules batch (@--make@) compiled before this one, but
-- which are not below this one.
- ; (home_insts, home_fam_insts) <- liftIO $
+ ; (home_insts, home_mod_fam_inst_env) <- liftIO $
hugInstancesBelow hsc_env unitId mnwib
+ ; let home_fam_inst_env = foldl' unionFamInstEnv emptyFamInstEnv $ snd <$> home_mod_fam_inst_env
+ ; let hpt_fam_insts = mkModuleEnv home_mod_fam_inst_env
-- We use 'unsafeInterleaveIO' to avoid redundant memory allocations
-- See Note [Lazily loading COMPLETE pragmas] from GHC.HsToCore.Monad
@@ -507,8 +509,7 @@ tcRnImports hsc_env import_decls
tcg_rn_imports = rn_imports,
tcg_default = foldMap subsume tc_defaults,
tcg_inst_env = tcg_inst_env gbl `unionInstEnv` home_insts,
- tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl)
- home_fam_insts
+ tcg_fam_inst_env = unionFamInstEnv (tcg_fam_inst_env gbl) home_fam_inst_env
}) $ do {
; traceRn "rn1" (ppr (imp_direct_dep_mods imports))
@@ -538,7 +539,7 @@ tcRnImports hsc_env import_decls
$ imports }
; logger <- getLogger
; withTiming logger (text "ConsistencyCheck"<+>brackets (ppr this_mod)) (const ())
- $ checkFamInstConsistency dir_imp_mods hsc_env unitId mnwib
+ $ checkFamInstConsistency hpt_fam_insts dir_imp_mods
; traceRn "rn1: } checking family instance consistency" empty
; gbl_env <- getGblEnv
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8b3c8036e60263902061622ddfeb7fe…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8b3c8036e60263902061622ddfeb7fe…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/ghc-9.14] 69 commits: Don't emit unprintable characters when printing Uniques
by Ben Gamari (＠bgamari) 12 Jun '25
by Ben Gamari (＠bgamari) 12 Jun '25
12 Jun '25
Ben Gamari pushed to branch wip/ghc-9.14 at Glasgow Haskell Compiler / GHC
Commits:
3b3a5dec by Ben Gamari at 2025-05-15T16:10:01-04:00
Don't emit unprintable characters when printing Uniques
When faced with an unprintable tag we now instead print the codepoint
number.
Fixes #25989.
(cherry picked from commit e832b1fadee66e8d6dd7b019368974756f8f8c46)
- - - - -
e1ef8974 by Mike Pilgrem at 2025-05-16T16:09:14-04:00
Translate iff in Haddock documentation into everyday English
- - - - -
fd64667d by Vladislav Zavialov at 2025-05-20T03:25:08-04:00
Allow the 'data' keyword in import/export lists (#25899)
This patch introduces the 'data' namespace specifier in import and
export lists. The intended use is to import data constructors without
their parent type constructors, e.g.
import Data.Proxy as D (data Proxy)
type DP = D.Proxy -- promoted data constructor
Additionally, it is possible to use 'data' to explicitly qualify any
data constructors or terms, incl. operators and field selectors
import Prelude (Semigroup(data (<>)))
import Data.Function (data (&))
import Data.Monoid (data Dual, data getDual)
x = Dual "Hello" <> Dual "World" & getDual
The implementation mostly builds on top of the existing logic for the
'type' and 'pattern' namespace specifiers, plus there are a few tweaks
to how we generate suggestions in error messages.
- - - - -
acc86753 by Ben Gamari at 2025-05-20T03:25:51-04:00
compiler: Use field selectors when creating BCOs
This makes it easier to grep for these fields.
- - - - -
60a55fd7 by Ben Gamari at 2025-05-20T03:25:51-04:00
compiler: Clarify BCO size
Previously the semantics and size of StgBCO was a bit unclear.
Specifically, the `size` field was documented to contain the size of the
bitmap whereas it was actually the size of the closure *and* bitmap.
Additionally, it was not as clear as it could be that the bitmap was a
full StgLargeBitmap with its own `size` field.
- - - - -
ac9fb269 by Simon Peyton Jones at 2025-05-20T09:19:04-04:00
Track rewriter sets more accurately in constraint solving
This MR addresses #26003, by refactoring the arcane
intricacies of Note [Equalities with incompatible kinds].
NB: now retitled to
Note [Equalities with heterogeneous kinds].
and the main Note for this MR.
In particular:
* Abandon invariant (COERCION-HOLE) in Note [Unification preconditions] in
GHC.Tc.Utils.Unify.
* Abandon invariant (TyEq:CH)) in Note [Canonical equalities] in
GHC.Tc.Types.Constraint.
* Instead: add invariant (REWRITERS) to Note [Unification preconditions]:
unify only if the constraint has an empty rewriter set.
Implementation:
* In canEqCanLHSFinish_try_unification, skip trying unification if there is a
non-empty rewriter set.
* To do this, make sure the rewriter set is zonked; do so in selectNextWorkItem,
which also deals with prioritisation.
* When a coercion hole is filled, kick out inert equalities that have that hole
as a rewriter. It might now be unlocked and available to unify.
* Remove the ad-hoc `ch_hetero_kind` field of `CoercionHole`.
* In `selectNextWorkItem`, priorities equalities withan empty rewriter set.
* Defaulting: see (DE6) in Note [Defaulting equalities]
and Note [Limited defaulting in the ambiguity check]
* Concreteness checks: there is some extra faff to try to get decent
error messages when the FRR (representation-polymorphism) checks
fail. In partiular, add a "When unifying..." explanation when the
representation-polymorphism check arose from another constraint.
- - - - -
86406f48 by Cheng Shao at 2025-05-20T09:19:47-04:00
rts: fix rts_clearMemory logic when sanity checks are enabled
This commit fixes an RTS assertion failure when invoking
rts_clearMemory with +RTS -DS. -DS implies -DZ which asserts that free
blocks contain 0xaa as the designated garbage value. Also adds the
sanity way to rts_clearMemory test to prevent future regression.
Closes #26011.
ChatGPT Codex automatically diagnosed the issue and proposed the
initial patch in a single shot, given a GHC checkout and the following
prompt:
---
Someone is reporting the following error when attempting to use `rts_clearMemory` with the RTS option `-DS`:
```
test.wasm: internal error: ASSERTION FAILED: file rts/sm/Storage.c, line 1216
(GHC version 9.12.2.20250327 for wasm32_unknown_wasi)
Please report this as a GHC bug: https://www.haskell.org/ghc/reportabug
```
What's the culprit? How do I look into this issue?
---
I manually reviewed & revised the patch, tested and submitted it.
- - - - -
7147370b by Cheng Shao at 2025-05-20T17:22:19-04:00
compiler: do not allocate strings in bytecode assembler
This patch refactors the compiler to avoid allocating iserv buffers
for BCONPtrStr at assemble-time. Now BCONPtrStr ByteStrings are
recorded as a part of CompiledByteCode, and actual allocation only
happens at link-time. This refactoring is necessary for adding
bytecode serialization functionality, as explained by the revised
comments in this commit.
- - - - -
a67db612 by Cheng Shao at 2025-05-20T17:22:19-04:00
compiler: make bc_strs serializable
This commit makes the bc_strs field in CompiledByteCode serializable;
similar to previous commit, we preserve the ByteString directly and
defer the actual allocation to link-time, as mentioned in updated
comment.
- - - - -
5faf34ef by Cheng Shao at 2025-05-20T17:22:19-04:00
compiler: make bc_itbls serializable
This commit makes bc_itbls in CompiledByteCode serializable. A
dedicated ConInfoTable datatype has been added in ghci which is the
recipe for dynamically making a datacon's info table, containing the
payload of the MkConInfoTable iserv message.
- - - - -
2abaf8c1 by Cheng Shao at 2025-05-20T17:22:19-04:00
compiler: remove FFIInfo bookkeeping in BCO
This commit removes the bc_ffis field from CompiledByteCode
completely, as well as all the related bookkeeping logic in
GHC.StgToByteCode. bc_ffis is actually *unused* in the rest of GHC
codebase! It is merely a list of FFIInfo, which is just a remote
pointer of the libffi ffi_cif struct; once we allocate the ffi_cif
struct and put its pointer in a CCALL instruction, we'll never free it
anyway. So there is no point of bookkeeping.
- - - - -
adb9e4d2 by Cheng Shao at 2025-05-20T17:22:19-04:00
compiler: make FFIInfo serializable in BCO
This commit makes all the FFIInfo needed in CCALL instructions
serializable. Previously, when doing STG to BCO lowering, we would
allocate a libffi ffi_cif struct and keep its remote pointer as
FFIInfo; but actually we can just keep the type signature as FFIInfo
and defer the actual allocation to link-time.
- - - - -
200f401b by Cheng Shao at 2025-05-20T17:22:19-04:00
ghci: remove redundant NewBreakModule message
This commit removes the redundant NewBreakModule message from ghci: it
just allocates two strings! This functionality can be implemented with
existing MallocStrings in one iserv call.
- - - - -
ddaadca6 by Cheng Shao at 2025-05-20T17:22:19-04:00
compiler: make breakpoint module name and unit id serializable
This commit makes breakpoint module name and unit id serializable, in
BRK_FUN instructions as well as ModBreaks. We can simply keep the
module name and unit ids, and defer the buffer allocation to link
time.
- - - - -
a0fde202 by Cheng Shao at 2025-05-20T17:22:19-04:00
compiler: remove unused newModule
This commit removes the now unused newModule function from GHC.
- - - - -
68c8f140 by Cheng Shao at 2025-05-20T17:22:19-04:00
compiler: add BCONPtrFS for interned top level string literals in BCO
This commit adds BCONPtrFS as a BCO non-pointer literal kind, which
has the same semantics of BCONPtrStr, except it contains a FastString
instead of a ByteString. By using BCONPtrFS to represent top level
string literals that are already FastString in the compilation
pipeline, we enjoy the FastString interning logic and avoid allocating
a bunch of redundant ByteStrings for the same FastStrings, especially
when we lower the BRK_FUN instruction.
- - - - -
f2b532bc by Peng Fan at 2025-05-20T17:23:15-04:00
hadrian: enable GHCi for loongarch64
- - - - -
8ded2330 by kwxm at 2025-05-20T17:24:07-04:00
Fix bugs in `integerRecipMod` and `integerPowMod`
This fixes #26017.
* `integerRecipMod x 1` now returns `(# 1 | #)` for all x; previously it
incorrectly returned `(# | () #)`, indicating failure.
* `integerPowMod 0 e m` now returns `(# | () #)` for e<0 and m>1, indicating
failure; previously it incorrectly returned `(# 0 | #)`.
- - - - -
c9abb87c by Andreas Klebinger at 2025-05-20T17:24:50-04:00
Specialise: Don't float out constraint components.
It was fairly complex to do so and it doesn't seem to improve anything.
Nofib allocations were unaffected as well.
See also Historical Note [Floating dictionaries out of cases]
- - - - -
202b201c by Andreas Klebinger at 2025-05-21T10:16:14-04: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.
- - - - -
67a177b4 by sheaf at 2025-05-21T10:17:04-04:00
QuickLook: do a shape test before unifying
This commit ensures we do a shape test before unifying. This ensures
we don't try to unify a TyVarTv with a non-tyvar, e.g.
alpha[tyv] := Int
On the way, we refactor simpleUnifyCheck:
1. Move the checkTopShape check into simpleUnifyCheck
2. Refactors simpleUnifyCheck to return a value of the new type
SimpleUnifyResult type. Now, simpleUnifyCheck returns "can unify",
"cannot unify" or "dunno" (with "cannot unify" being the new result
it can return). Now:
- touchabilityTest is included; it it fails we return "cannot unify"
- checkTopShape now returns "cannot unify" instead of "dunno" upon failure
3. Move the call to simpleUnifyCheck out of checkTouchableTyVarEq.
After that, checkTouchableTyVarEq becames a simple call to
checkTyEqRhs, so we inline it.
This allows the logic in canEqCanLHSFinish_try_unification to be simplified.
In particular, we now avoid calling 'checkTopShape' twice.
Two further changes suggested by Simon were also implemented:
- In canEqCanLHSFinish, if checkTyEqRhs returns PuFail with
'do_not_prevent_rewriting', we now **continue with this constraint**.
This allows us to use the constraint for rewriting.
- checkTyEqRhs now has a top-level check to avoid flattening a tyfam app
in a top-level equality of the form alpha ~ F tys, as this is
going around in circles. This simplifies the implementation without
any change in behaviour.
Fixes #25950
Fixes #26030
- - - - -
4020972c by sheaf at 2025-05-21T10:17:04-04:00
FixedRuntimeRepError: omit unhelpful explanation
This commit tweaks the FixedRuntimeRepError case of pprTcSolverReportMsg,
to avoid including an explanation which refers to a type variable that
appears nowhere else.
For example, the old error message could look like the following:
The pattern binding does not have a fixed runtime representation.
Its type is:
T :: TYPE R
Cannot unify ‘R’ with the type variable ‘c0’
because the former is not a concrete ‘RuntimeRep’.
With this commit, we now omit the last two lines, because the concrete
type variable (here 'c0') does not appear in the type displayed to the
user (here 'T :: TYPE R').
- - - - -
6d058a69 by Andrea Bedini at 2025-05-21T16:00:51-04:00
Don't fail when ghcversion.h can't be found (#26018)
If ghcversion.h can't be found, don't try to include it. This happens
when there is no rts package in the package db and when -ghcversion-file
argument isn't passed.
Co-authored-by: Syvlain Henry <sylvain(a)haskus.fr>
- - - - -
b1212fbf by Vladislav Zavialov at 2025-05-21T16:01:33-04:00
Implement -Wpattern-namespace-specifier (#25900)
In accordance with GHC Proposal #581 "Namespace-specified imports",
section 2.3 "Deprecate use of pattern in import/export lists", the
`pattern` namespace specifier is now deprecated.
Test cases: T25900 T25900_noext
- - - - -
e650ec3e by Ben Gamari at 2025-05-23T03:42:46-04:00
base: Forward port changelog language from 9.12
- - - - -
94cd9ca4 by Ben Gamari at 2025-05-23T03:42:46-04:00
base: Fix RestructuredText-isms in changelog
- - - - -
7722232c by Ben Gamari at 2025-05-23T03:42:46-04:00
base: Note strictness changes made in 4.16.0.0
Addresses #25886.
- - - - -
3f4b823c by Ben Gamari at 2025-05-23T03:43:28-04:00
rts/linker: Factor out ProddableBlocks machinery
- - - - -
6e23fef2 by Ben Gamari at 2025-05-23T03:43:28-04:00
rts/linker: Improve efficiency of proddable blocks structure
Previously the linker's "proddable blocks" check relied on a simple
linked list of spans. This resulted in extremely poor complexity while
linking objects with lots of small sections (e.g. objects built with
split sections).
Rework the mechanism to instead use a simple interval set implemented
via binary search.
Fixes #26009.
- - - - -
ea74860c by Ben Gamari at 2025-05-23T03:43:28-04:00
testsuite: Add simple functional test for ProddableBlockSet
- - - - -
74c4db46 by Ben Gamari at 2025-05-23T03:43:28-04:00
rts/linker/PEi386: Drop check for LOAD_LIBRARY_SEARCH_*_DIRS
The `LOAD_LIBRARY_SEARCH_USER_DIRS` and
`LOAD_LIBRARY_SEARCH_DEFAULT_DIRS` were introduced in Windows Vista and
have been available every since. As we no longer support Windows XP we
can drop this check.
Addresses #26009.
- - - - -
972d81d6 by Ben Gamari at 2025-05-23T03:43:28-04:00
rts/linker/PEi386: Clean up code style
- - - - -
8a1073a5 by Ben Gamari at 2025-05-23T03:43:28-04:00
rts/Hash: Factor out hashBuffer
This is a useful helper which can be used for non-strings as well.
- - - - -
44f509f2 by Ben Gamari at 2025-05-23T03:43:28-04:00
rts/linker/PEi386: Fix incorrect use of break in nested for
Previously the happy path of PEi386 used `break` in a double-`for` loop
resulting in redundant calls to `LoadLibraryEx`.
Fixes #26052.
- - - - -
bfb12783 by Ben Gamari at 2025-05-23T03:43:28-04:00
rts: Correctly mark const arguments
- - - - -
08469ff8 by Ben Gamari at 2025-05-23T03:43:28-04:00
rts/linker/PEi386: Don't repeatedly load DLLs
Previously every DLL-imported symbol would result in a call to
`LoadLibraryEx`. This ended up constituting over 40% of the runtime of
`ghc --interactive -e 42` on Windows. Avoid this by maintaining a
hash-set of loaded DLL names, skipping the call if we have already
loaded the requested DLL.
Addresses #26009.
- - - - -
823d1ccf by Ben Gamari at 2025-05-23T03:43:28-04:00
rts/linker: Expand comment describing ProddableBlockSet
- - - - -
e9de9e0b by Sylvain Henry at 2025-05-23T15:12:34-04:00
Remove emptyModBreaks
Remove emptyModBreaks and track the absence of ModBreaks with `Maybe
ModBreaks`. It avoids testing for null pointers...
- - - - -
17db44c5 by Ben Gamari at 2025-05-23T15:13:16-04:00
base: Expose Backtraces constructor and fields
This was specified in the proposal (CLC #199) yet somehow didn't make it
into the implementation.
Fixes #26049.
- - - - -
b08c08ae by soulomoon at 2025-05-28T01:57:23+08:00
Refactor handling of imported COMPLETE pragmas
from the HPT
Previously, we imported COMPLETE pragmas from all modules in the Home
Package Table (HPT) during type checking. However, since !13675, there
may be non-below modules in the HPT from the dependency tree that we do
not want to import COMPLETE pragmas from. This refactor changes the way
we handle COMPLETE pragmas from the HPT to only import them from modules
that are "below" the current module in the HPT.
- Add hugCompleteSigsBelow to filter COMPLETE pragmas from "below"
modules in the HPT, mirroring hugRulesBelow.
- Move responsibility for calling hugCompleteSigsBelow to tcRnImports,
storing the result in the new tcg_complete_match_env field of TcGblEnv.
- Update getCompleteMatchesTcM to use tcg_complete_match_env.
This refactor only affects how COMPLETE pragmas are imported from the
HPT, imports from external packages are unchanged.
- - - - -
16014bf8 by Hécate Kleidukos at 2025-05-28T20:09:34-04:00
Expose all of Backtraces' internals for ghc-internal
Closes #26049
- - - - -
a0adc30d by Ryan Hendrickson at 2025-05-30T14:12:52-04:00
haddock: Fix links to type operators
- - - - -
7b64697c by Mario Blažević at 2025-05-30T14:13:41-04:00
Introduce parenBreakableList and use it in ppHsContext
- - - - -
5f213bff by fendor at 2025-06-02T09:16:24+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.
---
Adds testcases for GHCi multiple home units session
* Test truly multiple home unit sessions, testing reload logic and code evaluation.
* Test that GHCi commands such as `:all-types`, `:browse`, etc., work
* Object code reloading for home modules
* GHCi debugger multiple home units session
- - - - -
de603d01 by fendor at 2025-06-02T09:16:24+02:00
Update "loading compiled code" GHCi documentation
To use object code in GHCi, the module needs to be compiled for use in
GHCi. To do that, users need to compile their modules with:
* `-dynamic`
* `-this-unit-id interactive-session`
Otherwise, the interface files will not match.
- - - - -
b255a8ca by Vladislav Zavialov at 2025-06-02T16:00:12-04:00
docs: Fix code example for NoListTuplePuns
Without the fix, the example produces an error:
Test.hs:11:3: error: [GHC-45219]
• Data constructor ‘Tuple’ returns type ‘Tuple2 a b’
instead of an instance of its parent type ‘Tuple a’
• In the definition of data constructor ‘Tuple’
In the data type declaration for ‘Tuple’
Fortunately, a one line change makes it compile.
- - - - -
6558467c by Ryan Hendrickson at 2025-06-06T05:46:58-04:00
haddock: Parse math even after ordinary characters
Fixes a bug where math sections were not recognized if preceded by a
character that isn't special (like space or a markup character).
- - - - -
265d0024 by ARATA Mizuki at 2025-06-06T05:47:48-04:00
AArch64 NCG: Fix sub-word arithmetic right shift
As noted in Note [Signed arithmetic on AArch64], we should zero-extend sub-word values.
Fixes #26061
- - - - -
05e9be18 by Simon Hengel at 2025-06-06T05:48:35-04:00
Allow Unicode in "message" and "hints" with -fdiagnostics-as-json
(fixes #26075)
- - - - -
bfa6b70f by ARATA Mizuki at 2025-06-06T05:49:24-04:00
x86 NCG: Fix code generation of bswap64 on i386
Co-authored-by: sheaf <sam.derbyshire(a)gmail.com>
Fix #25601
- - - - -
35826d8b by Matthew Pickering at 2025-06-08T22:00:41+01:00
Hadrian: Add option to generate .hie files for stage1 libraries
The +hie_files flavour transformer can be enabled to produce hie files
for stage1 libraries. The hie files are produced in the
"extra-compilation-artifacts" folder and copied into the resulting
bindist.
At the moment the hie files are not produced for the release flavour,
they add about 170M to the final bindist.
Towards #16901
- - - - -
e2467dbd by Ryan Hendrickson at 2025-06-09T13:07:05-04:00
Fix various failures to -fprint-unicode-syntax
- - - - -
1d99d3e4 by maralorn at 2025-06-12T03:47:39-04:00
Add necessary flag for js linking
- - - - -
974d5734 by maralorn at 2025-06-12T03:47:39-04:00
Don’t use additional linker flags to detect presence of -fno-pie in configure.ac
This mirrors the behavior of ghc-toolchain
- - - - -
1e9eb118 by Andrew Lelechenko at 2025-06-12T03:48:21-04:00
Add HasCallStack to Control.Monad.Fail.fail
CLC proposal https://github.com/haskell/core-libraries-committee/issues/327
2% compile-time allocations increase in T3064, likely because `fail`
is now marginally more expensive to compile.
Metric Increase:
T3064
- - - - -
6d12060f by meooow25 at 2025-06-12T14:26:07-04:00
Bump containers submodule to 0.8
Also
* Disable -Wunused-imports for containers
* Allow containers-0.8 for in-tree packages
* Bump some submodules so that they allow containers-0.8. These are not
at any particular versions.
* Remove unused deps containers and split from ucd2haskell
* Fix tests affected by the new containers and hpc-bin
- - - - -
537bd233 by Peng Fan at 2025-06-12T14:27:02-04:00
NCG/LA64: Optimize code generation and reduce build-directory size.
1. makeFarBranches: Prioritize fewer instruction sequences.
2. Prefer instructions with immediate numbers to reduce register moves,
e.g. andi,ori,xori,addi.
3. Ppr: Remove unnecessary judgments.
4. genJump: Avoid "ld+jr" as much as possible.
5. BCOND and BCOND1: Implement conditional jumps with two jump ranges,
with limited choice of the shortest.
6. Implement FSQRT, CLT, CTZ.
7. Remove unnecessary code.
- - - - -
34d5b00c by Ben Gamari at 2025-06-12T16:07:37-04:00
compiler: Import AnnotationWrapper from ghc-internal
Since `GHC.Desugar` exported from `base` has been deprecated.
- - - - -
58d5e74f by Ben Gamari at 2025-06-12T16:07:37-04:00
ghc-compact: Eliminate dependency on ghc-prim
- - - - -
aea4c506 by Ben Gamari at 2025-06-12T16:07:37-04:00
ghc-heap: Eliminate dependency on ghc-prim
- - - - -
dc9d62b9 by Ben Gamari at 2025-06-12T16:07:37-04:00
ghc-heap: Drop redundant import
- - - - -
9707fa1e by Ben Gamari at 2025-06-12T16:07:37-04:00
ghc-prim: Bump version to 0.13.1
There are no interface changes from 0.13.0 but the implementation now
lives in `ghc-internal`.
- - - - -
c6353941 by Ben Gamari at 2025-06-12T16:07:38-04:00
template-haskell: Bump version number to 2.24.0.0
- - - - -
10e58285 by Ben Gamari at 2025-06-12T16:07:38-04:00
Bump GHC version number to 9.14
- - - - -
d0d3007e by Ben Gamari at 2025-06-12T16:07:38-04:00
Bump parsec to 3.1.18.0
- - - - -
5971c9b5 by Ben Gamari at 2025-06-12T16:07:38-04:00
unix: Bump to 2.8.7.0
- - - - -
0bd2904f by Ben Gamari at 2025-06-12T16:07:38-04:00
binary: Bump to 0.8.9.3
- - - - -
146be7b9 by Ben Gamari at 2025-06-12T16:07:38-04:00
Win32: Bump to 2.14.2.0
- - - - -
f130260f by Ben Gamari at 2025-06-12T16:07:38-04:00
base: Bump version to 4.22.0
- - - - -
478 changed files:
- compiler/GHC.hs
- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/ByteCode/Asm.hs
- compiler/GHC/ByteCode/InfoTable.hs
- compiler/GHC/ByteCode/Instr.hs
- compiler/GHC/ByteCode/Linker.hs
- compiler/GHC/ByteCode/Types.hs
- compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
- compiler/GHC/CmmToAsm/LA64.hs
- compiler/GHC/CmmToAsm/LA64/CodeGen.hs
- compiler/GHC/CmmToAsm/LA64/Instr.hs
- compiler/GHC/CmmToAsm/LA64/Ppr.hs
- compiler/GHC/CmmToAsm/X86/CodeGen.hs
- compiler/GHC/Core/Coercion.hs
- compiler/GHC/Core/Opt/Specialise.hs
- compiler/GHC/Core/Predicate.hs
- compiler/GHC/Core/TyCo/Rep.hs
- compiler/GHC/Core/TyCo/Tidy.hs
- compiler/GHC/Driver/Downsweep.hs
- compiler/GHC/Driver/Env.hs
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Hs/Binds.hs
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/ImpExp.hs
- compiler/GHC/HsToCore/Breakpoints.hs
- compiler/GHC/HsToCore/Monad.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Iface/Type.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Errors/Ppr.hs
- compiler/GHC/Parser/Errors/Types.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Rename/Bind.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Rename/Unbound.hs
- compiler/GHC/Runtime/Context.hs
- compiler/GHC/Runtime/Debugger/Breakpoints.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/Runtime/Interpreter.hs
- compiler/GHC/StgToByteCode.hs
- compiler/GHC/StgToJS/Linker/Linker.hs
- compiler/GHC/SysTools/Cpp.hs
- compiler/GHC/Tc/Errors.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Export.hs
- compiler/GHC/Tc/Gen/HsType.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/Plugin.hs
- compiler/GHC/Tc/Solver.hs
- compiler/GHC/Tc/Solver/Default.hs
- compiler/GHC/Tc/Solver/Equality.hs
- compiler/GHC/Tc/Solver/InertSet.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Types.hs
- compiler/GHC/Tc/Types/Constraint.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Tc/Utils/TcMType.hs
- compiler/GHC/Tc/Utils/Unify.hs
- compiler/GHC/Tc/Zonk/TcType.hs
- compiler/GHC/Types/Error.hs
- compiler/GHC/Types/Error/Codes.hs
- compiler/GHC/Types/Hint.hs
- compiler/GHC/Types/Hint/Ppr.hs
- compiler/GHC/Types/Name/Ppr.hs
- compiler/GHC/Types/Unique.hs
- compiler/GHC/Unit/Env.hs
- compiler/GHC/Unit/Home/Graph.hs
- compiler/GHC/Unit/Types.hs
- compiler/Language/Haskell/Syntax/Extension.hs
- compiler/Language/Haskell/Syntax/ImpExp.hs
- compiler/ghc.cabal.in
- configure.ac
- docs/users_guide/9.14.1-notes.rst
- docs/users_guide/exts/data_kinds.rst
- docs/users_guide/exts/explicit_namespaces.rst
- docs/users_guide/exts/pattern_synonyms.rst
- docs/users_guide/ghci.rst
- docs/users_guide/using-warnings.rst
- ghc/GHCi/UI.hs
- ghc/GHCi/UI/Exception.hs
- ghc/GHCi/UI/Info.hs
- ghc/GHCi/UI/Monad.hs
- ghc/Main.hs
- ghc/ghc-bin.cabal.in
- hadrian/doc/flavours.md
- hadrian/doc/user-settings.md
- hadrian/hadrian.cabal
- hadrian/src/Context.hs
- hadrian/src/Context/Path.hs
- hadrian/src/Flavour.hs
- hadrian/src/Flavour/Type.hs
- hadrian/src/Oracles/Flag.hs
- hadrian/src/Settings/Builders/Ghc.hs
- hadrian/src/Settings/Default.hs
- hadrian/src/Settings/Flavours/Release.hs
- hadrian/src/Settings/Warnings.hs
- libraries/Win32
- libraries/array
- libraries/base/base.cabal.in
- libraries/base/changelog.md
- libraries/base/src/Control/Exception/Backtrace.hs
- libraries/base/tests/IO/withBinaryFile002.stderr
- libraries/base/tests/IO/withFile002.stderr
- libraries/base/tests/IO/withFileBlocking002.stderr
- libraries/binary
- libraries/containers
- libraries/deepseq
- libraries/directory
- libraries/exceptions
- libraries/filepath
- libraries/ghc-boot-th/ghc-boot-th.cabal.in
- libraries/ghc-boot/ghc-boot.cabal.in
- libraries/ghc-compact/GHC/Compact.hs
- libraries/ghc-compact/GHC/Compact/Serialized.hs
- libraries/ghc-compact/ghc-compact.cabal
- libraries/ghc-experimental/ghc-experimental.cabal.in
- libraries/ghc-heap/GHC/Exts/Heap/Utils.hsc
- libraries/ghc-heap/ghc-heap.cabal.in
- libraries/ghc-internal/src/GHC/Internal/Bignum/Integer.hs
- libraries/ghc-internal/src/GHC/Internal/Control/Monad/Fail.hs
- libraries/ghc-internal/src/GHC/Internal/Data/Maybe.hs
- libraries/ghc-internal/src/GHC/Internal/Data/Typeable/Internal.hs
- libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs
- libraries/ghc-internal/src/GHC/Internal/Exception/Type.hs-boot
- libraries/ghc-internal/src/GHC/Internal/IO.hs-boot
- libraries/ghc-internal/src/GHC/Internal/IO/Exception.hs-boot
- libraries/ghc-internal/src/GHC/Internal/Type/Reflection.hs
- libraries/ghc-internal/src/GHC/Internal/TypeLits.hs
- libraries/ghc-internal/src/GHC/Internal/TypeNats.hs
- libraries/ghc-internal/tools/ucd2haskell/ucd2haskell.cabal
- libraries/ghc-prim/changelog.md
- libraries/ghc-prim/ghc-prim.cabal
- libraries/ghci/GHCi/Message.hs
- libraries/ghci/GHCi/Run.hs
- libraries/ghci/ghci.cabal.in
- libraries/haskeline
- libraries/hpc
- libraries/os-string
- libraries/parsec
- libraries/process
- libraries/semaphore-compat
- libraries/stm
- libraries/template-haskell/template-haskell.cabal.in
- libraries/terminfo
- libraries/text
- libraries/unix
- m4/fp_gcc_supports_no_pie.m4
- m4/fptools_set_c_ld_flags.m4
- rts/Disassembler.c
- rts/Hash.c
- rts/Hash.h
- rts/Interpreter.c
- rts/Linker.c
- rts/LinkerInternals.h
- rts/PathUtils.c
- rts/PathUtils.h
- rts/PrimOps.cmm
- rts/include/rts/Bytecodes.h
- rts/include/rts/storage/Closures.h
- rts/linker/Elf.c
- rts/linker/MachO.c
- rts/linker/PEi386.c
- rts/linker/PEi386.h
- + rts/linker/ProddableBlocks.c
- + rts/linker/ProddableBlocks.h
- rts/rts.cabal
- rts/sm/Storage.h
- testsuite/driver/testlib.py
- testsuite/tests/bytecode/T22376/all.T
- testsuite/tests/callarity/unittest/CallArity1.hs
- + testsuite/tests/cmm/should_run/T25601.hs
- + testsuite/tests/cmm/should_run/T25601.stdout
- + testsuite/tests/cmm/should_run/T25601a.cmm
- testsuite/tests/cmm/should_run/all.T
- + testsuite/tests/codeGen/should_run/T26061.hs
- + testsuite/tests/codeGen/should_run/T26061.stdout
- testsuite/tests/codeGen/should_run/all.T
- testsuite/tests/deSugar/should_run/DsDoExprFailMsg.stderr
- testsuite/tests/deSugar/should_run/DsMonadCompFailMsg.stderr
- testsuite/tests/dependent/should_fail/T11471.stderr
- testsuite/tests/diagnostic-codes/codes.stdout
- testsuite/tests/driver/Makefile
- testsuite/tests/driver/T8526/T8526.stdout
- testsuite/tests/driver/all.T
- testsuite/tests/driver/fat-iface/fat014.stdout
- testsuite/tests/driver/json.stderr
- testsuite/tests/driver/json_warn.stderr
- testsuite/tests/driver/multipleHomeUnits/multiGHCi.stderr
- testsuite/tests/ffi/should_run/all.T
- 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/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/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/prog020/A.hs
- + testsuite/tests/ghci/prog020/B.hs
- + testsuite/tests/ghci/prog020/Makefile
- + testsuite/tests/ghci/prog020/all.T
- + testsuite/tests/ghci/prog020/ghci.prog020.script
- + testsuite/tests/ghci/prog020/ghci.prog020.stderr
- + testsuite/tests/ghci/prog020/ghci.prog020.stdout
- testsuite/tests/ghci/scripts/T12550.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/T8959b.stderr
- testsuite/tests/ghci/scripts/all.T
- testsuite/tests/ghci/scripts/ghci024.stdout
- testsuite/tests/ghci/scripts/ghci024.stdout-mingw32
- testsuite/tests/ghci/scripts/ghci058.script
- + testsuite/tests/ghci/scripts/print-unicode-syntax.script
- + testsuite/tests/ghci/scripts/print-unicode-syntax.stderr
- + testsuite/tests/ghci/scripts/print-unicode-syntax.stdout
- testsuite/tests/ghci/should_run/T11825.stdout
- testsuite/tests/ghci/should_run/TopEnvIface.stdout
- testsuite/tests/hpc/fork/hpc_fork.stdout
- testsuite/tests/hpc/function/tough.stdout
- testsuite/tests/hpc/function2/tough2.stdout
- testsuite/tests/hpc/simple/hpc001.stdout
- testsuite/tests/indexed-types/should_fail/T8227.stderr
- testsuite/tests/indexed-types/should_fail/T9662.stderr
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/interface-stability/base-exports.stdout-ws-32
- + testsuite/tests/lib/integer/T26017.hs
- + testsuite/tests/lib/integer/T26017.stdout
- testsuite/tests/lib/integer/all.T
- testsuite/tests/lib/integer/integerRecipMod.hs
- testsuite/tests/lib/integer/integerRecipMod.stdout
- testsuite/tests/module/T21826.stderr
- testsuite/tests/numeric/should_run/all.T
- testsuite/tests/numeric/should_run/foundation.hs
- testsuite/tests/numeric/should_run/foundation.stdout
- + testsuite/tests/parser/should_compile/T25900.hs
- + testsuite/tests/parser/should_compile/T25900.stderr
- + testsuite/tests/parser/should_compile/T25900_noext.hs
- + testsuite/tests/parser/should_compile/T25900_noext.stderr
- testsuite/tests/parser/should_compile/all.T
- testsuite/tests/partial-sigs/should_fail/T10999.stderr
- testsuite/tests/partial-sigs/should_fail/T14040a.stderr
- testsuite/tests/partial-sigs/should_fail/T14584.stderr
- testsuite/tests/patsyn/should_compile/ImpExp_Exp.hs
- testsuite/tests/patsyn/should_compile/T11959.hs
- testsuite/tests/patsyn/should_compile/T11959.stderr
- testsuite/tests/patsyn/should_compile/T11959Lib.hs
- testsuite/tests/patsyn/should_compile/T13350/boolean/Boolean.hs
- testsuite/tests/patsyn/should_compile/T22521.hs
- testsuite/tests/patsyn/should_compile/T9857.hs
- testsuite/tests/patsyn/should_compile/export.hs
- testsuite/tests/perf/should_run/ByteCodeAsm.hs
- testsuite/tests/pmcheck/complete_sigs/T25115a.hs
- testsuite/tests/pmcheck/should_compile/T11822.hs
- testsuite/tests/polykinds/T14172.stderr
- testsuite/tests/polykinds/T14270.hs
- testsuite/tests/polykinds/T14846.stderr
- testsuite/tests/quasiquotation/T7918.hs
- testsuite/tests/rebindable/DoRestrictedM.hs
- testsuite/tests/rename/should_compile/T12548.hs
- testsuite/tests/rename/should_compile/T22581d.stdout
- + testsuite/tests/rename/should_compile/T25899a.hs
- + testsuite/tests/rename/should_compile/T25899b.hs
- + testsuite/tests/rename/should_compile/T25899c.hs
- + testsuite/tests/rename/should_compile/T25899c_helper.hs
- + testsuite/tests/rename/should_compile/T25899d.script
- + testsuite/tests/rename/should_compile/T25899d.stdout
- testsuite/tests/rename/should_compile/all.T
- testsuite/tests/rename/should_fail/T22581a.stderr
- testsuite/tests/rename/should_fail/T22581b.stderr
- testsuite/tests/rename/should_fail/T25056.stderr
- testsuite/tests/rename/should_fail/T25056a.hs
- + testsuite/tests/rename/should_fail/T25899e1.hs
- + testsuite/tests/rename/should_fail/T25899e1.stderr
- + testsuite/tests/rename/should_fail/T25899e2.hs
- + testsuite/tests/rename/should_fail/T25899e2.stderr
- + testsuite/tests/rename/should_fail/T25899e3.hs
- + testsuite/tests/rename/should_fail/T25899e3.stderr
- + testsuite/tests/rename/should_fail/T25899e_helper.hs
- + testsuite/tests/rename/should_fail/T25899f.hs
- + testsuite/tests/rename/should_fail/T25899f.stderr
- + testsuite/tests/rename/should_fail/T25899f_helper.hs
- testsuite/tests/rename/should_fail/all.T
- testsuite/tests/rep-poly/RepPolyArgument.stderr
- testsuite/tests/rep-poly/RepPolyBackpack1.stderr
- testsuite/tests/rep-poly/RepPolyBinder.stderr
- testsuite/tests/rep-poly/RepPolyDoBind.stderr
- testsuite/tests/rep-poly/RepPolyDoBody1.stderr
- testsuite/tests/rep-poly/RepPolyDoBody2.stderr
- testsuite/tests/rep-poly/RepPolyLeftSection2.stderr
- testsuite/tests/rep-poly/RepPolyMagic.stderr
- testsuite/tests/rep-poly/RepPolyMcBind.stderr
- testsuite/tests/rep-poly/RepPolyMcBody.stderr
- testsuite/tests/rep-poly/RepPolyMcGuard.stderr
- testsuite/tests/rep-poly/RepPolyNPlusK.stderr
- testsuite/tests/rep-poly/RepPolyPatBind.stderr
- testsuite/tests/rep-poly/RepPolyRecordUpdate.stderr
- testsuite/tests/rep-poly/RepPolyRightSection.stderr
- testsuite/tests/rep-poly/RepPolyRule1.stderr
- testsuite/tests/rep-poly/RepPolyTuple.stderr
- testsuite/tests/rep-poly/RepPolyTuple4.stderr
- testsuite/tests/rep-poly/RepPolyTupleSection.stderr
- testsuite/tests/rep-poly/RepPolyWrappedVar.stderr
- testsuite/tests/rep-poly/T11473.stderr
- testsuite/tests/rep-poly/T12709.stderr
- testsuite/tests/rep-poly/T12973.stderr
- testsuite/tests/rep-poly/T13233.stderr
- testsuite/tests/rep-poly/T13929.stderr
- testsuite/tests/rep-poly/T14561.stderr
- testsuite/tests/rep-poly/T14561b.stderr
- testsuite/tests/rep-poly/T17817.stderr
- testsuite/tests/rep-poly/T19615.stderr
- testsuite/tests/rep-poly/T19709b.stderr
- testsuite/tests/rep-poly/T21906.stderr
- testsuite/tests/rep-poly/T23903.stderr
- testsuite/tests/rep-poly/UnliftedNewtypesCoerceFail.stderr
- + testsuite/tests/rts/TestProddableBlockSet.c
- testsuite/tests/rts/all.T
- testsuite/tests/simplCore/should_compile/T15186.hs
- testsuite/tests/simplCore/should_compile/T15186A.hs
- testsuite/tests/simplCore/should_compile/simpl017.stderr
- testsuite/tests/th/T15321.stderr
- testsuite/tests/typecheck/no_skolem_info/T14040.stderr
- testsuite/tests/typecheck/should_compile/T25266a.stderr
- + testsuite/tests/typecheck/should_compile/T26030.hs
- testsuite/tests/typecheck/should_compile/TypeRepCon.hs
- testsuite/tests/typecheck/should_compile/all.T
- testsuite/tests/typecheck/should_compile/subsumption_sort_hole_fits.stderr
- testsuite/tests/typecheck/should_compile/valid_hole_fits.stderr
- testsuite/tests/typecheck/should_fail/T16204c.stderr
- + testsuite/tests/typecheck/should_fail/T25950.hs
- + testsuite/tests/typecheck/should_fail/T25950.stderr
- testsuite/tests/typecheck/should_fail/T7696.stderr
- testsuite/tests/typecheck/should_fail/T8603.stderr
- testsuite/tests/typecheck/should_fail/all.T
- testsuite/tests/warnings/should_compile/DataToTagWarnings.hs
- testsuite/tests/warnings/should_compile/T14794a.hs
- testsuite/tests/warnings/should_compile/T14794a.stderr
- testsuite/tests/warnings/should_compile/T14794b.hs
- testsuite/tests/warnings/should_compile/T14794b.stderr
- testsuite/tests/warnings/should_compile/T14794c.hs
- testsuite/tests/warnings/should_compile/T14794c.stderr
- testsuite/tests/warnings/should_compile/T14794d.hs
- testsuite/tests/warnings/should_compile/T14794d.stderr
- testsuite/tests/warnings/should_compile/T14794e.hs
- testsuite/tests/warnings/should_compile/T14794e.stderr
- testsuite/tests/warnings/should_compile/T14794f.hs
- testsuite/tests/warnings/should_compile/T14794f.stderr
- testsuite/tests/wcompat-warnings/Template.hs
- + testsuite/tests/wcompat-warnings/WCompatWarningsOn.stderr
- utils/check-exact/ExactPrint.hs
- utils/genprimopcode/Main.hs
- utils/genprimopcode/Syntax.hs
- utils/ghc-toolchain/src/GHC/Toolchain/Tools/Link.hs
- utils/haddock/haddock-api/haddock-api.cabal
- utils/haddock/haddock-api/resources/html/Linuwial.std-theme/linuwial.css
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
- utils/haddock/haddock-api/src/Haddock/Interface/LexParseRn.hs
- utils/haddock/haddock-api/src/Haddock/InterfaceFile.hs
- utils/haddock/haddock-library/haddock-library.cabal
- utils/haddock/haddock-library/src/Documentation/Haddock/Parser.hs
- utils/haddock/haddock-library/test/Documentation/Haddock/ParserSpec.hs
- utils/haddock/haddock-test/haddock-test.cabal
- utils/haddock/haddock.cabal
- utils/haddock/html-test/ref/Bug1004.html
- utils/haddock/html-test/ref/Bug548.html
- utils/haddock/html-test/ref/Bug973.html
- utils/haddock/html-test/ref/Hash.html
- utils/haddock/html-test/ref/ImplicitParams.html
- utils/haddock/html-test/ref/Instances.html
- utils/haddock/html-test/ref/PatternSyns.html
- utils/haddock/html-test/ref/TypeOperators.html
- utils/haddock/html-test/src/TypeOperators.hs
- utils/haddock/hypsrc-test/ref/src/Quasiquoter.html
- utils/hpc
- utils/hsc2hs
- utils/iserv/iserv.cabal.in
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/77b4d1bee886da2b1e1ae990b1c0c5…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/77b4d1bee886da2b1e1ae990b1c0c5…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] NCG/LA64: Optimize code generation and reduce build-directory size.
by Marge Bot (＠marge-bot) 12 Jun '25
by Marge Bot (＠marge-bot) 12 Jun '25
12 Jun '25
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
537bd233 by Peng Fan at 2025-06-12T14:27:02-04:00
NCG/LA64: Optimize code generation and reduce build-directory size.
1. makeFarBranches: Prioritize fewer instruction sequences.
2. Prefer instructions with immediate numbers to reduce register moves,
e.g. andi,ori,xori,addi.
3. Ppr: Remove unnecessary judgments.
4. genJump: Avoid "ld+jr" as much as possible.
5. BCOND and BCOND1: Implement conditional jumps with two jump ranges,
with limited choice of the shortest.
6. Implement FSQRT, CLT, CTZ.
7. Remove unnecessary code.
- - - - -
4 changed files:
- compiler/GHC/CmmToAsm/LA64.hs
- compiler/GHC/CmmToAsm/LA64/CodeGen.hs
- compiler/GHC/CmmToAsm/LA64/Instr.hs
- compiler/GHC/CmmToAsm/LA64/Ppr.hs
Changes:
=====================================
compiler/GHC/CmmToAsm/LA64.hs
=====================================
@@ -32,7 +32,7 @@ ncgLA64 config =
maxSpillSlots = LA64.maxSpillSlots config,
allocatableRegs = LA64.allocatableRegs platform,
ncgAllocMoreStack = LA64.allocMoreStack platform,
- ncgMakeFarBranches = \_p _i bs -> pure bs,
+ ncgMakeFarBranches = LA64.makeFarBranches,
extractUnwindPoints = const [],
invertCondBranches = \_ _ -> id
}
=====================================
compiler/GHC/CmmToAsm/LA64/CodeGen.hs
=====================================
@@ -6,6 +6,7 @@
module GHC.CmmToAsm.LA64.CodeGen (
cmmTopCodeGen
, generateJumpTableForInstr
+ , makeFarBranches
)
where
@@ -31,7 +32,7 @@ import GHC.CmmToAsm.Monad
getNewLabelNat,
getNewRegNat,
getPicBaseMaybeNat,
- getPlatform,
+ getPlatform
)
import GHC.CmmToAsm.PIC
import GHC.CmmToAsm.LA64.Cond
@@ -53,10 +54,10 @@ import GHC.Utils.Constants (debugIsOn)
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
-import GHC.Cmm.Dataflow.Label()
import GHC.Utils.Monad
import Control.Monad
-import GHC.Types.Unique.DSM()
+import GHC.Cmm.Dataflow.Label
+import GHC.Types.Unique.DSM
-- [General layout of an NCG]
cmmTopCodeGen ::
@@ -449,14 +450,6 @@ getRegister e = do
getRegister' :: NCGConfig -> Platform -> CmmExpr -> NatM Register
-- OPTIMIZATION WARNING: CmmExpr rewrites
--- Maybe we can do more?
--- 1. Rewrite: Reg + (-i) => Reg - i
-getRegister' config plat (CmmMachOp (MO_Add w0) [x, CmmLit (CmmInt i w1)]) | i < 0
- = getRegister' config plat (CmmMachOp (MO_Sub w0) [x, CmmLit (CmmInt (-i) w1)])
-
--- 2. Rewrite: Reg - (-i) => Reg + i
-getRegister' config plat (CmmMachOp (MO_Sub w0) [x, CmmLit (CmmInt i w1)]) | i < 0
- = getRegister' config plat (CmmMachOp (MO_Add w0) [x, CmmLit (CmmInt (-i) w1)])
-- Generic case.
getRegister' config plat expr =
@@ -616,20 +609,38 @@ getRegister' config plat expr =
x -> pprPanic ("getRegister' (monadic CmmMachOp): " ++ show x) (pdoc plat expr)
where
-- In the case of 32- or 16- or 8-bit values we need to sign-extend to 64-bits
- negate code w reg = do
+ negate code w reg
+ | w `elem` [W8, W16] = do
return $ Any (intFormat w) $ \dst ->
- code `appOL`
- signExtend w W64 reg reg `snocOL`
+ code `snocOL`
+ EXT (OpReg W64 reg) (OpReg w reg) `snocOL`
NEG (OpReg W64 dst) (OpReg W64 reg) `appOL`
truncateReg W64 w dst
+ | otherwise = do
+ return $ Any (intFormat w) $ \dst ->
+ code `snocOL`
+ NEG (OpReg W64 dst) (OpReg w reg)
- ss_conv from to reg code =
+ ss_conv from to reg code
+ | from `elem` [W8, W16] || to `elem` [W8, W16] = do
return $ Any (intFormat to) $ \dst ->
- code `appOL`
- signExtend from W64 reg dst `appOL`
+ code `snocOL`
+ EXT (OpReg W64 dst) (OpReg (min from to) reg) `appOL`
-- At this point an 8- or 16-bit value would be sign-extended
-- to 64-bits. Truncate back down the final width.
truncateReg W64 to dst
+ | from == W32 && to == W64 = do
+ return $ Any (intFormat to) $ \dst ->
+ code `snocOL`
+ SLL (OpReg to dst) (OpReg from reg) (OpImm (ImmInt 0))
+ | from == to = do
+ return $ Any (intFormat from) $ \dst ->
+ code `snocOL` MOV (OpReg from dst) (OpReg from reg)
+ | otherwise = do
+ return $ Any (intFormat to) $ \dst ->
+ code `appOL`
+ signExtend from W64 reg dst `appOL`
+ truncateReg W64 to dst
-- Dyadic machops:
@@ -646,337 +657,532 @@ getRegister' config plat expr =
CmmMachOp (MO_Add _) [expr'@(CmmReg (CmmGlobal _r)), CmmLit (CmmInt 0 _)] -> getRegister' config plat expr'
CmmMachOp (MO_Sub _) [expr'@(CmmReg (CmmGlobal _r)), CmmLit (CmmInt 0 _)] -> getRegister' config plat expr'
- CmmMachOp (MO_Add w) [x, CmmLit (CmmInt n _)]
- | w `elem` [W8, W16, W32]
- , fitsInNbits 12 (fromIntegral n) -> do
- (reg_x, format_x, code_x) <- getSomeReg x
- return $ Any (intFormat w) ( \dst ->
- code_x `appOL`
- signExtend (formatToWidth format_x) W64 reg_x reg_x `snocOL`
- annExpr expr (ADD (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInt (fromIntegral n) ))) `appOL`
- truncateReg W64 w dst
- )
-
- CmmMachOp (MO_Sub w) [x, CmmLit (CmmInt n _)]
- | w `elem` [W8, W16, W32]
- , fitsInNbits 12 (fromIntegral n) -> do
- (reg_x, format_x, code_x) <- getSomeReg x
- return $ Any (intFormat w) ( \dst ->
- code_x `appOL`
- signExtend (formatToWidth format_x) W64 reg_x reg_x `snocOL`
- annExpr expr (SUB (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInt (fromIntegral n) ))) `appOL`
- truncateReg W64 w dst
- )
-
- CmmMachOp (MO_Add w) [CmmReg reg, CmmLit (CmmInt n _)]
- | w `elem` [W8, W16, W32]
- , fitsInNbits 12 (fromIntegral n) -> do
- let w' = formatToWidth (cmmTypeFormat (cmmRegType reg))
- r' = getRegisterReg plat reg
- return $ Any (intFormat w) ( \dst ->
- signExtend w' W64 r' r' `snocOL`
- annExpr expr (ADD (OpReg W64 dst) (OpReg w' r') (OpImm (ImmInt (fromIntegral n) ))) `appOL`
- truncateReg W64 w dst
- )
-
- CmmMachOp (MO_Sub w) [CmmReg reg, CmmLit (CmmInt n _)]
- | w `elem` [W8, W16, W32]
- , fitsInNbits 12 (fromIntegral n) -> do
- let w' = formatToWidth (cmmTypeFormat (cmmRegType reg))
- r' = getRegisterReg plat reg
- return $ Any (intFormat w) ( \dst ->
- signExtend w' W64 r' r' `snocOL`
- annExpr expr (SUB (OpReg W64 dst) (OpReg w' r') (OpImm (ImmInt (fromIntegral n) ))) `appOL`
- truncateReg W64 w dst
- )
+ CmmMachOp (MO_Add w) [x, CmmLit (CmmInt n _)] | fitsInNbits 12 (fromIntegral n) -> do
+ if w `elem` [W8, W16]
+ then do
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ return $ Any (intFormat w) (\dst ->
+ code_x `snocOL`
+ annExpr expr (EXT (OpReg W64 reg_x) (OpReg w reg_x)) `snocOL`
+ ADD (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n))
+ )
+ else do
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (ADD (OpReg W64 dst) (OpReg w reg_x) (OpImm (ImmInteger n))))
+
+ CmmMachOp (MO_Sub w) [x, CmmLit (CmmInt n _)] | fitsInNbits 12 (fromIntegral n) -> do
+ if w `elem` [W8, W16]
+ then do
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ return $ Any (intFormat w) (\dst ->
+ code_x `snocOL`
+ annExpr expr (EXT (OpReg W64 reg_x) (OpReg w reg_x)) `snocOL`
+ SUB (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n))
+ )
+ else do
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (SUB (OpReg W64 dst) (OpReg w reg_x) (OpImm (ImmInteger n))))
CmmMachOp (MO_U_Quot w) [x, y]
- | w `elem` [W8, W16, W32] -> do
- (reg_x, format_x, code_x) <- getSomeReg x
- (reg_y, format_y, code_y) <- getSomeReg y
- return $ Any (intFormat w) ( \dst ->
- code_x `appOL`
- truncateReg (formatToWidth format_x) W64 reg_x `appOL`
- code_y `appOL`
- truncateReg (formatToWidth format_y) W64 reg_y `snocOL`
- annExpr expr (DIVU (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) `appOL`
- truncateReg W64 w dst
- )
+ | w `elem` [W8, W16] -> do
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ (reg_y, _format_y, code_y) <- getSomeReg y
+ return $ Any (intFormat w) (\dst ->
+ code_x `appOL`
+ code_y `appOL`
+ truncateReg w W64 reg_x `appOL`
+ truncateReg w W64 reg_y `snocOL`
+ annExpr expr (DIVU (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))
+ )
-- 2. Shifts.
- CmmMachOp (MO_Shl w) [x, y]
- | w `elem` [W8, W16, W32] -> do
- (reg_x, format_x, code_x) <- getSomeReg x
- (reg_y, format_y, code_y) <- getSomeReg y
- return $ Any (intFormat w) ( \dst ->
- code_x `appOL`
- signExtend (formatToWidth format_x) W64 reg_x reg_x `appOL`
- code_y `appOL`
- signExtend (formatToWidth format_y) W64 reg_y reg_y `snocOL`
- annExpr expr (SLL (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) `appOL`
- truncateReg W64 w dst
- )
-
- CmmMachOp (MO_Shl w) [x, CmmLit (CmmInt n _)]
- | w `elem` [W8, W16, W32]
- , 0 <= n, n < fromIntegral (widthInBits w) -> do
- (reg_x, format_x, code_x) <- getSomeReg x
- return $ Any (intFormat w) ( \dst ->
- code_x `appOL`
- signExtend (formatToWidth format_x) W64 reg_x reg_x `snocOL`
- annExpr expr (SLL (OpReg W64 dst) (OpReg w reg_x) (OpImm (ImmInt (fromIntegral n) ))) `appOL`
- truncateReg W64 w dst
- )
+ CmmMachOp (MO_Shl w) [x, y] ->
+ case y of
+ CmmLit (CmmInt n _) | w `elem` [W8, W16], 0 <= n, n < fromIntegral (widthInBits w) -> do
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ return $ Any (intFormat w) (\dst ->
+ code_x `snocOL`
+ annExpr expr (EXT (OpReg W64 reg_x) (OpReg w reg_x)) `snocOL`
+ SLL (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n))
+ )
+ CmmLit (CmmInt n _) | 0 <= n, n < fromIntegral (widthInBits w) -> do
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (SLL (OpReg W64 dst) (OpReg w reg_x) (OpImm (ImmInteger n))))
+
+ _ | w `elem` [W8, W16] -> do
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ (reg_y, _format_y, code_y) <- getSomeReg y
+ return $ Any (intFormat w) (\dst ->
+ code_x `appOL`
+ code_y `snocOL`
+ annExpr expr (EXT (OpReg W64 reg_x) (OpReg w reg_x)) `snocOL`
+ EXT (OpReg W64 reg_y) (OpReg w reg_y) `snocOL`
+ SLL (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)
+ )
+ _ -> do
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ (reg_y, _format_y, code_y) <- getSomeReg y
+ return $ Any (intFormat w) (\dst ->
+ code_x `appOL`
+ code_y `snocOL`
+ annExpr expr (SLL (OpReg W64 dst) (OpReg w reg_x) (OpReg w reg_y))
+ )
-- MO_S_Shr: signed-shift-right
- CmmMachOp (MO_S_Shr w) [x, y]
- | w `elem` [W8, W16, W32] -> do
- (reg_x, format_x, code_x) <- getSomeReg x
- (reg_y, format_y, code_y) <- getSomeReg y
- return $ Any (intFormat w) ( \dst ->
- code_x `appOL`
- signExtend (formatToWidth format_x) W64 reg_x reg_x `appOL`
- code_y `appOL`
- signExtend (formatToWidth format_y) W64 reg_y reg_y `snocOL`
- annExpr expr (SRA (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) `appOL`
- truncateReg W64 w dst
- )
- CmmMachOp (MO_S_Shr w) [x, CmmLit (CmmInt n _)]
- | w `elem` [W8, W16, W32]
- , fitsInNbits 12 (fromIntegral n) -> do
- (reg_x, format_x, code_x) <- getSomeReg x
- return $ Any (intFormat w) (\dst ->
- code_x `appOL`
- signExtend (formatToWidth format_x) W64 reg_x reg_x `snocOL`
- annExpr expr (SRA (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInt (fromIntegral n) ))) `appOL`
- truncateReg W64 w dst
- )
+ CmmMachOp (MO_S_Shr w) [x, y] ->
+ case y of
+ CmmLit (CmmInt n _) | w `elem` [W8, W16], 0 <= n, n < fromIntegral (widthInBits w) -> do
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ return $ Any (intFormat w) (\dst ->
+ code_x `snocOL`
+ annExpr expr (EXT (OpReg W64 reg_x) (OpReg w reg_x)) `snocOL`
+ SRA (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n))
+ )
+ CmmLit (CmmInt n _) | 0 <= n, n < fromIntegral (widthInBits w) -> do
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (SRA (OpReg W64 dst) (OpReg w reg_x) (OpImm (ImmInteger n))))
+
+ _ | w `elem` [W8, W16] -> do
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ (reg_y, _format_y, code_y) <- getSomeReg y
+ return $ Any (intFormat w) (\dst ->
+ code_x `appOL`
+ code_y `snocOL`
+ annExpr expr (EXT (OpReg W64 reg_x) (OpReg w reg_x)) `snocOL`
+ EXT (OpReg W64 reg_y) (OpReg w reg_y) `snocOL`
+ SRA (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)
+ )
+ _ -> do
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ (reg_y, _format_y, code_y) <- getSomeReg y
+ return $ Any (intFormat w) (\dst ->
+ code_x `appOL`
+ code_y `snocOL`
+ annExpr expr (SRA (OpReg W64 dst) (OpReg w reg_x) (OpReg w reg_y))
+ )
-- MO_U_Shr: unsigned-shift-right
- CmmMachOp (MO_U_Shr w) [x, y]
- | w `elem` [W8, W16, W32] -> do
- (reg_x, format_x, code_x) <- getSomeReg x
- (reg_y, format_y, code_y) <- getSomeReg y
- return $ Any (intFormat w) ( \dst ->
- code_x `appOL`
- truncateReg (formatToWidth format_x) W64 reg_x `appOL`
- code_y `appOL`
- truncateReg (formatToWidth format_y) W64 reg_y `snocOL`
- annExpr expr (SRL (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) `appOL`
- truncateReg W64 w dst
- )
- CmmMachOp (MO_U_Shr w) [x, CmmLit (CmmInt n _)]
- | w `elem` [W8, W16, W32]
- , 0 <= n, n < fromIntegral (widthInBits w) -> do
- (reg_x, format_x, code_x) <- getSomeReg x
- return $ Any (intFormat w) ( \dst ->
- code_x `appOL`
- truncateReg (formatToWidth format_x) W64 reg_x `snocOL`
- annExpr expr (SRL (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInt (fromIntegral n) ))) `appOL`
- truncateReg W64 w dst
- )
+ CmmMachOp (MO_U_Shr w) [x, y] ->
+ case y of
+ CmmLit (CmmInt n _) | w `elem` [W8, W16], 0 <= n, n < fromIntegral (widthInBits w) -> do
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ return $ Any (intFormat w) (\dst ->
+ code_x `appOL`
+ truncateReg w W64 reg_x `snocOL`
+ annExpr expr (SRL (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n)))
+ )
+ CmmLit (CmmInt n _) | 0 <= n, n < fromIntegral (widthInBits w) -> do
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (SRL (OpReg W64 dst) (OpReg w reg_x) (OpImm (ImmInteger n))))
+
+ _ | w `elem` [W8, W16] -> do
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ (reg_y, _format_y, code_y) <- getSomeReg y
+ return $ Any (intFormat w) (\dst ->
+ code_x `appOL`
+ code_y `appOL`
+ truncateReg w W64 reg_x `appOL`
+ truncateReg w W64 reg_y `snocOL`
+ annExpr expr (SRL (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))
+ )
+ _ -> do
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ (reg_y, _format_y, code_y) <- getSomeReg y
+ return $ Any (intFormat w) (\dst ->
+ code_x `appOL`
+ code_y `snocOL`
+ annExpr expr (SRL (OpReg W64 dst) (OpReg w reg_x) (OpReg w reg_y))
+ )
-- 3. Logic &&, ||
-- andi Instr's Imm-operand is zero-extended.
- CmmMachOp (MO_And w) [x, y]
- | w `elem` [W8, W16, W32] -> do
- (reg_x, format_x, code_x) <- getSomeReg x
- (reg_y, format_y, code_y) <- getSomeReg y
- return $ Any (intFormat w) ( \dst ->
- code_x `appOL`
- truncateReg (formatToWidth format_x) W64 reg_x `appOL`
- code_y `appOL`
- truncateReg (formatToWidth format_y) W64 reg_y `snocOL`
- annExpr expr (AND (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) `appOL`
- truncateReg W64 w dst
- )
+ CmmMachOp (MO_And w) [x, y] ->
+ case y of
+ CmmLit (CmmInt n _) | w `elem` [W8, W16, W32], (n :: Integer) >= 0, (n :: Integer) <= 4095 -> do
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ return $ Any (intFormat w) (\dst ->
+ code_x `appOL`
+ truncateReg w W64 reg_x `snocOL`
+ annExpr expr (AND (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n)))
+ )
- CmmMachOp (MO_And w) [x, CmmLit (CmmInt n _)]
- | w `elem` [W8, W16, W32] -> do
- (reg_x, format_x, code_x) <- getSomeReg x
- return $ Any (intFormat w) ( \dst ->
- code_x `appOL`
- truncateReg (formatToWidth format_x) W64 reg_x `snocOL`
- annExpr expr (AND (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInt (fromIntegral n) ))) `appOL`
- truncateReg W64 w dst
- )
+ CmmLit (CmmInt n _) | (n :: Integer) >= 0, (n :: Integer) <= 4095 -> do
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (AND (OpReg W64 dst) (OpReg w reg_x) (OpImm (ImmInteger n))))
+
+ CmmLit (CmmInt n _) | w `elem` [W8, W16, W32] -> do
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ tmp <- getNewRegNat II64
+ return $ Any (intFormat w) (\dst ->
+ code_x `appOL`
+ truncateReg w W64 reg_x `snocOL`
+ annExpr expr (MOV (OpReg W64 tmp) (OpImm (ImmInteger n))) `snocOL`
+ AND (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 tmp)
+ )
- CmmMachOp (MO_Or w) [x, y]
- | w `elem` [W8, W16, W32] -> do
- (reg_x, format_x, code_x) <- getSomeReg x
- (reg_y, format_y, code_y) <- getSomeReg y
- return $ Any (intFormat w) ( \dst ->
- code_x `appOL`
- truncateReg (formatToWidth format_x) W64 reg_x `appOL`
- code_y `appOL`
- truncateReg (formatToWidth format_y) W64 reg_y `snocOL`
- annExpr expr (OR (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) `appOL`
- truncateReg W64 w dst
- )
+ CmmLit (CmmInt n _) -> do
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ tmp <- getNewRegNat II64
+ return $ Any (intFormat w) (\dst ->
+ code_x `snocOL`
+ annExpr expr (MOV (OpReg W64 tmp) (OpImm (ImmInteger n))) `snocOL`
+ AND (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 tmp)
+ )
- CmmMachOp (MO_Or w) [x, CmmLit (CmmInt n _)]
- | w `elem` [W8, W16, W32] -> do
- (reg_x, format_x, code_x) <- getSomeReg x
- return $ Any (intFormat w) ( \dst ->
- code_x `appOL`
- truncateReg (formatToWidth format_x) W64 reg_x `snocOL`
- annExpr expr (OR (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInt (fromIntegral n) ))) `appOL`
- truncateReg W64 w dst
- )
+ _ | w `elem` [W8, W16, W32] -> do
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ (reg_y, _format_y, code_y) <- getSomeReg y
+ return $ Any (intFormat w) (\dst ->
+ code_x `appOL`
+ code_y `appOL`
+ truncateReg w W64 reg_x `appOL`
+ truncateReg w W64 reg_y `snocOL`
+ annExpr expr (AND (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))
+ )
- CmmMachOp (MO_Xor w) [x, y]
- | w `elem` [W8, W16, W32] -> do
- (reg_x, format_x, code_x) <- getSomeReg x
- (reg_y, format_y, code_y) <- getSomeReg y
- return $ Any (intFormat w) ( \dst ->
- code_x `appOL`
- truncateReg (formatToWidth format_x) W64 reg_x `appOL`
- code_y `appOL`
- truncateReg (formatToWidth format_y) W64 reg_y `snocOL`
- annExpr expr (XOR (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) `appOL`
- truncateReg W64 w dst
- )
+ _ -> do
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ (reg_y, _format_y, code_y) <- getSomeReg y
+ return $ Any (intFormat w) (\dst ->
+ code_x `appOL`
+ code_y `snocOL`
+ annExpr expr (AND (OpReg W64 dst) (OpReg w reg_x) (OpReg w reg_y))
+ )
- CmmMachOp (MO_Xor w) [x, CmmLit (CmmInt n _)]
- | w `elem` [W8, W16, W32] -> do
- (reg_x, format_x, code_x) <- getSomeReg x
- return $ Any (intFormat w) ( \dst ->
- code_x `appOL`
- truncateReg (formatToWidth format_x) W64 reg_x `snocOL`
- annExpr expr (XOR (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInt (fromIntegral n) ))) `appOL`
- truncateReg W64 w dst
- )
+ -- ori Instr's Imm-operand is zero-extended.
+ CmmMachOp (MO_Or w) [x, y] ->
+ case y of
+ CmmLit (CmmInt n _) | w `elem` [W8, W16, W32], (n :: Integer) >= 0, (n :: Integer) <= 4095 -> do
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ return $ Any (intFormat w) (\dst ->
+ code_x `appOL`
+ truncateReg w W64 reg_x `snocOL`
+ annExpr expr (OR (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n)))
+ )
+
+ CmmLit (CmmInt n _) | (n :: Integer) >= 0, (n :: Integer) <= 4095 -> do
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (OR (OpReg W64 dst) (OpReg w reg_x) (OpImm (ImmInteger n))))
+
+ CmmLit (CmmInt n _) | w `elem` [W8, W16, W32] -> do
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ tmp <- getNewRegNat II64
+ return $ Any (intFormat w) (\dst ->
+ code_x `appOL`
+ truncateReg w W64 reg_x `snocOL`
+ annExpr expr (MOV (OpReg W64 tmp) (OpImm (ImmInteger n))) `snocOL`
+ OR (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 tmp)
+ )
+
+ CmmLit (CmmInt n _) -> do
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ tmp <- getNewRegNat II64
+ return $ Any (intFormat w) (\dst ->
+ code_x `snocOL`
+ annExpr expr (MOV (OpReg W64 tmp) (OpImm (ImmInteger n))) `snocOL`
+ OR (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 tmp)
+ )
+
+ _ | w `elem` [W8, W16, W32] -> do
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ (reg_y, _format_y, code_y) <- getSomeReg y
+ return $ Any (intFormat w) (\dst ->
+ code_x `appOL`
+ code_y `appOL`
+ truncateReg w W64 reg_x `appOL`
+ truncateReg w W64 reg_y `snocOL`
+ annExpr expr (OR (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))
+ )
+
+ _ -> do
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ (reg_y, _format_y, code_y) <- getSomeReg y
+ return $ Any (intFormat w) (\dst ->
+ code_x `appOL`
+ code_y `snocOL`
+ annExpr expr (OR (OpReg W64 dst) (OpReg w reg_x) (OpReg w reg_y))
+ )
+
+ -- xori Instr's Imm-operand is zero-extended.
+ CmmMachOp (MO_Xor w) [x, y] ->
+ case y of
+ CmmLit (CmmInt n _) | w `elem` [W8, W16, W32], (n :: Integer) >= 0, (n :: Integer) <= 4095 -> do
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ return $ Any (intFormat w) (\dst ->
+ code_x `appOL`
+ truncateReg w W64 reg_x `snocOL`
+ annExpr expr (XOR (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n)))
+ )
+
+ CmmLit (CmmInt n _) | (n :: Integer) >= 0, (n :: Integer) <= 4095 -> do
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (XOR (OpReg W64 dst) (OpReg w reg_x) (OpImm (ImmInteger n))))
+
+ CmmLit (CmmInt n _) | w `elem` [W8, W16, W32] -> do
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ tmp <- getNewRegNat II64
+ return $ Any (intFormat w) (\dst ->
+ code_x `appOL`
+ truncateReg w W64 reg_x `snocOL`
+ annExpr expr (MOV (OpReg W64 tmp) (OpImm (ImmInteger n))) `snocOL`
+ XOR (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 tmp)
+ )
+
+ CmmLit (CmmInt n _) -> do
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ tmp <- getNewRegNat II64
+ return $ Any (intFormat w) (\dst ->
+ code_x `snocOL`
+ annExpr expr (MOV (OpReg W64 tmp) (OpImm (ImmInteger n))) `snocOL`
+ XOR (OpReg W64 dst) (OpReg w reg_x) (OpReg W64 tmp)
+ )
+
+ _ | w `elem` [W8, W16, W32] -> do
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ (reg_y, _format_y, code_y) <- getSomeReg y
+ return $ Any (intFormat w) (\dst ->
+ code_x `appOL`
+ code_y `appOL`
+ truncateReg w W64 reg_x `appOL`
+ truncateReg w W64 reg_y `snocOL`
+ annExpr expr (XOR (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))
+ )
+
+ _ -> do
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ (reg_y, _format_y, code_y) <- getSomeReg y
+ return $ Any (intFormat w) (\dst ->
+ code_x `appOL`
+ code_y `snocOL`
+ annExpr expr (XOR (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))
+ )
-- CSET commands register operand being W64.
CmmMachOp (MO_Eq w) [x, y]
| w `elem` [W8, W16, W32] -> do
- (reg_x, format_x, code_x) <- getSomeReg x
- (reg_y, format_y, code_y) <- getSomeReg y
- return $ Any (intFormat w) ( \dst ->
- code_x `appOL`
- signExtend (formatToWidth format_x) W64 reg_x reg_x `appOL`
- code_y `appOL`
- signExtend (formatToWidth format_y) W64 reg_y reg_y `snocOL`
- annExpr expr (CSET EQ (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) `appOL`
- truncateReg W64 w dst
- )
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ (reg_y, _format_y, code_y) <- getSomeReg y
+ return $ Any (intFormat w) ( \dst ->
+ code_x `appOL`
+ code_y `appOL`
+ signExtend w W64 reg_x reg_x `appOL`
+ signExtend w W64 reg_y reg_y `snocOL`
+ annExpr expr (CSET EQ (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))
+ )
+ | otherwise -> do
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ (reg_y, _format_y, code_y) <- getSomeReg y
+ return $ Any (intFormat w) ( \dst ->
+ code_x `appOL`
+ code_y `snocOL`
+ annExpr expr (CSET EQ (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))
+ )
CmmMachOp (MO_Ne w) [x, y]
| w `elem` [W8, W16, W32] -> do
- (reg_x, format_x, code_x) <- getSomeReg x
- (reg_y, format_y, code_y) <- getSomeReg y
- return $ Any (intFormat w) ( \dst ->
- code_x `appOL`
- signExtend (formatToWidth format_x) W64 reg_x reg_x `appOL`
- code_y `appOL`
- signExtend (formatToWidth format_y) W64 reg_y reg_y `snocOL`
- annExpr expr (CSET NE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) `appOL`
- truncateReg W64 w dst
- )
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ (reg_y, _format_y, code_y) <- getSomeReg y
+ return $ Any (intFormat w) ( \dst ->
+ code_x `appOL`
+ code_y `appOL`
+ signExtend w W64 reg_x reg_x `appOL`
+ signExtend w W64 reg_y reg_y `snocOL`
+ annExpr expr (CSET NE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))
+ )
+ | otherwise -> do
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ (reg_y, _format_y, code_y) <- getSomeReg y
+ return $ Any (intFormat w) ( \dst ->
+ code_x `appOL`
+ code_y `snocOL`
+ annExpr expr (CSET NE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))
+ )
+
+ CmmMachOp (MO_S_Lt w) [x, CmmLit (CmmInt n _)]
+ | w `elem` [W8, W16, W32]
+ , fitsInNbits 12 (fromIntegral n) -> do
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ return $ Any (intFormat w) ( \dst ->
+ code_x `appOL`
+ signExtend w W64 reg_x reg_x `snocOL`
+ annExpr expr (SSLT (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n)))
+ )
+ | fitsInNbits 12 (fromIntegral n) -> do
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ return $ Any (intFormat w) ( \dst -> code_x `snocOL` annExpr expr (SSLT (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n))))
+
+ CmmMachOp (MO_U_Lt w) [x, CmmLit (CmmInt n _)]
+ | w `elem` [W8, W16, W32]
+ , fitsInNbits 12 (fromIntegral n) -> do
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ return $ Any (intFormat w) ( \dst ->
+ code_x `appOL`
+ truncateReg w W64 reg_x `snocOL`
+ annExpr expr (SSLTU (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n)))
+ )
+ | fitsInNbits 12 (fromIntegral n) -> do
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ return $ Any (intFormat w) ( \dst -> code_x `snocOL` annExpr expr (SSLTU (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n))))
CmmMachOp (MO_S_Lt w) [x, y]
| w `elem` [W8, W16, W32] -> do
- (reg_x, format_x, code_x) <- getSomeReg x
- (reg_y, format_y, code_y) <- getSomeReg y
- return $ Any (intFormat w) ( \dst ->
- code_x `appOL`
- signExtend (formatToWidth format_x) W64 reg_x reg_x `appOL`
- code_y `appOL`
- signExtend (formatToWidth format_y) W64 reg_y reg_y `snocOL`
- annExpr expr (CSET SLT (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) `appOL`
- truncateReg W64 w dst
- )
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ (reg_y, _format_y, code_y) <- getSomeReg y
+ return $ Any (intFormat w) ( \dst ->
+ code_x `appOL`
+ code_y `appOL`
+ signExtend w W64 reg_x reg_x `appOL`
+ signExtend w W64 reg_y reg_y `snocOL`
+ annExpr expr (CSET SLT (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))
+ )
+ | otherwise -> do
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ (reg_y, _format_y, code_y) <- getSomeReg y
+ return $ Any (intFormat w) ( \dst ->
+ code_x `appOL`
+ code_y `snocOL`
+ annExpr expr (CSET SLT (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))
+ )
CmmMachOp (MO_S_Le w) [x, y]
| w `elem` [W8, W16, W32] -> do
- (reg_x, format_x, code_x) <- getSomeReg x
- (reg_y, format_y, code_y) <- getSomeReg y
- return $ Any (intFormat w) ( \dst ->
- code_x `appOL`
- signExtend (formatToWidth format_x) W64 reg_x reg_x `appOL`
- code_y `appOL`
- signExtend (formatToWidth format_y) W64 reg_y reg_y `snocOL`
- annExpr expr (CSET SLE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) `appOL`
- truncateReg W64 w dst
- )
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ (reg_y, _format_y, code_y) <- getSomeReg y
+ return $ Any (intFormat w) ( \dst ->
+ code_x `appOL`
+ code_y `appOL`
+ signExtend w W64 reg_x reg_x `appOL`
+ signExtend w W64 reg_y reg_y `snocOL`
+ annExpr expr (CSET SLE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))
+ )
+ | otherwise -> do
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ (reg_y, _format_y, code_y) <- getSomeReg y
+ return $ Any (intFormat w) ( \dst ->
+ code_x `appOL`
+ code_y `snocOL`
+ annExpr expr (CSET SLE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))
+ )
CmmMachOp (MO_S_Ge w) [x, y]
| w `elem` [W8, W16, W32] -> do
- (reg_x, format_x, code_x) <- getSomeReg x
- (reg_y, format_y, code_y) <- getSomeReg y
- return $ Any (intFormat w) ( \dst ->
- code_x `appOL`
- signExtend (formatToWidth format_x) W64 reg_x reg_x `appOL`
- code_y `appOL`
- signExtend (formatToWidth format_y) W64 reg_y reg_y `snocOL`
- annExpr expr (CSET SGE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) `appOL`
- truncateReg W64 w dst
- )
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ (reg_y, _format_y, code_y) <- getSomeReg y
+ return $ Any (intFormat w) ( \dst ->
+ code_x `appOL`
+ code_y `appOL`
+ signExtend w W64 reg_x reg_x `appOL`
+ signExtend w W64 reg_y reg_y `snocOL`
+ annExpr expr (CSET SGE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))
+ )
+ | otherwise -> do
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ (reg_y, _format_y, code_y) <- getSomeReg y
+ return $ Any (intFormat w) ( \dst ->
+ code_x `appOL`
+ code_y `snocOL`
+ annExpr expr (CSET SGE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))
+ )
CmmMachOp (MO_S_Gt w) [x, y]
| w `elem` [W8, W16, W32] -> do
- (reg_x, format_x, code_x) <- getSomeReg x
- (reg_y, format_y, code_y) <- getSomeReg y
- return $ Any (intFormat w) ( \dst ->
- code_x `appOL`
- signExtend (formatToWidth format_x) W64 reg_x reg_x `appOL`
- code_y `appOL`
- signExtend (formatToWidth format_y) W64 reg_y reg_y `snocOL`
- annExpr expr (CSET SGT (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) `appOL`
- truncateReg W64 w dst
- )
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ (reg_y, _format_y, code_y) <- getSomeReg y
+ return $ Any (intFormat w) ( \dst ->
+ code_x `appOL`
+ code_y `appOL`
+ signExtend w W64 reg_x reg_x `appOL`
+ signExtend w W64 reg_y reg_y `snocOL`
+ annExpr expr (CSET SGT (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))
+ )
+ | otherwise -> do
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ (reg_y, _format_y, code_y) <- getSomeReg y
+ return $ Any (intFormat w) ( \dst ->
+ code_x `appOL`
+ code_y `snocOL`
+ annExpr expr (CSET SGT (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))
+ )
CmmMachOp (MO_U_Lt w) [x, y]
| w `elem` [W8, W16, W32] -> do
- (reg_x, format_x, code_x) <- getSomeReg x
- (reg_y, format_y, code_y) <- getSomeReg y
- return $ Any (intFormat w) ( \dst ->
- code_x `appOL`
- truncateReg (formatToWidth format_x) W64 reg_x `appOL`
- code_y `appOL`
- truncateReg (formatToWidth format_y) W64 reg_y `snocOL`
- annExpr expr (CSET ULT (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) `appOL`
- truncateReg W64 w dst
- )
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ (reg_y, _format_y, code_y) <- getSomeReg y
+ return $ Any (intFormat w) ( \dst ->
+ code_x `appOL`
+ code_y `appOL`
+ truncateReg w W64 reg_x `appOL`
+ truncateReg w W64 reg_y `snocOL`
+ annExpr expr (CSET ULT (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))
+ )
+ | otherwise -> do
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ (reg_y, _format_y, code_y) <- getSomeReg y
+ return $ Any (intFormat w) ( \dst ->
+ code_x `appOL`
+ code_y `snocOL`
+ annExpr expr (CSET ULT (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))
+ )
CmmMachOp (MO_U_Le w) [x, y]
| w `elem` [W8, W16, W32] -> do
- (reg_x, format_x, code_x) <- getSomeReg x
- (reg_y, format_y, code_y) <- getSomeReg y
- return $ Any (intFormat w) ( \dst ->
- code_x `appOL`
- truncateReg (formatToWidth format_x) W64 reg_x `appOL`
- code_y `appOL`
- truncateReg (formatToWidth format_y) W64 reg_y `snocOL`
- annExpr expr (CSET ULE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) `appOL`
- truncateReg W64 w dst
- )
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ (reg_y, _format_y, code_y) <- getSomeReg y
+ return $ Any (intFormat w) ( \dst ->
+ code_x `appOL`
+ code_y `appOL`
+ truncateReg w W64 reg_x `appOL`
+ truncateReg w W64 reg_y `snocOL`
+ annExpr expr (CSET ULE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))
+ )
+ | otherwise -> do
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ (reg_y, _format_y, code_y) <- getSomeReg y
+ return $ Any (intFormat w) ( \dst ->
+ code_x `appOL`
+ code_y `snocOL`
+ annExpr expr (CSET ULE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))
+ )
CmmMachOp (MO_U_Ge w) [x, y]
| w `elem` [W8, W16, W32] -> do
- (reg_x, format_x, code_x) <- getSomeReg x
- (reg_y, format_y, code_y) <- getSomeReg y
- return $ Any (intFormat w) ( \dst ->
- code_x `appOL`
- truncateReg (formatToWidth format_x) W64 reg_x `appOL`
- code_y `appOL`
- truncateReg (formatToWidth format_y) W64 reg_y `snocOL`
- annExpr expr (CSET UGE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) `appOL`
- truncateReg W64 w dst
- )
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ (reg_y, _format_y, code_y) <- getSomeReg y
+ return $ Any (intFormat w) ( \dst ->
+ code_x `appOL`
+ code_y `appOL`
+ truncateReg w W64 reg_x `appOL`
+ truncateReg w W64 reg_y `snocOL`
+ annExpr expr (CSET UGE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))
+ )
+ | otherwise -> do
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ (reg_y, _format_y, code_y) <- getSomeReg y
+ return $ Any (intFormat w) ( \dst ->
+ code_x `appOL`
+ code_y `snocOL`
+ annExpr expr (CSET UGE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))
+ )
CmmMachOp (MO_U_Gt w) [x, y]
| w `elem` [W8, W16, W32] -> do
- (reg_x, format_x, code_x) <- getSomeReg x
- (reg_y, format_y, code_y) <- getSomeReg y
- return $ Any (intFormat w) ( \dst ->
- code_x `appOL`
- truncateReg (formatToWidth format_x) W64 reg_x `appOL`
- code_y `appOL`
- truncateReg (formatToWidth format_y) W64 reg_y `snocOL`
- annExpr expr (CSET UGT (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) `appOL`
- truncateReg W64 w dst
- )
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ (reg_y, _format_y, code_y) <- getSomeReg y
+ return $ Any (intFormat w) ( \dst ->
+ code_x `appOL`
+ code_y `appOL`
+ truncateReg w W64 reg_x `appOL`
+ truncateReg w W64 reg_y `snocOL`
+ annExpr expr (CSET UGT (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))
+ )
+ | otherwise -> do
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ (reg_y, _format_y, code_y) <- getSomeReg y
+ return $ Any (intFormat w) ( \dst ->
+ code_x `appOL`
+ code_y `snocOL`
+ annExpr expr (CSET UGT (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))
+ )
-- Generic binary case.
@@ -1044,21 +1250,6 @@ getRegister' config plat expr =
MO_U_Quot w -> intOp False w (\d x y -> annExpr expr (DIVU d x y))
MO_U_Rem w -> intOp False w (\d x y -> annExpr expr (MODU d x y))
- MO_Eq w -> intOp False w (\d x y -> annExpr expr (CSET EQ d x y))
- MO_Ne w -> intOp False w (\d x y -> annExpr expr (CSET NE d x y))
-
- -- Signed comparisons
- MO_S_Ge w -> intOp True w (\d x y -> annExpr expr (CSET SGE d x y))
- MO_S_Le w -> intOp True w (\d x y -> annExpr expr (CSET SLE d x y))
- MO_S_Gt w -> intOp True w (\d x y -> annExpr expr (CSET SGT d x y))
- MO_S_Lt w -> intOp True w (\d x y -> annExpr expr (CSET SLT d x y))
-
- -- Unsigned comparisons
- MO_U_Ge w -> intOp False w (\d x y -> annExpr expr (CSET UGE d x y))
- MO_U_Le w -> intOp False w (\d x y -> annExpr expr (CSET ULE d x y))
- MO_U_Gt w -> intOp False w (\d x y -> annExpr expr (CSET UGT d x y))
- MO_U_Lt w -> intOp False w (\d x y -> annExpr expr (CSET ULT d x y))
-
-- Floating point arithmetic
MO_F_Add w -> floatOp w (\d x y -> unitOL $ annExpr expr (ADD d x y))
MO_F_Sub w -> floatOp w (\d x y -> unitOL $ annExpr expr (SUB d x y))
@@ -1075,15 +1266,6 @@ getRegister' config plat expr =
MO_F_Gt w -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET FGT d x y))
MO_F_Lt w -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET FLT d x y))
- MO_Shl w -> intOp False w (\d x y -> annExpr expr (SLL d x y))
- MO_U_Shr w -> intOp False w (\d x y -> annExpr expr (SRL d x y))
- MO_S_Shr w -> intOp True w (\d x y -> annExpr expr (SRA d x y))
-
- -- Bitwise operations
- MO_And w -> intOp False w (\d x y -> annExpr expr (AND d x y))
- MO_Or w -> intOp False w (\d x y -> annExpr expr (OR d x y))
- MO_Xor w -> intOp False w (\d x y -> annExpr expr (XOR d x y))
-
op -> pprPanic "getRegister' (unhandled dyadic CmmMachOp): " $ pprMachOp op <+> text "in" <+> pdoc plat expr
-- Generic ternary case.
@@ -1148,8 +1330,7 @@ getRegister' config plat expr =
code_y `snocOL`
MULW (OpReg W64 tmp1) (OpReg W64 reg_x) (OpReg W64 reg_y) `snocOL`
ADD (OpReg W64 tmp2) (OpReg W32 tmp1) (OpImm (ImmInt 0)) `snocOL`
- CSET NE (OpReg W64 dst) (OpReg W64 tmp1) (OpReg W64 tmp2) `appOL`
- truncateReg W64 W32 dst
+ CSET NE (OpReg W64 dst) (OpReg W64 tmp1) (OpReg W64 tmp2)
)
-- General case
@@ -1193,8 +1374,7 @@ getRegister' config plat expr =
-- extract valid result via result's width
-- slli.w for W32, otherwise ext.w.[b, h]
extract w tmp2 tmp1 `snocOL`
- CSET NE (OpReg W64 dst) (OpReg W64 tmp1) (OpReg W64 tmp2) `appOL`
- truncateReg W64 w dst
+ CSET NE (OpReg W64 dst) (OpReg W64 tmp1) (OpReg W64 tmp2)
)
-- Should it be happened?
@@ -1210,11 +1390,10 @@ signExtend w w' r r'
| w > w' = pprPanic "Sign-extend Error: not a sign extension, but a truncation." $ ppr w <> text "->" <+> ppr w'
| w > W64 || w' > W64 = pprPanic "Sign-extend Error: from/to register width greater than 64-bit." $ ppr w <> text "->" <+> ppr w'
| w == W64 && w' == W64 && r == r' = nilOL
- | w == W64 && w' == W64 = unitOL $ MOV (OpReg w' r') (OpReg w r)
| w == W32 && w' == W64 = unitOL $ SLL (OpReg W64 r') (OpReg w r) (OpImm (ImmInt 0))
-- Sign-extend W8 and W16 to W64.
| w `elem` [W8, W16] = unitOL $ EXT (OpReg W64 r') (OpReg w r)
- | w == W32 && w' == W32 = unitOL $ MOV (OpReg w' r') (OpReg w r)
+ | w == w' = unitOL $ MOV (OpReg w' r') (OpReg w r)
| otherwise = pprPanic "signExtend: Unexpected width: " $ ppr w <> text "->" <+> ppr w'
-- | Instructions to truncate the value in the given register from width @w@
@@ -1321,12 +1500,19 @@ assignReg_FltCode = assignReg_IntCode
-- Jumps
genJump :: CmmExpr{-the branch target-} -> NatM InstrBlock
--- `b label` may be optimal, but not the right one in some scenarios.
--- genJump expr@(CmmLit (CmmLabel lbl))
--- = return $ unitOL (annExpr expr (J (TLabel lbl)))
genJump expr = do
- (target, _format, code) <- getSomeReg expr
- return (code `appOL` unitOL (annExpr expr (J (TReg target))))
+ case expr of
+ (CmmLit (CmmLabel lbl)) -> do
+ return $ unitOL (annExpr expr (TAIL36 (OpReg W64 tmpReg) (TLabel lbl)))
+ (CmmLit (CmmBlock bid)) -> do
+ return $ unitOL (annExpr expr (TAIL36 (OpReg W64 tmpReg) (TBlock bid)))
+ _ -> do
+ (target, _format, code) <- getSomeReg expr
+ -- I'd like to do more.
+ return $ COMMENT (text "genJump for unknow expr: " <+> (text (show expr))) `consOL`
+ (code `appOL`
+ unitOL (annExpr expr (J (TReg target)))
+ )
-- -----------------------------------------------------------------------------
-- Unconditional branches
@@ -1369,65 +1555,47 @@ genCondJump bid expr = do
-- Generic case.
CmmMachOp mop [x, y] -> do
-
- let ubcond w cmp | w `elem` [W8, W16, W32] = do
+ let ubcond w cmp = do
(reg_x, format_x, code_x) <- getSomeReg x
(reg_y, format_y, code_y) <- getSomeReg y
- reg_t <- getNewRegNat (intFormat W64)
- return $
- code_x `appOL`
- truncateReg (formatToWidth format_x) W64 reg_x `appOL`
- code_y `appOL`
- truncateReg (formatToWidth format_y) W64 reg_y `snocOL`
- MOV (OpReg W64 reg_t) (OpImm (ImmInt 12)) `snocOL`
- BCOND cmp (OpReg W64 reg_x) (OpReg W64 reg_y) (TBlock bid) (OpReg W64 reg_t)
- ubcond _w cmp = do
- (reg_x, _format_x, code_x) <- getSomeReg x
- (reg_y, _format_y, code_y) <- getSomeReg y
- reg_t <- getNewRegNat (intFormat W64)
- return $
- code_x `appOL`
- code_y `snocOL`
- MOV (OpReg W64 reg_t) (OpImm (ImmInt 12)) `snocOL`
- BCOND cmp (OpReg W64 reg_x) (OpReg W64 reg_y) (TBlock bid) (OpReg W64 reg_t)
-
-
- sbcond w cmp | w `elem` [W8, W16, W32] = do
+ return $ case w of
+ w | w `elem` [W8, W16, W32] ->
+ code_x `appOL`
+ truncateReg (formatToWidth format_x) W64 reg_x `appOL`
+ code_y `appOL`
+ truncateReg (formatToWidth format_y) W64 reg_y `snocOL`
+ BCOND1 cmp (OpReg W64 reg_x) (OpReg W64 reg_y) (TBlock bid)
+ _ ->
+ code_x `appOL`
+ code_y `snocOL`
+ BCOND1 cmp (OpReg W64 reg_x) (OpReg W64 reg_y) (TBlock bid)
+
+ sbcond w cmp = do
(reg_x, format_x, code_x) <- getSomeReg x
(reg_y, format_y, code_y) <- getSomeReg y
- reg_t <- getNewRegNat (intFormat W64)
- return $
- code_x `appOL`
- signExtend (formatToWidth format_x) W64 reg_x reg_x `appOL`
- code_y `appOL`
- signExtend (formatToWidth format_y) W64 reg_y reg_y `snocOL`
- MOV (OpReg W64 reg_t) (OpImm (ImmInt 13)) `snocOL`
- BCOND cmp (OpReg W64 reg_x) (OpReg W64 reg_y) (TBlock bid) (OpReg W64 reg_t)
-
- sbcond _w cmp = do
- (reg_x, _format_x, code_x) <- getSomeReg x
- (reg_y, _format_y, code_y) <- getSomeReg y
- reg_t <- getNewRegNat (intFormat W64)
- return $
- code_x `appOL`
- code_y `snocOL`
- MOV (OpReg W64 reg_t) (OpImm (ImmInt 13)) `snocOL`
- BCOND cmp (OpReg W64 reg_x) (OpReg W64 reg_y) (TBlock bid) (OpReg W64 reg_t)
-
+ return $ case w of
+ w | w `elem` [W8, W16, W32] ->
+ code_x `appOL`
+ signExtend (formatToWidth format_x) W64 reg_x reg_x `appOL`
+ code_y `appOL`
+ signExtend (formatToWidth format_y) W64 reg_y reg_y `snocOL`
+ BCOND1 cmp (OpReg W64 reg_x) (OpReg W64 reg_y) (TBlock bid)
+ _ ->
+ code_x `appOL`
+ code_y `snocOL`
+ BCOND1 cmp (OpReg W64 reg_x) (OpReg W64 reg_y) (TBlock bid)
fbcond w cmp = do
(reg_fx, _format_fx, code_fx) <- getFloatReg x
(reg_fy, _format_fy, code_fy) <- getFloatReg y
rst <- OpReg W64 <$> getNewRegNat II64
oneReg <- OpReg W64 <$> getNewRegNat II64
- reg_t <- getNewRegNat (intFormat W64)
return $
code_fx `appOL`
code_fy `snocOL`
- MOV (OpReg W64 reg_t) (OpImm (ImmInt 14)) `snocOL`
CSET cmp rst (OpReg w reg_fx) (OpReg w reg_fy) `snocOL`
MOV oneReg (OpImm (ImmInt 1)) `snocOL`
- BCOND EQ rst oneReg (TBlock bid) (OpReg W64 reg_t)
+ BCOND1 EQ rst oneReg (TBlock bid)
case mop of
@@ -1437,15 +1605,12 @@ genCondJump bid expr = do
MO_F_Ge w -> fbcond w FGE
MO_F_Lt w -> fbcond w FLT
MO_F_Le w -> fbcond w FLE
-
MO_Eq w -> sbcond w EQ
MO_Ne w -> sbcond w NE
-
MO_S_Gt w -> sbcond w SGT
MO_S_Ge w -> sbcond w SGE
MO_S_Lt w -> sbcond w SLT
MO_S_Le w -> sbcond w SLE
-
MO_U_Gt w -> ubcond w UGT
MO_U_Ge w -> ubcond w UGE
MO_U_Lt w -> ubcond w ULT
@@ -1454,7 +1619,6 @@ genCondJump bid expr = do
_ -> pprPanic "LA64.genCondJump: " (text $ show expr)
-
-- | Generate conditional branching instructions
-- This is basically an "if with else" statement.
genCondBranch ::
@@ -1513,16 +1677,14 @@ genCCall target dest_regs arg_regs = do
-- be a foreign procedure with an address expr
-- and a calling convention.
ForeignTarget expr _cconv -> do
--- (call_target, call_target_code) <- case expr of
--- -- if this is a label, let's just directly to it. This will produce the
--- -- correct CALL relocation for BL.
--- (CmmLit (CmmLabel lbl)) -> pure (TLabel lbl, nilOL)
--- -- if it's not a label, let's compute the expression into a
--- -- register and jump to that.
--- _ -> do
- (call_target_reg, call_target_code) <- do
- (reg, _format, reg_code) <- getSomeReg expr
- pure (reg, reg_code)
+ (call_target, call_target_code) <- case expr of
+ -- if this is a label, let's just directly to it.
+ (CmmLit (CmmLabel lbl)) -> pure (TLabel lbl, nilOL)
+ -- if it's not a label, let's compute the expression into a
+ -- register and jump to that.
+ _ -> do
+ (reg, _format, reg_code) <- getSomeReg expr
+ pure (TReg reg, reg_code)
-- compute the code and register logic for all arg_regs.
-- this will give us the format information to match on.
arg_regs' <- mapM getSomeReg arg_regs
@@ -1562,8 +1724,7 @@ genCCall target dest_regs arg_regs = do
call_target_code -- compute the label (possibly into a register)
`appOL` moveStackDown (stackSpaceWords)
`appOL` passArgumentsCode -- put the arguments into x0, ...
- -- `snocOL` BL call_target passRegs -- branch and link (C calls aren't tail calls, but return)
- `snocOL` BL (TReg call_target_reg) passRegs -- branch and link (C calls aren't tail calls, but return)
+ `snocOL` CALL call_target passRegs -- branch and link (C calls aren't tail calls, but return)
`appOL` readResultsCode -- parse the results into registers
`appOL` moveStackUp (stackSpaceWords)
return code
@@ -1571,11 +1732,79 @@ genCCall target dest_regs arg_regs = do
PrimTarget MO_F32_Fabs
| [arg_reg] <- arg_regs, [dest_reg] <- dest_regs ->
unaryFloatOp W32 (\d x -> unitOL $ FABS d x) arg_reg dest_reg
+ | otherwise -> panic "mal-formed MO_F32_Fabs"
PrimTarget MO_F64_Fabs
| [arg_reg] <- arg_regs, [dest_reg] <- dest_regs ->
unaryFloatOp W64 (\d x -> unitOL $ FABS d x) arg_reg dest_reg
+ | otherwise -> panic "mal-formed MO_F64_Fabs"
+
+ PrimTarget MO_F32_Sqrt
+ | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs ->
+ unaryFloatOp W32 (\d x -> unitOL $ FSQRT d x) arg_reg dest_reg
+ | otherwise -> panic "mal-formed MO_F32_Sqrt"
+ PrimTarget MO_F64_Sqrt
+ | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs ->
+ unaryFloatOp W64 (\d x -> unitOL $ FSQRT d x) arg_reg dest_reg
+ | otherwise -> panic "mal-formed MO_F64_Sqrt"
+
+ PrimTarget (MO_Clz w)
+ | w `elem` [W32, W64],
+ [arg_reg] <- arg_regs,
+ [dest_reg] <- dest_regs -> do
+ platform <- getPlatform
+ (reg_x, _format_x, code_x) <- getSomeReg arg_reg
+ let dst_reg = getRegisterReg platform (CmmLocal dest_reg)
+ return ( code_x `snocOL`
+ CLZ (OpReg w dst_reg) (OpReg w reg_x)
+ )
+ | w `elem` [W8, W16],
+ [arg_reg] <- arg_regs,
+ [dest_reg] <- dest_regs -> do
+ platform <- getPlatform
+ (reg_x, _format_x, code_x) <- getSomeReg arg_reg
+ let dst_reg = getRegisterReg platform (CmmLocal dest_reg)
+ return ( code_x `appOL` toOL
+ [
+ MOV (OpReg W64 dst_reg) (OpImm (ImmInt 1)),
+ SLL (OpReg W64 dst_reg) (OpReg W64 dst_reg) (OpImm (ImmInt (31-shift))),
+ SLL (OpReg W64 reg_x) (OpReg W64 reg_x) (OpImm (ImmInt (32-shift))),
+ OR (OpReg W64 dst_reg) (OpReg W64 dst_reg) (OpReg W64 reg_x),
+ CLZ (OpReg W64 dst_reg) (OpReg W32 dst_reg)
+ ]
+ )
+ | otherwise -> unsupported (MO_Clz w)
+ where
+ shift = widthToInt w
+
+ PrimTarget (MO_Ctz w)
+ | w `elem` [W32, W64],
+ [arg_reg] <- arg_regs,
+ [dest_reg] <- dest_regs -> do
+ platform <- getPlatform
+ (reg_x, _format_x, code_x) <- getSomeReg arg_reg
+ let dst_reg = getRegisterReg platform (CmmLocal dest_reg)
+ return ( code_x `snocOL`
+ CTZ (OpReg w dst_reg) (OpReg w reg_x)
+ )
+ | w `elem` [W8, W16],
+ [arg_reg] <- arg_regs,
+ [dest_reg] <- dest_regs -> do
+ platform <- getPlatform
+ (reg_x, _format_x, code_x) <- getSomeReg arg_reg
+ let dst_reg = getRegisterReg platform (CmmLocal dest_reg)
+ return ( code_x `appOL` toOL
+ [
+ MOV (OpReg W64 dst_reg) (OpImm (ImmInt 1)),
+ SLL (OpReg W64 dst_reg) (OpReg W64 dst_reg) (OpImm (ImmInt shift)),
+ BSTRPICK II64 (OpReg W64 reg_x) (OpReg W64 reg_x) (OpImm (ImmInt (shift-1))) (OpImm (ImmInt 0)),
+ OR (OpReg W64 dst_reg) (OpReg W64 dst_reg) (OpReg W64 reg_x),
+ CTZ (OpReg W64 dst_reg) (OpReg W64 dst_reg)
+ ]
+ )
+ | otherwise -> unsupported (MO_Ctz w)
+ where
+ shift = (widthToInt w)
- -- or a possibly side-effecting machine operation
-- mop :: CallishMachOp (see GHC.Cmm.MachOp)
PrimTarget mop -> do
-- We'll need config to construct forien targets
@@ -1603,8 +1832,6 @@ genCCall target dest_regs arg_regs = do
MO_F64_Log1P -> mkCCall "log1p"
MO_F64_Exp -> mkCCall "exp"
MO_F64_ExpM1 -> mkCCall "expm1"
- MO_F64_Fabs -> mkCCall "fabs"
- MO_F64_Sqrt -> mkCCall "sqrt"
-- 32 bit float ops
MO_F32_Pwr -> mkCCall "powf"
@@ -1625,8 +1852,6 @@ genCCall target dest_regs arg_regs = do
MO_F32_Log1P -> mkCCall "log1pf"
MO_F32_Exp -> mkCCall "expf"
MO_F32_ExpM1 -> mkCCall "expm1f"
- MO_F32_Fabs -> mkCCall "fabsf"
- MO_F32_Sqrt -> mkCCall "sqrtf"
-- 64-bit primops
MO_I64_ToI -> mkCCall "hs_int64ToInt"
@@ -1715,11 +1940,10 @@ genCCall target dest_regs arg_regs = do
MO_PopCnt w -> mkCCall (popCntLabel w)
MO_Pdep w -> mkCCall (pdepLabel w)
MO_Pext w -> mkCCall (pextLabel w)
- MO_Clz w -> mkCCall (clzLabel w)
- MO_Ctz w -> mkCCall (ctzLabel w)
MO_BSwap w -> mkCCall (bSwapLabel w)
MO_BRev w -> mkCCall (bRevLabel w)
+ -- or a possibly side-effecting machine operation
mo@(MO_AtomicRead w ord)
| [p_reg] <- arg_regs
, [dst_reg] <- dest_regs -> do
@@ -1891,3 +2115,122 @@ genCCall target dest_regs arg_regs = do
let dst = getRegisterReg platform (CmmLocal dest_reg)
let code = code_fx `appOL` op (OpReg w dst) (OpReg w reg_fx)
pure code
+
+data BlockInRange = InRange | NotInRange BlockId
+
+genCondFarJump :: (MonadGetUnique m) => Cond -> Operand -> Operand -> BlockId -> m InstrBlock
+genCondFarJump cond op1 op2 far_target = do
+ return $ toOL [ ann (text "Conditional far jump to: " <> ppr far_target)
+ $ BCOND cond op1 op2 (TBlock far_target)
+ ]
+
+makeFarBranches ::
+ Platform ->
+ LabelMap RawCmmStatics ->
+ [NatBasicBlock Instr] ->
+ UniqDSM [NatBasicBlock Instr]
+
+makeFarBranches {- only used when debugging -} _platform statics basic_blocks = do
+ -- All offsets/positions are counted in multiples of 4 bytes (the size of LoongArch64 instructions)
+ -- That is an offset of 1 represents a 4-byte/one instruction offset.
+ let (func_size, lblMap) = foldl' calc_lbl_positions (0, mapEmpty) basic_blocks
+ if func_size < max_cond_jump_dist
+ then pure basic_blocks
+ else do
+ (_, blocks) <- mapAccumLM (replace_blk lblMap) 0 basic_blocks
+ pure $ concat blocks
+ where
+ max_cond_jump_dist = 2 ^ (15 :: Int) - 8 :: Int
+ -- Currently all inline info tables fit into 64 bytes.
+ max_info_size = 16 :: Int
+ long_bc_jump_dist = 2 :: Int
+
+ -- Replace out of range conditional jumps with unconditional jumps.
+ replace_blk :: LabelMap Int -> Int -> GenBasicBlock Instr -> UniqDSM (Int, [GenBasicBlock Instr])
+ replace_blk !m !pos (BasicBlock lbl instrs) = do
+ -- Account for a potential info table before the label.
+ let !block_pos = pos + infoTblSize_maybe lbl
+ (!pos', instrs') <- mapAccumLM (replace_jump m) block_pos instrs
+ let instrs'' = concat instrs'
+ -- We might have introduced new labels, so split the instructions into basic blocks again if neccesary.
+ let (top, split_blocks, no_data) = foldr mkBlocks ([], [], []) instrs''
+ -- There should be no data in the instruction stream at this point
+ massert (null no_data)
+
+ let final_blocks = BasicBlock lbl top : split_blocks
+ pure (pos', final_blocks)
+
+ replace_jump :: LabelMap Int -> Int -> Instr -> UniqDSM (Int, [Instr])
+ replace_jump !m !pos instr = do
+ case instr of
+ ANN ann instr -> do
+ replace_jump m pos instr >>= \case
+ (idx, instr' : instrs') -> pure (idx, ANN ann instr' : instrs')
+ (idx, []) -> pprPanic "replace_jump" (text "empty return list for " <+> ppr idx)
+
+ BCOND1 cond op1 op2 t ->
+ case target_in_range m t pos of
+ InRange -> pure (pos + 1, [instr])
+ NotInRange far_target -> do
+ jmp_code <- genCondFarJump cond op1 op2 far_target
+ pure (pos + long_bc_jump_dist, fromOL jmp_code)
+
+ _ -> pure (pos + instr_size instr, [instr])
+
+ target_in_range :: LabelMap Int -> Target -> Int -> BlockInRange
+ target_in_range m target src =
+ case target of
+ (TReg{}) -> InRange
+ (TBlock bid) -> block_in_range m src bid
+ (TLabel clbl)
+ | Just bid <- maybeLocalBlockLabel clbl
+ -> block_in_range m src bid
+ | otherwise
+ -> InRange
+
+ block_in_range :: LabelMap Int -> Int -> BlockId -> BlockInRange
+ block_in_range m src_pos dest_lbl =
+ case mapLookup dest_lbl m of
+ Nothing ->
+ pprTrace "not in range" (ppr dest_lbl) $ NotInRange dest_lbl
+ Just dest_pos ->
+ if abs (dest_pos - src_pos) < max_cond_jump_dist
+ then InRange
+ else NotInRange dest_lbl
+
+ calc_lbl_positions :: (Int, LabelMap Int) -> GenBasicBlock Instr -> (Int, LabelMap Int)
+ calc_lbl_positions (pos, m) (BasicBlock lbl instrs) =
+ let !pos' = pos + infoTblSize_maybe lbl
+ in foldl' instr_pos (pos', mapInsert lbl pos' m) instrs
+
+ instr_pos :: (Int, LabelMap Int) -> Instr -> (Int, LabelMap Int)
+ instr_pos (pos, m) instr = (pos + instr_size instr, m)
+
+ infoTblSize_maybe bid =
+ case mapLookup bid statics of
+ Nothing -> 0 :: Int
+ Just _info_static -> max_info_size
+
+ instr_size :: Instr -> Int
+ instr_size i = case i of
+ COMMENT {} -> 0
+ MULTILINE_COMMENT {} -> 0
+ ANN _ instr -> instr_size instr
+ LOCATION {} -> 0
+ DELTA {} -> 0
+ -- At this point there should be no NEWBLOCK in the instruction stream (pos, mapInsert bid pos m)
+ NEWBLOCK {} -> panic "mkFarBranched - Unexpected"
+ LDATA {} -> panic "mkFarBranched - Unexpected"
+ PUSH_STACK_FRAME -> 4
+ POP_STACK_FRAME -> 4
+ CSET {} -> 2
+ LD _ _ (OpImm (ImmIndex _ _)) -> 3
+ LD _ _ (OpImm (ImmCLbl _)) -> 2
+ SCVTF {} -> 2
+ FCVTZS {} -> 4
+ BCOND {} -> long_bc_jump_dist
+ CALL (TReg _) _ -> 1
+ CALL {} -> 2
+ CALL36 {} -> 2
+ TAIL36 {} -> 2
+ _ -> 1
=====================================
compiler/GHC/CmmToAsm/LA64/Instr.hs
=====================================
@@ -143,9 +143,16 @@ regUsageOfInstr platform instr = case instr of
J_TBL _ _ t -> usage ([t], [])
B t -> usage (regTarget t, [])
BL t ps -> usage (regTarget t ++ ps, callerSavedRegisters)
+ CALL t ps -> usage (regTarget t ++ ps, callerSavedRegisters)
CALL36 t -> usage (regTarget t, [])
TAIL36 r t -> usage (regTarget t, regOp r)
- BCOND _ j d t tmp -> usage (regTarget t ++ regOp j ++ regOp d ++ regOp tmp, regOp tmp)
+ -- Here two kinds of BCOND and BCOND1 are implemented, mainly because we want
+ -- to distinguish between two kinds of conditional jumps with different jump
+ -- ranges, corresponding to 2 and 1 instruction implementations respectively.
+ --
+ -- BCOND1 is selected by default.
+ BCOND1 _ j d t -> usage (regTarget t ++ regOp j ++ regOp d, [])
+ BCOND _ j d t -> usage (regTarget t ++ regOp j ++ regOp d, [])
BEQZ j t -> usage (regTarget t ++ regOp j, [])
BNEZ j t -> usage (regTarget t ++ regOp j, [])
-- 5. Common Memory Access Instructions --------------------------------------
@@ -157,6 +164,7 @@ regUsageOfInstr platform instr = case instr of
STX _ dst src -> usage (regOp src ++ regOp dst, [])
LDPTR _ dst src -> usage (regOp src, regOp dst)
STPTR _ dst src -> usage (regOp src ++ regOp dst, [])
+ PRELD _hint src -> usage (regOp src, [])
-- 6. Bound Check Memory Access Instructions ---------------------------------
-- LDCOND dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)
-- STCOND dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)
@@ -176,6 +184,7 @@ regUsageOfInstr platform instr = case instr of
SCVTF dst src -> usage (regOp src, regOp dst)
FCVTZS dst src1 src2 -> usage (regOp src2, regOp src1 ++ regOp dst)
FABS dst src -> usage (regOp src, regOp dst)
+ FSQRT dst src -> usage (regOp src, regOp dst)
FMA _ dst src1 src2 src3 -> usage (regOp src1 ++ regOp src2 ++ regOp src3, regOp dst)
_ -> panic $ "regUsageOfInstr: " ++ instrCon instr
@@ -317,9 +326,11 @@ patchRegsOfInstr instr env = case instr of
J_TBL ids mbLbl t -> J_TBL ids mbLbl (env t)
B t -> B (patchTarget t)
BL t ps -> BL (patchTarget t) ps
+ CALL t ps -> CALL (patchTarget t) ps
CALL36 t -> CALL36 (patchTarget t)
TAIL36 r t -> TAIL36 (patchOp r) (patchTarget t)
- BCOND c j d t tmp -> BCOND c (patchOp j) (patchOp d) (patchTarget t) (patchOp tmp)
+ BCOND1 c j d t -> BCOND1 c (patchOp j) (patchOp d) (patchTarget t)
+ BCOND c j d t -> BCOND c (patchOp j) (patchOp d) (patchTarget t)
BEQZ j t -> BEQZ (patchOp j) (patchTarget t)
BNEZ j t -> BNEZ (patchOp j) (patchTarget t)
-- 5. Common Memory Access Instructions --------------------------------------
@@ -332,6 +343,7 @@ patchRegsOfInstr instr env = case instr of
STX f o1 o2 -> STX f (patchOp o1) (patchOp o2)
LDPTR f o1 o2 -> LDPTR f (patchOp o1) (patchOp o2)
STPTR f o1 o2 -> STPTR f (patchOp o1) (patchOp o2)
+ PRELD o1 o2 -> PRELD (patchOp o1) (patchOp o2)
-- 6. Bound Check Memory Access Instructions ---------------------------------
-- LDCOND o1 o2 o3 -> LDCOND (patchOp o1) (patchOp o2) (patchOp o3)
-- STCOND o1 o2 o3 -> STCOND (patchOp o1) (patchOp o2) (patchOp o3)
@@ -350,6 +362,7 @@ patchRegsOfInstr instr env = case instr of
FMAXA o1 o2 o3 -> FMAXA (patchOp o1) (patchOp o2) (patchOp o3)
FNEG o1 o2 -> FNEG (patchOp o1) (patchOp o2)
FABS o1 o2 -> FABS (patchOp o1) (patchOp o2)
+ FSQRT o1 o2 -> FSQRT (patchOp o1) (patchOp o2)
FMA s o1 o2 o3 o4 -> FMA s (patchOp o1) (patchOp o2) (patchOp o3) (patchOp o4)
_ -> panic $ "patchRegsOfInstr: " ++ instrCon instr
@@ -381,8 +394,10 @@ isJumpishInstr instr = case instr of
J_TBL {} -> True
B {} -> True
BL {} -> True
+ CALL {} -> True
CALL36 {} -> True
TAIL36 {} -> True
+ BCOND1 {} -> True
BCOND {} -> True
BEQZ {} -> True
BNEZ {} -> True
@@ -395,9 +410,11 @@ jumpDestsOfInstr (J t) = [id | TBlock id <- [t]]
jumpDestsOfInstr (J_TBL ids _mbLbl _r) = catMaybes ids
jumpDestsOfInstr (B t) = [id | TBlock id <- [t]]
jumpDestsOfInstr (BL t _) = [id | TBlock id <- [t]]
+jumpDestsOfInstr (CALL t _) = [id | TBlock id <- [t]]
jumpDestsOfInstr (CALL36 t) = [id | TBlock id <- [t]]
jumpDestsOfInstr (TAIL36 _ t) = [id | TBlock id <- [t]]
-jumpDestsOfInstr (BCOND _ _ _ t _) = [id | TBlock id <- [t]]
+jumpDestsOfInstr (BCOND1 _ _ _ t) = [id | TBlock id <- [t]]
+jumpDestsOfInstr (BCOND _ _ _ t) = [id | TBlock id <- [t]]
jumpDestsOfInstr (BEQZ _ t) = [id | TBlock id <- [t]]
jumpDestsOfInstr (BNEZ _ t) = [id | TBlock id <- [t]]
jumpDestsOfInstr _ = []
@@ -413,9 +430,11 @@ patchJumpInstr instr patchF =
J_TBL ids mbLbl r -> J_TBL (map (fmap patchF) ids) mbLbl r
B (TBlock bid) -> B (TBlock (patchF bid))
BL (TBlock bid) ps -> BL (TBlock (patchF bid)) ps
+ CALL (TBlock bid) ps -> CALL (TBlock (patchF bid)) ps
CALL36 (TBlock bid) -> CALL36 (TBlock (patchF bid))
TAIL36 r (TBlock bid) -> TAIL36 r (TBlock (patchF bid))
- BCOND c o1 o2 (TBlock bid) tmp -> BCOND c o1 o2 (TBlock (patchF bid)) tmp
+ BCOND1 c o1 o2 (TBlock bid) -> BCOND1 c o1 o2 (TBlock (patchF bid))
+ BCOND c o1 o2 (TBlock bid) -> BCOND c o1 o2 (TBlock (patchF bid))
BEQZ j (TBlock bid) -> BEQZ j (TBlock (patchF bid))
BNEZ j (TBlock bid) -> BNEZ j (TBlock (patchF bid))
_ -> panic $ "patchJumpInstr: " ++ instrCon instr
@@ -501,9 +520,9 @@ canFallthroughTo insn bid =
J (TBlock target) -> bid == target
J_TBL targets _ _ -> all isTargetBid targets
B (TBlock target) -> bid == target
- CALL36 (TBlock target) -> bid == target
TAIL36 _ (TBlock target) -> bid == target
- BCOND _ _ _ (TBlock target) _ -> bid == target
+ BCOND1 _ _ _ (TBlock target) -> bid == target
+ BCOND _ _ _ (TBlock target) -> bid == target
_ -> False
where
isTargetBid target = case target of
@@ -589,7 +608,6 @@ allocMoreStack platform slots proc@(CmmProc info lbl live (ListGraph code)) = do
insert_dealloc insn r = case insn of
J {} -> dealloc ++ (insn : r)
- J_TBL {} -> dealloc ++ (insn : r)
ANN _ e -> insert_dealloc e r
_other | jumpDestsOfInstr insn /= [] ->
patchJumpInstr insn retarget : r
@@ -697,9 +715,11 @@ data Instr
| J_TBL [Maybe BlockId] (Maybe CLabel) Reg
| B Target
| BL Target [Reg]
+ | CALL Target [Reg]
| CALL36 Target
| TAIL36 Operand Target
- | BCOND Cond Operand Operand Target Operand
+ | BCOND1 Cond Operand Operand Target
+ | BCOND Cond Operand Operand Target
| BEQZ Operand Target
| BNEZ Operand Target
-- 5. Common Memory Access Instructions --------------------------------------
@@ -711,6 +731,7 @@ data Instr
| STX Format Operand Operand
| LDPTR Format Operand Operand
| STPTR Format Operand Operand
+ | PRELD Operand Operand
-- 6. Bound Check Memory Access Instructions ---------------------------------
-- 7. Atomic Memory Access Instructions --------------------------------------
-- 8. Barrier Instructions ---------------------------------------------------
@@ -726,6 +747,7 @@ data Instr
| FMINA Operand Operand Operand
| FNEG Operand Operand
| FABS Operand Operand
+ | FSQRT Operand Operand
-- Floating-point fused multiply-add instructions
-- fmadd : d = r1 * r2 + r3
-- fnmsub: d = r1 * r2 - r3
@@ -809,8 +831,10 @@ instrCon i =
J_TBL{} -> "J_TBL"
B{} -> "B"
BL{} -> "BL"
+ CALL{} -> "CALL"
CALL36{} -> "CALL36"
TAIL36{} -> "TAIL36"
+ BCOND1{} -> "BCOND1"
BCOND{} -> "BCOND"
BEQZ{} -> "BEQZ"
BNEZ{} -> "BNEZ"
@@ -822,6 +846,7 @@ instrCon i =
STX{} -> "STX"
LDPTR{} -> "LDPTR"
STPTR{} -> "STPTR"
+ PRELD{} -> "PRELD"
DBAR{} -> "DBAR"
IBAR{} -> "IBAR"
FCVT{} -> "FCVT"
@@ -833,6 +858,7 @@ instrCon i =
FMINA{} -> "FMINA"
FNEG{} -> "FNEG"
FABS{} -> "FABS"
+ FSQRT{} -> "FSQRT"
FMA variant _ _ _ _ ->
case variant of
FMAdd -> "FMADD"
@@ -979,6 +1005,8 @@ widthFromOpReg (OpReg W32 _) = W32
widthFromOpReg (OpReg W64 _) = W64
widthFromOpReg _ = W64
-lessW64 :: Width -> Bool
-lessW64 w | w == W8 || w == W16 || w == W32 = True
-lessW64 _ = False
+ldFormat :: Format -> Format
+ldFormat f
+ | f `elem` [II8, II16, II32, II64] = II64
+ | f `elem` [FF32, FF64] = FF64
+ | otherwise = pprPanic "unsupported ldFormat: " (text $ show f)
=====================================
compiler/GHC/CmmToAsm/LA64/Ppr.hs
=====================================
@@ -1,4 +1,3 @@
-
module GHC.CmmToAsm.LA64.Ppr (pprNatCmmDecl, pprInstr) where
import GHC.Prelude hiding (EQ)
@@ -437,32 +436,28 @@ pprInstr platform instr = case instr of
-- ADD.{W/D}, SUB.{W/D}
-- ADDI.{W/D}, ADDU16I.D
ADD o1 o2 o3
- | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 && isSingleOp o1 && isSingleOp o2 && isSingleOp o3 -> op3 (text "\tfadd.s") o1 o2 o3
- | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 && isDoubleOp o1 && isDoubleOp o2 && isDoubleOp o3 -> op3 (text "\tfadd.d") o1 o2 o3
- | OpReg W64 _ <- o1, OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tadd.w") o1 o2 o3
- | OpReg W64 _ <- o1, OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tadd.d") o1 o2 o3
- | OpReg W64 _ <- o1, OpReg W32 _ <- o2, isImmOp o3, (OpImm (ImmInteger i)) <- o3, fitsInNbits 12 (fromIntegral i) -> op3 (text "\taddi.w") o1 o2 o3
- | OpReg W64 _ <- o1, OpReg W32 _ <- o2, isImmOp o3, (OpImm (ImmInt i)) <- o3, fitsInNbits 12 (fromIntegral i) -> op3 (text "\taddi.w") o1 o2 o3
- | OpReg W64 _ <- o1, OpReg W64 _ <- o2, isImmOp o3, (OpImm (ImmInteger i)) <- o3, fitsInNbits 12 (fromIntegral i) -> op3 (text "\taddi.d") o1 o2 o3
- | OpReg W64 _ <- o1, OpReg W64 _ <- o2, isImmOp o3, (OpImm (ImmInt i)) <- o3, fitsInNbits 12 (fromIntegral i) -> op3 (text "\taddi.d") o1 o2 o3
+ | isFloatOp o2 && isFloatOp o3 && isSingleOp o2 && isSingleOp o3 -> op3 (text "\tfadd.s") o1 o2 o3
+ | isFloatOp o2 && isFloatOp o3 && isDoubleOp o2 && isDoubleOp o3 -> op3 (text "\tfadd.d") o1 o2 o3
+ | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tadd.w") o1 o2 o3
+ | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tadd.d") o1 o2 o3
+ | OpReg W32 _ <- o2, isImmOp o3 -> op3 (text "\taddi.w") o1 o2 o3
+ | OpReg W64 _ <- o2, isImmOp o3 -> op3 (text "\taddi.d") o1 o2 o3
| otherwise -> pprPanic "LA64.ppr: ADD error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)
-- TODO: Not complete.
-- Here we should add addu16i.d for optimizations of accelerating GOT accession
-- with ldptr.w/d, stptr.w/d
SUB o1 o2 o3
- | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 && isSingleOp o1 && isSingleOp o2 && isSingleOp o3 -> op3 (text "\tfsub.s") o1 o2 o3
- | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 && isDoubleOp o1 && isDoubleOp o2 && isDoubleOp o3 -> op3 (text "\tfsub.d") o1 o2 o3
- | OpReg W64 _ <- o1, OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tsub.w") o1 o2 o3
- | OpReg W64 _ <- o1, OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tsub.d") o1 o2 o3
- | OpReg W64 _ <- o1, OpReg W32 _ <- o2, isImmOp o3, (OpImm (ImmInteger i)) <- o3, fitsInNbits 12 (fromIntegral i) -> op3 (text "\taddi.w") o1 o2 (negOp o3)
- | OpReg W64 _ <- o1, OpReg W32 _ <- o2, isImmOp o3, (OpImm (ImmInt i)) <- o3, fitsInNbits 12 (fromIntegral i) -> op3 (text "\taddi.w") o1 o2 (negOp o3)
- | OpReg W64 _ <- o1, OpReg W64 _ <- o2, isImmOp o3, (OpImm (ImmInteger i)) <- o3, fitsInNbits 12 (fromIntegral i) -> op3 (text "\taddi.d") o1 o2 (negOp o3)
- | OpReg W64 _ <- o1, OpReg W64 _ <- o2, isImmOp o3, (OpImm (ImmInt i)) <- o3, fitsInNbits 12 (fromIntegral i) -> op3 (text "\taddi.d") o1 o2 (negOp o3)
+ | isFloatOp o2 && isFloatOp o3 && isSingleOp o2 && isSingleOp o3 -> op3 (text "\tfsub.s") o1 o2 o3
+ | isFloatOp o2 && isFloatOp o3 && isDoubleOp o2 && isDoubleOp o3 -> op3 (text "\tfsub.d") o1 o2 o3
+ | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tsub.w") o1 o2 o3
+ | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tsub.d") o1 o2 o3
+ | OpReg W32 _ <- o2, isImmOp o3 -> op3 (text "\taddi.w") o1 o2 (negOp o3)
+ | OpReg W64 _ <- o2, isImmOp o3 -> op3 (text "\taddi.d") o1 o2 (negOp o3)
| otherwise -> pprPanic "LA64.ppr: SUB error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)
-- ALSL.{W[U]/D}
ALSL o1 o2 o3 o4
- | OpReg W64 _ <- o1, OpReg W32 _ <- o2, OpReg W32 _ <- o3, isImmOp o4 -> op4 (text "\talsl.w") o1 o2 o3 o4
- | OpReg W64 _ <- o1, OpReg W64 _ <- o2, OpReg W64 _ <- o3, isImmOp o4 -> op4 (text "\talsl.d") o1 o2 o3 o4
+ | OpReg W32 _ <- o2, OpReg W32 _ <- o3, isImmOp o4 -> op4 (text "\talsl.w") o1 o2 o3 o4
+ | OpReg W64 _ <- o2, OpReg W64 _ <- o3, isImmOp o4 -> op4 (text "\talsl.d") o1 o2 o3 o4
| otherwise -> pprPanic "LA64.ppr: ALSL error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)
ALSLU o1 o2 o3 o4 -> op4 (text "\talsl.wu") o1 o2 o3 o4
-- LoongArch-Assembler should implement following pesudo instructions, here we can directly use them.
@@ -491,14 +486,12 @@ pprInstr platform instr = case instr of
-- SSLT[U]
-- SSLT[U]I
SSLT o1 o2 o3
- | OpReg W64 _ <- o1, isImmOp o3, (OpImm (ImmInteger i)) <- o3, fitsInNbits 12 (fromIntegral i) -> op3 (text "\tslti") o1 o2 o3
- | OpReg W64 _ <- o1, isImmOp o3, (OpImm (ImmInt i)) <- o3, fitsInNbits 12 (fromIntegral i) -> op3 (text "\tslti") o1 o2 o3
- | OpReg W64 _ <- o1, OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tslt") o1 o2 o3
+ | isImmOp o3 -> op3 (text "\tslti") o1 o2 o3
+ | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tslt") o1 o2 o3
| otherwise -> pprPanic "LA64.ppr: SSLT error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)
SSLTU o1 o2 o3
- | OpReg W64 _ <- o1, isImmOp o3, (OpImm (ImmInteger i)) <- o3, fitsInNbits 12 (fromIntegral i) -> op3 (text "\tsltui") o1 o2 o3
- | OpReg W64 _ <- o1, isImmOp o3, (OpImm (ImmInt i)) <- o3, fitsInNbits 12 (fromIntegral i) -> op3 (text "\tsltui") o1 o2 o3
- | OpReg W64 _ <- o1, OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tsltu") o1 o2 o3
+ | isImmOp o3 -> op3 (text "\tsltui") o1 o2 o3
+ | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tsltu") o1 o2 o3
| otherwise -> pprPanic "LA64.ppr: SSLTU error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)
-- PCADDI, PCADDU121, PCADDU18l, PCALAU12I
PCADDI o1 o2 -> op2 (text "\tpcaddi") o1 o2
@@ -511,19 +504,16 @@ pprInstr platform instr = case instr of
-- AND, OR, NOR, XOR, ANDN, ORN
-- ANDI, ORI, XORI: zero-extention
AND o1 o2 o3
- | OpReg W64 _ <- o1, OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tand") o1 o2 o3
- | OpReg W64 _ <- o1, OpReg W64 _ <- o2, (OpImm (ImmInteger i)) <- o3, isUnsignOp (fromIntegral i), fitsInNbits 13 (fromIntegral i) -> op3 (text "\tandi") o1 o2 o3
- | OpReg W64 _ <- o1, OpReg W64 _ <- o2, (OpImm (ImmInt i)) <- o3, isUnsignOp (fromIntegral i), fitsInNbits 13 (fromIntegral i) -> op3 (text "\tandi") o1 o2 o3
+ | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tand") o1 o2 o3
+ | OpReg W64 _ <- o2, isImmOp o3 -> op3 (text "\tandi") o1 o2 o3
| otherwise -> pprPanic "LA64.ppr: AND error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)
OR o1 o2 o3
- | OpReg W64 _ <- o1, OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tor") o1 o2 o3
- | OpReg W64 _ <- o1, OpReg W64 _ <- o2, (OpImm (ImmInteger i)) <- o3, isUnsignOp (fromIntegral i), fitsInNbits 13 (fromIntegral i) -> op3 (text "\tori") o1 o2 o3
- | OpReg W64 _ <- o1, OpReg W64 _ <- o2, (OpImm (ImmInt i)) <- o3, isUnsignOp (fromIntegral i), fitsInNbits 13 (fromIntegral i) -> op3 (text "\tori") o1 o2 o3
+ | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tor") o1 o2 o3
+ | OpReg W64 _ <- o2, isImmOp o3 -> op3 (text "\tori") o1 o2 o3
| otherwise -> pprPanic "LA64.ppr: OR error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)
XOR o1 o2 o3
- | OpReg W64 _ <- o1, OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\txor") o1 o2 o3
- | OpReg W64 _ <- o1, OpReg W64 _ <- o2, (OpImm (ImmInteger i)) <- o3, isUnsignOp (fromIntegral i), fitsInNbits 13 (fromIntegral i) -> op3 (text "\txori") o1 o2 o3
- | OpReg W64 _ <- o1, OpReg W64 _ <- o2, (OpImm (ImmInt i)) <- o3, isUnsignOp (fromIntegral i), fitsInNbits 13 (fromIntegral i) -> op3 (text "\txori") o1 o2 o3
+ | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\txor") o1 o2 o3
+ | OpReg W64 _ <- o2, isImmOp o3 -> op3 (text "\txori") o1 o2 o3
| otherwise -> pprPanic "LA64.ppr: XOR error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)
NOR o1 o2 o3 -> op3 (text "\tnor") o1 o2 o3
ANDN o1 o2 o3 -> op3 (text "\tandn") o1 o2 o3
@@ -535,10 +525,10 @@ pprInstr platform instr = case instr of
NOP -> line $ text "\tnop"
-- NEG o1 o2, alias for "sub o1, r0, o2"
NEG o1 o2
- | isFloatOp o1 && isFloatOp o2 && isSingleOp o1 && isSingleOp o2 -> op2 (text "\tfneg.s") o1 o2
- | isFloatOp o1 && isFloatOp o2 && isDoubleOp o1 && isDoubleOp o2 -> op2 (text "\tfneg.d") o1 o2
- | OpReg W64 _ <- o1, OpReg W32 _ <- o2 -> op3 (text "\tsub.w" ) o1 zero o2
- | OpReg W64 _ <- o1, OpReg W64 _ <- o2 -> op3 (text "\tsub.d" ) o1 zero o2
+ | isFloatOp o2 && isSingleOp o2 -> op2 (text "\tfneg.s") o1 o2
+ | isFloatOp o2 && isDoubleOp o2 -> op2 (text "\tfneg.d") o1 o2
+ | OpReg W32 _ <- o2 -> op3 (text "\tsub.w" ) o1 zero o2
+ | OpReg W64 _ <- o2 -> op3 (text "\tsub.d" ) o1 zero o2
| otherwise -> pprPanic "LA64.ppr: NEG error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2)
-- Here we can do more simplitcations.
-- To be honest, floating point instructions are too scarce, so maybe
@@ -552,22 +542,12 @@ pprInstr platform instr = case instr of
| isFloatOp o1 && not (isFloatOp o2) && isDoubleOp o1 -> op2 (text "\tmovgr2fr.d") o1 o2
| not (isFloatOp o1) && isFloatOp o2 && isSingleOp o2 -> op2 (text "\tmovfr2gr.s") o1 o2
| not (isFloatOp o1) && isFloatOp o2 && isDoubleOp o2 -> op2 (text "\tmovfr2gr.d") o1 o2
- | OpReg W64 _ <- o1, isImmOp o2, (OpImm (ImmInteger i)) <- o2, fitsInNbits 12 (fromIntegral i) ->
+ | isImmOp o2, (OpImm (ImmInt i)) <- o2, fitsInNbits 12 (fromIntegral i) ->
lines_ [text "\taddi.d" <+> pprOp platform o1 <> comma <+> pprOp platform x0 <+> comma <> pprOp platform o2]
- | OpReg W64 _ <- o1, isImmOp o2, (OpImm (ImmInt i)) <- o2, fitsInNbits 12 (fromIntegral i) ->
+ | isImmOp o2, (OpImm (ImmInteger i)) <- o2, fitsInNbits 12 (fromIntegral i) ->
lines_ [text "\taddi.d" <+> pprOp platform o1 <> comma <+> pprOp platform x0 <+> comma <> pprOp platform o2]
- | OpReg _ _ <- o1, isImmOp o2, (OpImm (ImmInteger i)) <- o2, fitsInNbits 12 (fromIntegral i) ->
- lines_ [
- text "\taddi.d" <+> pprOp platform o1 <> comma <+> pprOp platform x0 <+> comma <> pprOp platform o2,
- text "\tbstrpick.d" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> pprOp platform (OpImm (ImmInt ((widthToInt $ widthFromOpReg o1) - 1) )) <+> text ", 0"
- ]
- | OpReg _ _ <- o1, isImmOp o2, (OpImm (ImmInt i)) <- o2, fitsInNbits 12 (fromIntegral i) ->
- lines_ [
- text "\taddi.d" <+> pprOp platform o1 <> comma <+> pprOp platform x0 <+> comma <> pprOp platform o2,
- text "\tbstrpick.d" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> pprOp platform (OpImm (ImmInt ((widthToInt $ widthFromOpReg o1) - 1) )) <+> text ", 0"
- ]
- | OpReg W64 _ <- o1, OpReg W64 _ <- o2 -> op2 (text "\tmove") o1 o2
- | OpReg _ _ <- o1, OpReg _ _ <- o2 ->
+ | OpReg W64 _ <- o2 -> op2 (text "\tmove") o1 o2
+ | OpReg _ _ <- o2 ->
lines_ [
text "\tbstrpick.d" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform (OpImm (ImmInt ((widthToInt (min (widthFromOpReg o1) (widthFromOpReg o2))) - 1))) <+> text ", 0"
]
@@ -690,18 +670,18 @@ pprInstr platform instr = case instr of
_ -> pprPanic "LA64.ppr: CSET error: " (pprCond cond <+> pprOp platform dst <> comma <+> (ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2)
where
- subFor o1 o2 | (OpReg W64 _) <- dst, (OpReg W64 _) <- o1, (OpImm _) <- o2 =
+ subFor o1 o2 | (OpReg W64 _) <- dst, (OpImm _) <- o2 =
text "\taddi.d" <+> pprOp platform dst <> comma <+> pprOp platform o1 <> comma <+> pprOp platform (negOp o2)
- | (OpReg W64 _) <- dst, (OpReg W64 _) <- o1,(OpReg W64 _) <- o2 =
+ | (OpReg W64 _) <- dst, (OpReg W64 _) <- o2 =
text "\tsub.d" <+> pprOp platform dst <> comma <+> pprOp platform o1 <> comma <+> pprOp platform o2
| otherwise = pprPanic "LA64.ppr: unknown subFor format: " ((ppr (widthFromOpReg dst)) <+> pprOp platform dst <+> (ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2)
- sltFor o1 o2 | (OpReg W64 _) <- dst, (OpReg W64 _) <- o1, (OpImm _) <- o2 = text "\tslti"
- | (OpReg W64 _) <- dst, (OpReg W64 _) <- o1, (OpReg W64 _) <- o2 = text "\tslt"
+ sltFor o1 o2 | (OpReg W64 _) <- dst, (OpImm _) <- o2 = text "\tslti"
+ | (OpReg W64 _) <- dst, (OpReg W64 _) <- o2 = text "\tslt"
| otherwise = pprPanic "LA64.ppr: unknown sltFor format: " ((ppr (widthFromOpReg dst)) <+> pprOp platform dst <+> (ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2)
- sltuFor o1 o2 | (OpReg W64 _) <- dst, (OpReg W64 _) <- o1, (OpImm _) <- o2 = text "\tsltui"
- | (OpReg W64 _) <- dst, (OpReg W64 _) <- o1, (OpReg W64 _) <- o2 = text "\tsltu"
+ sltuFor o1 o2 | (OpReg W64 _) <- dst, (OpImm _) <- o2 = text "\tsltui"
+ | (OpReg W64 _) <- dst, (OpReg W64 _) <- o2 = text "\tsltu"
| otherwise = pprPanic "LA64.ppr: unknown sltuFor format: " ((ppr (widthFromOpReg dst)) <+> pprOp platform dst <+> (ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2)
-- MUL.{W/D}, MULH, {W[U]/D[U]}, 'h' means high 32bit.
@@ -709,41 +689,41 @@ pprInstr platform instr = case instr of
MUL o1 o2 o3
| isFloatOp o1 && isFloatOp o2 && isFloatOp o3 && isSingleOp o1 && isSingleOp o2 && isSingleOp o3 -> op3 (text "\tfmul.s") o1 o2 o3
| isFloatOp o1 && isFloatOp o2 && isFloatOp o3 && isDoubleOp o1 && isDoubleOp o2 && isDoubleOp o3 -> op3 (text "\tfmul.d") o1 o2 o3
- | OpReg W64 _ <- o1, OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tmul.w") o1 o2 o3
- | OpReg W64 _ <- o1, OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tmul.d") o1 o2 o3
+ | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tmul.w") o1 o2 o3
+ | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tmul.d") o1 o2 o3
| otherwise -> pprPanic "LA64.ppr: MUL error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)
MULW o1 o2 o3
- | OpReg W64 _ <- o1, OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tmulw.d.w") o1 o2 o3
+ | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tmulw.d.w") o1 o2 o3
| otherwise -> pprPanic "LA64.ppr: MULW error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)
MULWU o1 o2 o3
- | OpReg W64 _ <- o1, OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tmulw.d.wu") o1 o2 o3
+ | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tmulw.d.wu") o1 o2 o3
| otherwise -> pprPanic "LA64.ppr: MULWU error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)
MULH o1 o2 o3
- | OpReg W64 _ <- o1, OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tmulh.w") o1 o2 o3
- | OpReg W64 _ <- o1, OpReg W64 _ <- o2, OpReg W64 _ <- o2 -> op3 (text "\tmulh.d") o1 o2 o3
+ | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tmulh.w") o1 o2 o3
+ | OpReg W64 _ <- o2, OpReg W64 _ <- o2 -> op3 (text "\tmulh.d") o1 o2 o3
| otherwise -> pprPanic "LA64.ppr: MULH error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)
MULHU o1 o2 o3
- | OpReg W64 _ <- o1, OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tmulh.wu") o1 o2 o3
- | OpReg W64 _ <- o1, OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tmulh.du") o1 o2 o3
+ | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tmulh.wu") o1 o2 o3
+ | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tmulh.du") o1 o2 o3
| otherwise -> pprPanic "LA64.ppr: MULHU error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)
-- DIV.{W[U]/D[U]}, MOD.{W[U]/D[U]}
DIV o1 o2 o3
| isFloatOp o1 && isFloatOp o2 && isFloatOp o3 && isSingleOp o1 && isSingleOp o2 && isSingleOp o3 -> op3 (text "\tfdiv.s") o1 o2 o3
| isFloatOp o1 && isFloatOp o2 && isFloatOp o3 && isDoubleOp o1 && isDoubleOp o2 && isDoubleOp o3 -> op3 (text "\tfdiv.d") o1 o2 o3
- | OpReg W64 _ <- o1, OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tdiv.w") o1 o2 o3
- | OpReg W64 _ <- o1, OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tdiv.d") o1 o2 o3
+ | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tdiv.w") o1 o2 o3
+ | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tdiv.d") o1 o2 o3
| otherwise -> pprPanic "LA64.ppr: DIV error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)
DIVU o1 o2 o3
- | OpReg W64 _ <- o1, OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tdiv.wu") o1 o2 o3
- | OpReg W64 _ <- o1, OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tdiv.du") o1 o2 o3
+ | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tdiv.wu") o1 o2 o3
+ | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tdiv.du") o1 o2 o3
| otherwise -> pprPanic "LA64.ppr: DIVU error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)
MOD o1 o2 o3
- | OpReg W64 _ <- o1, OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tmod.w") o1 o2 o3
- | OpReg W64 _ <- o1, OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tmod.d") o1 o2 o3
+ | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tmod.w") o1 o2 o3
+ | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tmod.d") o1 o2 o3
| otherwise -> pprPanic "LA64.ppr: MOD error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)
MODU o1 o2 o3
- | OpReg W64 _ <- o1, OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tmod.wu") o1 o2 o3
- | OpReg W64 _ <- o1, OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tmod.du") o1 o2 o3
+ | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tmod.wu") o1 o2 o3
+ | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tmod.du") o1 o2 o3
| otherwise -> pprPanic "LA64.ppr: MODU error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)
-- 2. Bit-shift Instuctions --------------------------------------------------
-- SLL.W, SRL.W, SRA.W, ROTR.W
@@ -751,58 +731,42 @@ pprInstr platform instr = case instr of
-- SLLI.W, SRLI.W, SRAI.W, ROTRI.W
-- SLLI.D, SRLI.D, SRAI.D, ROTRI.D
SLL o1 o2 o3
- | OpReg W64 _ <- o1, OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tsll.w") o1 o2 o3
- | OpReg W64 _ <- o1, OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tsll.d") o1 o2 o3
- | OpReg W64 _ <- o1, OpReg W32 _ <- o2, (OpImm (ImmInteger i)) <- o3, 0 <= i, i < 32 ->
- lines_ [text "\tslli.w" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3]
- | OpReg W64 _ <- o1, OpReg W32 _ <- o2, (OpImm (ImmInt i)) <- o3, 0 <= i, i < 32 ->
+ | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tsll.w") o1 o2 o3
+ | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tsll.d") o1 o2 o3
+ | OpReg W32 _ <- o2, isImmOp o3 ->
lines_ [text "\tslli.w" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3]
- | OpReg W64 _ <- o1, OpReg W64 _ <- o2, (OpImm (ImmInteger i)) <- o3, 0 <= i, i < 64 ->
- lines_ [text "\tslli.d" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3]
- | OpReg W64 _ <- o1, OpReg W64 _ <- o2, (OpImm (ImmInt i)) <- o3, 0 <= i, i < 64 ->
+ | OpReg W64 _ <- o2, isImmOp o3 ->
lines_ [text "\tslli.d" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3]
| otherwise -> pprPanic "LA64.ppr: SLL error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)
SRL o1 o2 o3
- | OpReg W64 _ <- o1, OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tsrl.w") o1 o2 o3
- | OpReg W64 _ <- o1, OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tsrl.d") o1 o2 o3
- | OpReg W64 _ <- o1, OpReg W32 _ <- o2, (OpImm (ImmInteger i)) <- o3, 0 <= i, i < 32 ->
- lines_ [text "\tsrli.w" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3]
- | OpReg W64 _ <- o1, OpReg W32 _ <- o2, (OpImm (ImmInt i)) <- o3, 0 <= i, i < 32 ->
+ | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tsrl.w") o1 o2 o3
+ | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tsrl.d") o1 o2 o3
+ | OpReg W32 _ <- o2, isImmOp o3 ->
lines_ [text "\tsrli.w" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3]
- | OpReg W64 _ <- o1, OpReg W64 _ <- o2, (OpImm (ImmInteger i)) <- o3, 0 <= i, i < 64 ->
- lines_ [text "\tsrli.d" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3]
- | OpReg W64 _ <- o1, OpReg W64 _ <- o2, (OpImm (ImmInt i)) <- o3, 0 <= i, i < 64 ->
+ | OpReg W64 _ <- o2, isImmOp o3 ->
lines_ [text "\tsrli.d" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3]
| otherwise -> pprPanic "LA64.ppr: SRL error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)
SRA o1 o2 o3
- | OpReg W64 _ <- o1, OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tsra.w") o1 o2 o3
- | OpReg W64 _ <- o1, OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tsra.d") o1 o2 o3
- | OpReg W64 _ <- o1, OpReg W32 _ <- o2, (OpImm (ImmInteger i)) <- o3, 0 <= i, i < 32 ->
- lines_ [text "\tsrai.w" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3]
- | OpReg W64 _ <- o1, OpReg W32 _ <- o2, (OpImm (ImmInt i)) <- o3, 0 <= i, i < 32 ->
+ | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tsra.w") o1 o2 o3
+ | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tsra.d") o1 o2 o3
+ | OpReg W32 _ <- o2, isImmOp o3 ->
lines_ [text "\tsrai.w" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3]
- | OpReg W64 _ <- o1, OpReg W64 _ <- o2, (OpImm (ImmInteger i)) <- o3, 0 <= i, i < 64 ->
- lines_ [text "\tsrai.d" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3]
- | OpReg W64 _ <- o1, OpReg W64 _ <- o2, (OpImm (ImmInt i)) <- o3, 0 <= i, i < 64 ->
+ | OpReg W64 _ <- o2, isImmOp o3 ->
lines_ [text "\tsrai.d" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3]
| otherwise -> pprPanic "LA64.ppr: SRA error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)
ROTR o1 o2 o3
- | OpReg W64 _ <- o1, OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\trotr.w") o1 o2 o3
- | OpReg W64 _ <- o1, OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\trotr.d") o1 o2 o3
- | OpReg W64 _ <- o1, OpReg W32 _ <- o2, (OpImm (ImmInteger i)) <- o3, 0 <= i, i < 32 ->
- lines_ [text "\trotri.w" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3]
- | OpReg W64 _ <- o1, OpReg W32 _ <- o2, (OpImm (ImmInt i)) <- o3, 0 <= i, i < 32 ->
+ | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\trotr.w") o1 o2 o3
+ | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\trotr.d") o1 o2 o3
+ | OpReg W32 _ <- o2, isImmOp o3 ->
lines_ [text "\trotri.w" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3]
- | OpReg W64 _ <- o1, OpReg W64 _ <- o2, (OpImm (ImmInteger i)) <- o3, 0 <= i, i < 64 ->
- lines_ [text "\trotri.d" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3]
- | OpReg W64 _ <- o1, OpReg W64 _ <- o2, (OpImm (ImmInt i)) <- o3, 0 <= i, i < 64 ->
+ | OpReg W64 _ <- o2, isImmOp o3 ->
lines_ [text "\trotri.d" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3]
| otherwise -> pprPanic "LA64.ppr: ROTR error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)
-- 3. Bit-manupulation Instructions ------------------------------------------
-- EXT.W{B/H}
EXT o1 o2
- | OpReg W64 _ <- o1, OpReg W8 _ <- o2 -> op2 (text "\text.w.b") o1 o2
- | OpReg W64 _ <- o1, OpReg W16 _ <- o2 -> op2 (text "\text.w.h") o1 o2
+ | OpReg W8 _ <- o2 -> op2 (text "\text.w.b") o1 o2
+ | OpReg W16 _ <- o2 -> op2 (text "\text.w.h") o1 o2
| otherwise -> pprPanic "LA64.ppr: EXT error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2)
-- CL{O/Z}.{W/D}, CT{O/Z}.{W/D}
CLO o1 o2
@@ -823,8 +787,8 @@ pprInstr platform instr = case instr of
| otherwise -> pprPanic "LA64.ppr: CTZ error" (pprOp platform o1 <+> pprOp platform o2)
-- BYTEPICK.{W/D} rd, rj, rk, sa2/sa3
BYTEPICK o1 o2 o3 o4
- | OpReg W64 _ <- o1, OpReg W32 _ <- o2 -> op4 (text "\tbytepick.w") o1 o2 o3 o4
- | OpReg W64 _ <- o1, OpReg W64 _ <- o2 -> op4 (text "\tbytepick.d") o1 o2 o3 o4
+ | OpReg W32 _ <- o2 -> op4 (text "\tbytepick.w") o1 o2 o3 o4
+ | OpReg W64 _ <- o2 -> op4 (text "\tbytepick.d") o1 o2 o3 o4
| otherwise -> pprPanic "LA64.ppr: BYTEPICK error" (pprOp platform o1 <+> pprOp platform o2 <+> pprOp platform o3 <+> pprOp platform o4)
-- REVB.{2H/4H/2W/D}
REVB2H o1 o2 -> op2 (text "\trevb.2h") o1 o2
@@ -857,7 +821,7 @@ pprInstr platform instr = case instr of
-- BL
-- JIRL
-- jr rd = jirl $zero, rd, 0: Commonly used for subroutine return.
- J (TReg r) -> line $ text "\tjirl" <+> text "$r1" <> comma <+> pprReg W64 r <> comma <+> text " 0"
+ J (TReg r) -> line $ text "\tjirl" <+> text "$r0" <> comma <+> pprReg W64 r <> comma <+> text " 0"
J_TBL _ _ r -> pprInstr platform (B (TReg r))
B (TBlock bid) -> line $ text "\tb" <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))
@@ -868,71 +832,89 @@ pprInstr platform instr = case instr of
BL (TLabel lbl) _ -> line $ text "\tbl" <+> pprAsmLabel platform lbl
BL (TReg r) _ -> line $ text "\tjirl" <+> text "$r1" <> comma <+> pprReg W64 r <> comma <+> text " 0"
+ CALL (TBlock bid) _ -> line $ text "\tcall36" <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))
+ CALL (TLabel lbl) _ -> line $ text "\tcall36" <+> pprAsmLabel platform lbl
+ CALL (TReg r) _ -> line $ text "\tjirl" <+> text "$r1" <> comma <+> pprReg W64 r <> comma <+> text " 0"
+
CALL36 (TBlock bid) -> line $ text "\tcall36" <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))
CALL36 (TLabel lbl) -> line $ text "\tcall36" <+> pprAsmLabel platform lbl
- CALL36 _ -> panic "LA64.ppr: CALL36: Unexpected pattern!"
+ CALL36 _ -> panic "LA64.ppr: CALL36: Not to registers!"
TAIL36 r (TBlock bid) -> line $ text "\ttail36" <+> pprOp platform r <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))
TAIL36 r (TLabel lbl) -> line $ text "\ttail36" <+> pprOp platform r <> comma <+> pprAsmLabel platform lbl
- TAIL36 _ _ -> panic "LA64.ppr: TAIL36: Unexpected pattern!"
+ TAIL36 _ _ -> panic "LA64.ppr: TAIL36: Not to registers!"
- BCOND c j d (TLabel lbl) _t -> case c of
- _ -> line $ text "\t" <> pprBcond c <+> pprOp platform j <> comma <+> pprOp platform d <> comma <+> pprAsmLabel platform lbl
+ BCOND1 c j d (TBlock bid) -> case c of
+ SLE ->
+ line $ text "\tbge" <+> pprOp platform d <> comma <+> pprOp platform j <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))
+ SGT ->
+ line $ text "\tblt" <+> pprOp platform d <> comma <+> pprOp platform j <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))
+ ULE ->
+ line $ text "\tbgeu" <+> pprOp platform d <> comma <+> pprOp platform j <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))
+ UGT ->
+ line $ text "\tbltu" <+> pprOp platform d <> comma <+> pprOp platform j <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))
+ _ -> line $ text "\t" <> pprBcond c <+> pprOp platform j <> comma <+> pprOp platform d <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))
- BCOND c j d (TBlock bid) t -> case c of
+ BCOND1 _ _ _ (TLabel _) -> panic "LA64.ppr: BCOND1: No conditional branching to TLabel!"
+
+ BCOND1 _ _ _ (TReg _) -> panic "LA64.ppr: BCOND1: No conditional branching to registers!"
+
+ -- Reuse t8(IP) register
+ BCOND c j d (TBlock bid) -> case c of
SLE ->
lines_ [
- text "\tslt" <+> pprOp platform t <> comma <+> pprOp platform d <> comma <+> pprOp platform j,
- text "\tbeqz" <+> pprOp platform t <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))
+ text "\tslt $t8, " <+> pprOp platform d <> comma <+> pprOp platform j,
+ text "\tbeqz $t8, " <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))
]
SGT ->
lines_ [
- text "\tslt" <+> pprOp platform t <> comma <+> pprOp platform d <> comma <+> pprOp platform j,
- text "\tbnez" <+> pprOp platform t <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))
+ text "\tslt $t8, " <+> pprOp platform d <> comma <+> pprOp platform j,
+ text "\tbnez $t8, " <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))
]
ULE ->
lines_ [
- text "\tsltu" <+> pprOp platform t <> comma <+> pprOp platform d <> comma <+> pprOp platform j,
- text "\tbeqz" <+> pprOp platform t <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))
+ text "\tsltu $t8, " <+> pprOp platform d <> comma <+> pprOp platform j,
+ text "\tbeqz $t8, " <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))
]
UGT ->
lines_ [
- text "\tsltu" <+> pprOp platform t <> comma <+> pprOp platform d <> comma <+> pprOp platform j,
- text "\tbnez" <+> pprOp platform t <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))
+ text "\tsltu $t8, " <+> pprOp platform d <> comma <+> pprOp platform j,
+ text "\tbnez $t8, " <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))
]
EQ ->
lines_ [
- text "\tsub.d" <+> pprOp platform t <> comma <+> pprOp platform j <> comma <+> pprOp platform d,
- text "\tbeqz" <+> pprOp platform t <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))
+ text "\tsub.d $t8, " <+> pprOp platform j <> comma <+> pprOp platform d,
+ text "\tbeqz $t8, " <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))
]
NE ->
lines_ [
- text "\tsub.d" <+> pprOp platform t <> comma <+> pprOp platform j <> comma <+> pprOp platform d,
- text "\tbnez" <+> pprOp platform t <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))
+ text "\tsub.d $t8, " <+> pprOp platform j <> comma <+> pprOp platform d,
+ text "\tbnez $t8, " <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))
]
SLT ->
lines_ [
- text "\tslt" <+> pprOp platform t <> comma <+> pprOp platform j <> comma <+> pprOp platform d,
- text "\tbnez" <+> pprOp platform t <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))
+ text "\tslt $t8, " <+> pprOp platform j <> comma <+> pprOp platform d,
+ text "\tbnez $t8, " <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))
]
SGE ->
lines_ [
- text "\tslt" <+> pprOp platform t <> comma <+> pprOp platform j <> comma <+> pprOp platform d,
- text "\tbeqz" <+> pprOp platform t <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))
+ text "\tslt $t8, " <+> pprOp platform j <> comma <+> pprOp platform d,
+ text "\tbeqz $t8, " <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))
]
ULT ->
lines_ [
- text "\tsltu" <+> pprOp platform t <> comma <+> pprOp platform j <> comma <+> pprOp platform d,
- text "\tbnez" <+> pprOp platform t <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))
+ text "\tsltu $t8, " <+> pprOp platform j <> comma <+> pprOp platform d,
+ text "\tbnez $t8, " <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))
]
UGE ->
lines_ [
- text "\tsltu" <+> pprOp platform t <> comma <+> pprOp platform j <> comma <+> pprOp platform d,
- text "\tbeqz" <+> pprOp platform t <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))
+ text "\tsltu $t8, " <+> pprOp platform j <> comma <+> pprOp platform d,
+ text "\tbeqz $t8, " <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))
]
+ _ -> panic "LA64.ppr: BCOND: Unsupported cond!"
- _ -> line $ text "\t" <> pprBcond c <+> pprOp platform j <> comma <+> pprOp platform d <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))
+ BCOND _ _ _ (TLabel _) -> panic "LA64.ppr: BCOND: No conditional branching to TLabel!"
- BCOND _ _ _ (TReg _) _ -> panic "LA64.ppr: BCOND: No conditional branching to registers!"
+ BCOND _ _ _ (TReg _) -> panic "LA64.ppr: BCOND: No conditional branching to registers!"
BEQZ j (TBlock bid) ->
line $ text "\tbeqz" <+> pprOp platform j <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))
@@ -951,12 +933,34 @@ pprInstr platform instr = case instr of
-- LD: load, ST: store, x: offset in register, u: load unsigned imm.
-- LD format dst src: 'src' means final address, not single register or immdiate.
-- Load symbol's address
+ LD _fmt o1 (OpImm (ImmIndex lbl' off)) | Just (_, lbl) <- dynamicLinkerLabelInfo lbl' ->
+ lines_ [ text "\tpcalau12i" <+> pprOp platform o1 <> comma <+> text "%got_pc_hi20(" <> pprAsmLabel platform lbl <> text ")"
+ , text "\tld.d" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> text "%got_pc_lo12(" <> pprAsmLabel platform lbl <> text ")"
+ , text "\taddi.d" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> int off
+ ]
+ LD _fmt o1 (OpImm (ImmIndex lbl off)) | isForeignLabel lbl ->
+ lines_ [ text "\tpcalau12i" <+> pprOp platform o1 <> comma <+> text "%got_pc_hi20(" <> pprAsmLabel platform lbl <> text ")"
+ , text "\tld.d" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> text "%got_pc_lo12(" <> pprAsmLabel platform lbl <> text ")"
+ , text "\taddi.d" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> int off
+ ]
LD _fmt o1 (OpImm (ImmIndex lbl off)) ->
- lines_ [ text "\tla.global" <+> pprOp platform o1 <> comma <+> pprAsmLabel platform lbl
- , text "\taddi.d" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> int off
+ lines_ [ text "\tpcalau12i" <+> pprOp platform o1 <> comma <+> text "%pc_hi20(" <> pprAsmLabel platform lbl <> text ")"
+ , text "\taddi.d" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> text "%pc_lo12(" <> pprAsmLabel platform lbl <> text ")"
+ , text "\taddi.d" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> int off
+ ]
+
+ LD _fmt o1 (OpImm (ImmCLbl lbl')) | Just (_, lbl) <- dynamicLinkerLabelInfo lbl' ->
+ lines_ [ text "\tpcalau12i" <+> pprOp platform o1 <> comma <+> text "%got_pc_hi20(" <> pprAsmLabel platform lbl <> text ")"
+ , text "\tld.d" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> text "%got_pc_lo12(" <> pprAsmLabel platform lbl <> text ")"
+ ]
+ LD _fmt o1 (OpImm (ImmCLbl lbl)) | isForeignLabel lbl ->
+ lines_ [ text "\tpcalau12i" <+> pprOp platform o1 <> comma <+> text "%got_pc_hi20(" <> pprAsmLabel platform lbl <> text ")"
+ , text "\tld.d" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> text "%got_pc_lo12(" <> pprAsmLabel platform lbl <> text ")"
]
LD _fmt o1 (OpImm (ImmCLbl lbl)) ->
- line $ text "\tla.global" <+> pprOp platform o1 <> comma <+> pprAsmLabel platform lbl
+ lines_ [ text "\tpcalau12i" <+> pprOp platform o1 <> comma <+> text "%pc_hi20(" <> pprAsmLabel platform lbl <> text ")"
+ , text "\taddi.d" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> text "%pc_lo12(" <> pprAsmLabel platform lbl <> text ")"
+ ]
LD II8 o1 o2 -> op2 (text "\tld.b") o1 o2
LD II16 o1 o2 -> op2 (text "\tld.h") o1 o2
@@ -1005,6 +1009,8 @@ pprInstr platform instr = case instr of
STX II64 o1 o2 -> op2 (text "\tstx.d") o1 o2
STX FF32 o1 o2 -> op2 (text "\tfstx.s") o1 o2
STX FF64 o1 o2 -> op2 (text "\tfstx.d") o1 o2
+
+ PRELD h o1@(OpAddr (AddrRegImm _ _)) -> op2 (text "\tpreld") h o1
-- 6. Bound Check Memory Access Instructions ---------------------------------
-- LD{GT/LE}.{B/H/W/D}, ST{GT/LE}.{B/H/W/D}
-- 7. Atomic Memory Access Instructions --------------------------------------
@@ -1092,6 +1098,7 @@ pprInstr platform instr = case instr of
FMAXA o1 o2 o3 -> op3 (text "fmaxa." <> if isSingleOp o2 then text "s" else text "d") o1 o2 o3
FABS o1 o2 -> op2 (text "fabs." <> if isSingleOp o2 then text "s" else text "d") o1 o2
FNEG o1 o2 -> op2 (text "fneg." <> if isSingleOp o2 then text "s" else text "d") o1 o2
+ FSQRT o1 o2 -> op2 (text "fsqrt." <> if isSingleOp o2 then text "s" else text "d") o1 o2
FMA variant d o1 o2 o3 ->
let fma = case variant of
FMAdd -> text "\tfmadd." <+> floatPrecission d
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/537bd233635df7304239e0e6084d683…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/537bd233635df7304239e0e6084d683…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
12 Jun '25
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
6d12060f by meooow25 at 2025-06-12T14:26:07-04:00
Bump containers submodule to 0.8
Also
* Disable -Wunused-imports for containers
* Allow containers-0.8 for in-tree packages
* Bump some submodules so that they allow containers-0.8. These are not
at any particular versions.
* Remove unused deps containers and split from ucd2haskell
* Fix tests affected by the new containers and hpc-bin
- - - - -
21 changed files:
- compiler/ghc.cabal.in
- ghc/ghc-bin.cabal.in
- hadrian/hadrian.cabal
- hadrian/src/Settings/Warnings.hs
- libraries/containers
- libraries/ghc-boot/ghc-boot.cabal.in
- libraries/ghc-heap/ghc-heap.cabal.in
- libraries/ghc-internal/tools/ucd2haskell/ucd2haskell.cabal
- libraries/ghci/ghci.cabal.in
- libraries/haskeline
- libraries/hpc
- testsuite/tests/hpc/fork/hpc_fork.stdout
- testsuite/tests/hpc/function/tough.stdout
- testsuite/tests/hpc/function2/tough2.stdout
- testsuite/tests/hpc/simple/hpc001.stdout
- testsuite/tests/partial-sigs/should_fail/T10999.stderr
- testsuite/tests/rebindable/DoRestrictedM.hs
- utils/haddock/haddock-library/haddock-library.cabal
- utils/hpc
- utils/hsc2hs
- utils/iserv/iserv.cabal.in
Changes:
=====================================
compiler/ghc.cabal.in
=====================================
@@ -121,7 +121,7 @@ Library
bytestring >= 0.11 && < 0.13,
binary == 0.8.*,
time >= 1.4 && < 1.15,
- containers >= 0.6.2.1 && < 0.8,
+ containers >= 0.6.2.1 && < 0.9,
array >= 0.1 && < 0.6,
filepath >= 1.5 && < 1.6,
os-string >= 2.0.1 && < 2.1,
=====================================
ghc/ghc-bin.cabal.in
=====================================
@@ -40,7 +40,7 @@ Executable ghc
directory >= 1 && < 1.4,
process >= 1 && < 1.7,
filepath >= 1.5 && < 1.6,
- containers >= 0.5 && < 0.8,
+ containers >= 0.5 && < 0.9,
transformers >= 0.5 && < 0.7,
ghc-boot == @ProjectVersionMunged@,
ghc == @ProjectVersionMunged@
=====================================
hadrian/hadrian.cabal
=====================================
@@ -156,7 +156,7 @@ executable hadrian
build-depends: Cabal >= 3.13 && < 3.15
, base >= 4.11 && < 5
, bytestring >= 0.10 && < 0.13
- , containers >= 0.5 && < 0.8
+ , containers >= 0.5 && < 0.9
-- N.B. directory >=1.3.9 as earlier versions are
-- afflicted by #24382.
, directory >= 1.3.9.0 && < 1.4
=====================================
hadrian/src/Settings/Warnings.hs
=====================================
@@ -90,4 +90,6 @@ ghcWarningsArgs = do
, "-Wno-deprecations" -- https://gitlab.haskell.org/ghc/ghc/-/issues/24240
, "-Wno-deriving-typeable"
]
- , package xhtml ? pure [ "-Wno-unused-imports" ] ] ]
+ , package xhtml ? pure [ "-Wno-unused-imports" ]
+ , package containers ? pure [ "-Wno-unused-imports" ]
+ ] ]
=====================================
libraries/containers
=====================================
@@ -1 +1 @@
-Subproject commit 4fda06c43ea14f808748aa8988158946c3ce0caf
+Subproject commit 801b06e5d4392b028e519d5ca116a2881d559721
=====================================
libraries/ghc-boot/ghc-boot.cabal.in
=====================================
@@ -78,7 +78,7 @@ Library
build-depends: base >= 4.7 && < 4.22,
binary == 0.8.*,
bytestring >= 0.10 && < 0.13,
- containers >= 0.5 && < 0.8,
+ containers >= 0.5 && < 0.9,
directory >= 1.2 && < 1.4,
filepath >= 1.3 && < 1.6,
deepseq >= 1.4 && < 1.6,
=====================================
libraries/ghc-heap/ghc-heap.cabal.in
=====================================
@@ -25,7 +25,7 @@ library
build-depends: base >= 4.9.0 && < 5.0
, ghc-prim > 0.2 && < 0.14
, rts == 1.0.*
- , containers >= 0.6.2.1 && < 0.8
+ , containers >= 0.6.2.1 && < 0.9
if impl(ghc >= 9.9)
build-depends: ghc-internal >= 9.900 && < @ProjectVersionForLib@.99999
=====================================
libraries/ghc-internal/tools/ucd2haskell/ucd2haskell.cabal
=====================================
@@ -54,9 +54,7 @@ executable ucd2haskell
build-depends:
base >= 4.7 && < 5
, bytestring >= 0.11 && < 0.13
- , containers >= 0.5 && < 0.7
, directory >= 1.3.6 && < 1.3.8
, filepath >= 1.4.2 && < 1.5
, getopt-generics >= 0.13 && < 0.14
- , split >= 0.2.3 && < 0.3
, unicode-data-parser >= 0.2.0 && < 0.4
=====================================
libraries/ghci/ghci.cabal.in
=====================================
@@ -93,7 +93,7 @@ library
ghc-prim >= 0.5.0 && < 0.14,
binary == 0.8.*,
bytestring >= 0.10 && < 0.13,
- containers >= 0.5 && < 0.8,
+ containers >= 0.5 && < 0.9,
deepseq >= 1.4 && < 1.6,
filepath >= 1.4 && < 1.6,
ghc-boot == @ProjectVersionMunged@,
=====================================
libraries/haskeline
=====================================
@@ -1 +1 @@
-Subproject commit 5f1a790a5db1cb3708d105d4f532c32fcbeb4296
+Subproject commit 1ef56b16d3ed1f063211982668329d9e3113fd5b
=====================================
libraries/hpc
=====================================
@@ -1 +1 @@
-Subproject commit 9e29abb785ab4f82c37c7a4e73ec999083955b09
+Subproject commit 304aaecec374fdfbf15bfb6c223a66e9730ea253
=====================================
testsuite/tests/hpc/fork/hpc_fork.stdout
=====================================
@@ -63,62 +63,26 @@ td.invbar { background-color: #f25913; }
table.dashboard { border-collapse: collapse ; border: solid 1px black }
.dashboard td { border: solid 1px black }
.dashboard th { border: solid 1px black }
-</style>
-</head><body><table class="dashboard" width="100%" border=1>
-<tr><th rowspan=2><a href="hpc_index.html">module</a></th><th colspan=3><a href="hpc_index_fun.html">Top Level Definitions</a></th><th colspan=3><a href="hpc_index_alt.html">Alternatives</a></th><th colspan=3><a href="hpc_index_exp.html">Expressions</a></th></tr><tr><th>%</th><th colspan=2>covered / total</th><th>%</th><th colspan=2>covered / total</th><th>%</th><th colspan=2>covered / total</th></tr><tr>
-<td> <tt>module <a href="Main.hs.html">Main</a></tt></td>
-<td align="right">100%</td><td>1/1</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="100%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">- </td><td>0/0</td><td width=100> </td><td align="right">60%</td><td>9/15</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="60%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
-<tr></tr><tr style="background: #e0e0e0">
-<th align=left> Program Coverage Total</tt></th>
-<td align="right">100%</td><td>1/1</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="100%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">- </td><td>0/0</td><td width=100> </td><td align="right">60%</td><td>9/15</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="60%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
-</table></body></html>
-Writing: hpc_index_fun.html
+</style></head><body><table class="dashboard" width="100%" border="1"><tr><th rowspan="2"><a href="hpc_index.html">module</a></th><th colspan="3"><a href="hpc_index_fun.html">Top Level Definitions</a></th><th colspan="3"><a href="hpc_index_alt.html">Alternatives</a></th><th colspan="3"><a href="hpc_index_exp.html">Expressions</a></th></tr><tr><th>%</th><th colspan="2">covered / total</th><th>%</th><th colspan="2">covered / total</th><th>%</th><th colspan="2">covered / total</th></tr><tr><td> <code>module <a href="Main.hs.html">Main</a></code></td><td align="right">100%</td><td>1/1</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="100%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">- </td><td>0/0</td><td width="100"> </td><td align="right">60%</td><td>9/15</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="60%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td></tr><tr></tr><tr style="background: #e0e0e0"><th align="left"> Program Coverage Total</th><td align="right">100%</td><td>1/1</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="100%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">- </td><td>0/0</td><td width="100"> </td><td align="right">60%</td><td>9/15</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="60%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td></tr></table></body></html>Writing: hpc_index_fun.html
<html><head><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"><style type="text/css">table.bar { background-color: #f25913; }
td.bar { background-color: #60de51; }
td.invbar { background-color: #f25913; }
table.dashboard { border-collapse: collapse ; border: solid 1px black }
.dashboard td { border: solid 1px black }
.dashboard th { border: solid 1px black }
-</style>
-</head><body><table class="dashboard" width="100%" border=1>
-<tr><th rowspan=2><a href="hpc_index.html">module</a></th><th colspan=3><a href="hpc_index_fun.html">Top Level Definitions</a></th><th colspan=3><a href="hpc_index_alt.html">Alternatives</a></th><th colspan=3><a href="hpc_index_exp.html">Expressions</a></th></tr><tr><th>%</th><th colspan=2>covered / total</th><th>%</th><th colspan=2>covered / total</th><th>%</th><th colspan=2>covered / total</th></tr><tr>
-<td> <tt>module <a href="Main.hs.html">Main</a></tt></td>
-<td align="right">100%</td><td>1/1</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="100%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">- </td><td>0/0</td><td width=100> </td><td align="right">60%</td><td>9/15</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="60%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
-<tr></tr><tr style="background: #e0e0e0">
-<th align=left> Program Coverage Total</tt></th>
-<td align="right">100%</td><td>1/1</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="100%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">- </td><td>0/0</td><td width=100> </td><td align="right">60%</td><td>9/15</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="60%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
-</table></body></html>
-Writing: hpc_index_alt.html
+</style></head><body><table class="dashboard" width="100%" border="1"><tr><th rowspan="2"><a href="hpc_index.html">module</a></th><th colspan="3"><a href="hpc_index_fun.html">Top Level Definitions</a></th><th colspan="3"><a href="hpc_index_alt.html">Alternatives</a></th><th colspan="3"><a href="hpc_index_exp.html">Expressions</a></th></tr><tr><th>%</th><th colspan="2">covered / total</th><th>%</th><th colspan="2">covered / total</th><th>%</th><th colspan="2">covered / total</th></tr><tr><td> <code>module <a href="Main.hs.html">Main</a></code></td><td align="right">100%</td><td>1/1</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="100%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">- </td><td>0/0</td><td width="100"> </td><td align="right">60%</td><td>9/15</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="60%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td></tr><tr></tr><tr style="background: #e0e0e0"><th align="left"> Program Coverage Total</th><td align="right">100%</td><td>1/1</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="100%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">- </td><td>0/0</td><td width="100"> </td><td align="right">60%</td><td>9/15</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="60%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td></tr></table></body></html>Writing: hpc_index_alt.html
<html><head><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"><style type="text/css">table.bar { background-color: #f25913; }
td.bar { background-color: #60de51; }
td.invbar { background-color: #f25913; }
table.dashboard { border-collapse: collapse ; border: solid 1px black }
.dashboard td { border: solid 1px black }
.dashboard th { border: solid 1px black }
-</style>
-</head><body><table class="dashboard" width="100%" border=1>
-<tr><th rowspan=2><a href="hpc_index.html">module</a></th><th colspan=3><a href="hpc_index_fun.html">Top Level Definitions</a></th><th colspan=3><a href="hpc_index_alt.html">Alternatives</a></th><th colspan=3><a href="hpc_index_exp.html">Expressions</a></th></tr><tr><th>%</th><th colspan=2>covered / total</th><th>%</th><th colspan=2>covered / total</th><th>%</th><th colspan=2>covered / total</th></tr><tr>
-<td> <tt>module <a href="Main.hs.html">Main</a></tt></td>
-<td align="right">100%</td><td>1/1</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="100%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">- </td><td>0/0</td><td width=100> </td><td align="right">60%</td><td>9/15</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="60%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
-<tr></tr><tr style="background: #e0e0e0">
-<th align=left> Program Coverage Total</tt></th>
-<td align="right">100%</td><td>1/1</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="100%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">- </td><td>0/0</td><td width=100> </td><td align="right">60%</td><td>9/15</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="60%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
-</table></body></html>
-Writing: hpc_index_exp.html
+</style></head><body><table class="dashboard" width="100%" border="1"><tr><th rowspan="2"><a href="hpc_index.html">module</a></th><th colspan="3"><a href="hpc_index_fun.html">Top Level Definitions</a></th><th colspan="3"><a href="hpc_index_alt.html">Alternatives</a></th><th colspan="3"><a href="hpc_index_exp.html">Expressions</a></th></tr><tr><th>%</th><th colspan="2">covered / total</th><th>%</th><th colspan="2">covered / total</th><th>%</th><th colspan="2">covered / total</th></tr><tr><td> <code>module <a href="Main.hs.html">Main</a></code></td><td align="right">100%</td><td>1/1</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="100%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">- </td><td>0/0</td><td width="100"> </td><td align="right">60%</td><td>9/15</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="60%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td></tr><tr></tr><tr style="background: #e0e0e0"><th align="left"> Program Coverage Total</th><td align="right">100%</td><td>1/1</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="100%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">- </td><td>0/0</td><td width="100"> </td><td align="right">60%</td><td>9/15</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="60%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td></tr></table></body></html>Writing: hpc_index_exp.html
<html><head><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"><style type="text/css">table.bar { background-color: #f25913; }
td.bar { background-color: #60de51; }
td.invbar { background-color: #f25913; }
table.dashboard { border-collapse: collapse ; border: solid 1px black }
.dashboard td { border: solid 1px black }
.dashboard th { border: solid 1px black }
-</style>
-</head><body><table class="dashboard" width="100%" border=1>
-<tr><th rowspan=2><a href="hpc_index.html">module</a></th><th colspan=3><a href="hpc_index_fun.html">Top Level Definitions</a></th><th colspan=3><a href="hpc_index_alt.html">Alternatives</a></th><th colspan=3><a href="hpc_index_exp.html">Expressions</a></th></tr><tr><th>%</th><th colspan=2>covered / total</th><th>%</th><th colspan=2>covered / total</th><th>%</th><th colspan=2>covered / total</th></tr><tr>
-<td> <tt>module <a href="Main.hs.html">Main</a></tt></td>
-<td align="right">100%</td><td>1/1</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="100%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">- </td><td>0/0</td><td width=100> </td><td align="right">60%</td><td>9/15</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="60%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
-<tr></tr><tr style="background: #e0e0e0">
-<th align=left> Program Coverage Total</tt></th>
-<td align="right">100%</td><td>1/1</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="100%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">- </td><td>0/0</td><td width=100> </td><td align="right">60%</td><td>9/15</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="60%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
-</table></body></html>
-
+</style></head><body><table class="dashboard" width="100%" border="1"><tr><th rowspan="2"><a href="hpc_index.html">module</a></th><th colspan="3"><a href="hpc_index_fun.html">Top Level Definitions</a></th><th colspan="3"><a href="hpc_index_alt.html">Alternatives</a></th><th colspan="3"><a href="hpc_index_exp.html">Expressions</a></th></tr><tr><th>%</th><th colspan="2">covered / total</th><th>%</th><th colspan="2">covered / total</th><th>%</th><th colspan="2">covered / total</th></tr><tr><td> <code>module <a href="Main.hs.html">Main</a></code></td><td align="right">100%</td><td>1/1</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="100%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">- </td><td>0/0</td><td width="100"> </td><td align="right">60%</td><td>9/15</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="60%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td></tr><tr></tr><tr style="background: #e0e0e0"><th align="left"> Program Coverage Total</th><td align="right">100%</td><td>1/1</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="100%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">- </td><td>0/0</td><td width="100"> </td><td align="right">60%</td><td>9/15</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="60%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td></tr></table></body></html>
=====================================
testsuite/tests/hpc/function/tough.stdout
=====================================
@@ -106,62 +106,26 @@ td.invbar { background-color: #f25913; }
table.dashboard { border-collapse: collapse ; border: solid 1px black }
.dashboard td { border: solid 1px black }
.dashboard th { border: solid 1px black }
-</style>
-</head><body><table class="dashboard" width="100%" border=1>
-<tr><th rowspan=2><a href="hpc_index.html">module</a></th><th colspan=3><a href="hpc_index_fun.html">Top Level Definitions</a></th><th colspan=3><a href="hpc_index_alt.html">Alternatives</a></th><th colspan=3><a href="hpc_index_exp.html">Expressions</a></th></tr><tr><th>%</th><th colspan=2>covered / total</th><th>%</th><th colspan=2>covered / total</th><th>%</th><th colspan=2>covered / total</th></tr><tr>
-<td> <tt>module <a href="Main.hs.html">Main</a></tt></td>
-<td align="right">83%</td><td>5/6</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="83%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">58%</td><td>7/12</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="58%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">73%</td><td>73/100</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="73%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
-<tr></tr><tr style="background: #e0e0e0">
-<th align=left> Program Coverage Total</tt></th>
-<td align="right">83%</td><td>5/6</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="83%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">58%</td><td>7/12</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="58%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">73%</td><td>73/100</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="73%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
-</table></body></html>
-Writing: hpc_index_fun.html
+</style></head><body><table class="dashboard" width="100%" border="1"><tr><th rowspan="2"><a href="hpc_index.html">module</a></th><th colspan="3"><a href="hpc_index_fun.html">Top Level Definitions</a></th><th colspan="3"><a href="hpc_index_alt.html">Alternatives</a></th><th colspan="3"><a href="hpc_index_exp.html">Expressions</a></th></tr><tr><th>%</th><th colspan="2">covered / total</th><th>%</th><th colspan="2">covered / total</th><th>%</th><th colspan="2">covered / total</th></tr><tr><td> <code>module <a href="Main.hs.html">Main</a></code></td><td align="right">83%</td><td>5/6</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="83%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">58%</td><td>7/12</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="58%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">73%</td><td>73/100</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="73%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td></tr><tr></tr><tr style="background: #e0e0e0"><th align="left"> Program Coverage Total</th><td align="right">83%</td><td>5/6</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="83%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">58%</td><td>7/12</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="58%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">73%</td><td>73/100</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="73%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td></tr></table></body></html>Writing: hpc_index_fun.html
<html><head><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"><style type="text/css">table.bar { background-color: #f25913; }
td.bar { background-color: #60de51; }
td.invbar { background-color: #f25913; }
table.dashboard { border-collapse: collapse ; border: solid 1px black }
.dashboard td { border: solid 1px black }
.dashboard th { border: solid 1px black }
-</style>
-</head><body><table class="dashboard" width="100%" border=1>
-<tr><th rowspan=2><a href="hpc_index.html">module</a></th><th colspan=3><a href="hpc_index_fun.html">Top Level Definitions</a></th><th colspan=3><a href="hpc_index_alt.html">Alternatives</a></th><th colspan=3><a href="hpc_index_exp.html">Expressions</a></th></tr><tr><th>%</th><th colspan=2>covered / total</th><th>%</th><th colspan=2>covered / total</th><th>%</th><th colspan=2>covered / total</th></tr><tr>
-<td> <tt>module <a href="Main.hs.html">Main</a></tt></td>
-<td align="right">83%</td><td>5/6</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="83%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">58%</td><td>7/12</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="58%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">73%</td><td>73/100</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="73%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
-<tr></tr><tr style="background: #e0e0e0">
-<th align=left> Program Coverage Total</tt></th>
-<td align="right">83%</td><td>5/6</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="83%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">58%</td><td>7/12</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="58%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">73%</td><td>73/100</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="73%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
-</table></body></html>
-Writing: hpc_index_alt.html
+</style></head><body><table class="dashboard" width="100%" border="1"><tr><th rowspan="2"><a href="hpc_index.html">module</a></th><th colspan="3"><a href="hpc_index_fun.html">Top Level Definitions</a></th><th colspan="3"><a href="hpc_index_alt.html">Alternatives</a></th><th colspan="3"><a href="hpc_index_exp.html">Expressions</a></th></tr><tr><th>%</th><th colspan="2">covered / total</th><th>%</th><th colspan="2">covered / total</th><th>%</th><th colspan="2">covered / total</th></tr><tr><td> <code>module <a href="Main.hs.html">Main</a></code></td><td align="right">83%</td><td>5/6</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="83%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">58%</td><td>7/12</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="58%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">73%</td><td>73/100</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="73%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td></tr><tr></tr><tr style="background: #e0e0e0"><th align="left"> Program Coverage Total</th><td align="right">83%</td><td>5/6</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="83%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">58%</td><td>7/12</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="58%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">73%</td><td>73/100</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="73%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td></tr></table></body></html>Writing: hpc_index_alt.html
<html><head><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"><style type="text/css">table.bar { background-color: #f25913; }
td.bar { background-color: #60de51; }
td.invbar { background-color: #f25913; }
table.dashboard { border-collapse: collapse ; border: solid 1px black }
.dashboard td { border: solid 1px black }
.dashboard th { border: solid 1px black }
-</style>
-</head><body><table class="dashboard" width="100%" border=1>
-<tr><th rowspan=2><a href="hpc_index.html">module</a></th><th colspan=3><a href="hpc_index_fun.html">Top Level Definitions</a></th><th colspan=3><a href="hpc_index_alt.html">Alternatives</a></th><th colspan=3><a href="hpc_index_exp.html">Expressions</a></th></tr><tr><th>%</th><th colspan=2>covered / total</th><th>%</th><th colspan=2>covered / total</th><th>%</th><th colspan=2>covered / total</th></tr><tr>
-<td> <tt>module <a href="Main.hs.html">Main</a></tt></td>
-<td align="right">83%</td><td>5/6</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="83%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">58%</td><td>7/12</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="58%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">73%</td><td>73/100</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="73%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
-<tr></tr><tr style="background: #e0e0e0">
-<th align=left> Program Coverage Total</tt></th>
-<td align="right">83%</td><td>5/6</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="83%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">58%</td><td>7/12</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="58%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">73%</td><td>73/100</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="73%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
-</table></body></html>
-Writing: hpc_index_exp.html
+</style></head><body><table class="dashboard" width="100%" border="1"><tr><th rowspan="2"><a href="hpc_index.html">module</a></th><th colspan="3"><a href="hpc_index_fun.html">Top Level Definitions</a></th><th colspan="3"><a href="hpc_index_alt.html">Alternatives</a></th><th colspan="3"><a href="hpc_index_exp.html">Expressions</a></th></tr><tr><th>%</th><th colspan="2">covered / total</th><th>%</th><th colspan="2">covered / total</th><th>%</th><th colspan="2">covered / total</th></tr><tr><td> <code>module <a href="Main.hs.html">Main</a></code></td><td align="right">83%</td><td>5/6</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="83%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">58%</td><td>7/12</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="58%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">73%</td><td>73/100</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="73%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td></tr><tr></tr><tr style="background: #e0e0e0"><th align="left"> Program Coverage Total</th><td align="right">83%</td><td>5/6</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="83%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">58%</td><td>7/12</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="58%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">73%</td><td>73/100</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="73%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td></tr></table></body></html>Writing: hpc_index_exp.html
<html><head><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"><style type="text/css">table.bar { background-color: #f25913; }
td.bar { background-color: #60de51; }
td.invbar { background-color: #f25913; }
table.dashboard { border-collapse: collapse ; border: solid 1px black }
.dashboard td { border: solid 1px black }
.dashboard th { border: solid 1px black }
-</style>
-</head><body><table class="dashboard" width="100%" border=1>
-<tr><th rowspan=2><a href="hpc_index.html">module</a></th><th colspan=3><a href="hpc_index_fun.html">Top Level Definitions</a></th><th colspan=3><a href="hpc_index_alt.html">Alternatives</a></th><th colspan=3><a href="hpc_index_exp.html">Expressions</a></th></tr><tr><th>%</th><th colspan=2>covered / total</th><th>%</th><th colspan=2>covered / total</th><th>%</th><th colspan=2>covered / total</th></tr><tr>
-<td> <tt>module <a href="Main.hs.html">Main</a></tt></td>
-<td align="right">83%</td><td>5/6</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="83%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">58%</td><td>7/12</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="58%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">73%</td><td>73/100</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="73%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
-<tr></tr><tr style="background: #e0e0e0">
-<th align=left> Program Coverage Total</tt></th>
-<td align="right">83%</td><td>5/6</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="83%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">58%</td><td>7/12</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="58%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">73%</td><td>73/100</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="73%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
-</table></body></html>
-
+</style></head><body><table class="dashboard" width="100%" border="1"><tr><th rowspan="2"><a href="hpc_index.html">module</a></th><th colspan="3"><a href="hpc_index_fun.html">Top Level Definitions</a></th><th colspan="3"><a href="hpc_index_alt.html">Alternatives</a></th><th colspan="3"><a href="hpc_index_exp.html">Expressions</a></th></tr><tr><th>%</th><th colspan="2">covered / total</th><th>%</th><th colspan="2">covered / total</th><th>%</th><th colspan="2">covered / total</th></tr><tr><td> <code>module <a href="Main.hs.html">Main</a></code></td><td align="right">83%</td><td>5/6</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="83%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">58%</td><td>7/12</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="58%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">73%</td><td>73/100</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="73%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td></tr><tr></tr><tr style="background: #e0e0e0"><th align="left"> Program Coverage Total</th><td align="right">83%</td><td>5/6</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="83%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">58%</td><td>7/12</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="58%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">73%</td><td>73/100</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="73%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td></tr></table></body></html>
=====================================
testsuite/tests/hpc/function2/tough2.stdout
=====================================
@@ -108,62 +108,26 @@ td.invbar { background-color: #f25913; }
table.dashboard { border-collapse: collapse ; border: solid 1px black }
.dashboard td { border: solid 1px black }
.dashboard th { border: solid 1px black }
-</style>
-</head><body><table class="dashboard" width="100%" border=1>
-<tr><th rowspan=2><a href="hpc_index.html">module</a></th><th colspan=3><a href="hpc_index_fun.html">Top Level Definitions</a></th><th colspan=3><a href="hpc_index_alt.html">Alternatives</a></th><th colspan=3><a href="hpc_index_exp.html">Expressions</a></th></tr><tr><th>%</th><th colspan=2>covered / total</th><th>%</th><th colspan=2>covered / total</th><th>%</th><th colspan=2>covered / total</th></tr><tr>
-<td> <tt>module <a href="Main.hs.html">Main</a></tt></td>
-<td align="right">83%</td><td>5/6</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="83%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">58%</td><td>7/12</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="58%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">73%</td><td>73/100</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="73%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
-<tr></tr><tr style="background: #e0e0e0">
-<th align=left> Program Coverage Total</tt></th>
-<td align="right">83%</td><td>5/6</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="83%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">58%</td><td>7/12</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="58%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">73%</td><td>73/100</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="73%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
-</table></body></html>
-Writing: hpc_index_fun.html
+</style></head><body><table class="dashboard" width="100%" border="1"><tr><th rowspan="2"><a href="hpc_index.html">module</a></th><th colspan="3"><a href="hpc_index_fun.html">Top Level Definitions</a></th><th colspan="3"><a href="hpc_index_alt.html">Alternatives</a></th><th colspan="3"><a href="hpc_index_exp.html">Expressions</a></th></tr><tr><th>%</th><th colspan="2">covered / total</th><th>%</th><th colspan="2">covered / total</th><th>%</th><th colspan="2">covered / total</th></tr><tr><td> <code>module <a href="Main.hs.html">Main</a></code></td><td align="right">83%</td><td>5/6</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="83%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">58%</td><td>7/12</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="58%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">73%</td><td>73/100</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="73%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td></tr><tr></tr><tr style="background: #e0e0e0"><th align="left"> Program Coverage Total</th><td align="right">83%</td><td>5/6</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="83%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">58%</td><td>7/12</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="58%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">73%</td><td>73/100</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="73%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td></tr></table></body></html>Writing: hpc_index_fun.html
<html><head><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"><style type="text/css">table.bar { background-color: #f25913; }
td.bar { background-color: #60de51; }
td.invbar { background-color: #f25913; }
table.dashboard { border-collapse: collapse ; border: solid 1px black }
.dashboard td { border: solid 1px black }
.dashboard th { border: solid 1px black }
-</style>
-</head><body><table class="dashboard" width="100%" border=1>
-<tr><th rowspan=2><a href="hpc_index.html">module</a></th><th colspan=3><a href="hpc_index_fun.html">Top Level Definitions</a></th><th colspan=3><a href="hpc_index_alt.html">Alternatives</a></th><th colspan=3><a href="hpc_index_exp.html">Expressions</a></th></tr><tr><th>%</th><th colspan=2>covered / total</th><th>%</th><th colspan=2>covered / total</th><th>%</th><th colspan=2>covered / total</th></tr><tr>
-<td> <tt>module <a href="Main.hs.html">Main</a></tt></td>
-<td align="right">83%</td><td>5/6</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="83%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">58%</td><td>7/12</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="58%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">73%</td><td>73/100</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="73%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
-<tr></tr><tr style="background: #e0e0e0">
-<th align=left> Program Coverage Total</tt></th>
-<td align="right">83%</td><td>5/6</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="83%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">58%</td><td>7/12</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="58%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">73%</td><td>73/100</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="73%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
-</table></body></html>
-Writing: hpc_index_alt.html
+</style></head><body><table class="dashboard" width="100%" border="1"><tr><th rowspan="2"><a href="hpc_index.html">module</a></th><th colspan="3"><a href="hpc_index_fun.html">Top Level Definitions</a></th><th colspan="3"><a href="hpc_index_alt.html">Alternatives</a></th><th colspan="3"><a href="hpc_index_exp.html">Expressions</a></th></tr><tr><th>%</th><th colspan="2">covered / total</th><th>%</th><th colspan="2">covered / total</th><th>%</th><th colspan="2">covered / total</th></tr><tr><td> <code>module <a href="Main.hs.html">Main</a></code></td><td align="right">83%</td><td>5/6</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="83%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">58%</td><td>7/12</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="58%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">73%</td><td>73/100</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="73%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td></tr><tr></tr><tr style="background: #e0e0e0"><th align="left"> Program Coverage Total</th><td align="right">83%</td><td>5/6</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="83%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">58%</td><td>7/12</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="58%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">73%</td><td>73/100</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="73%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td></tr></table></body></html>Writing: hpc_index_alt.html
<html><head><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"><style type="text/css">table.bar { background-color: #f25913; }
td.bar { background-color: #60de51; }
td.invbar { background-color: #f25913; }
table.dashboard { border-collapse: collapse ; border: solid 1px black }
.dashboard td { border: solid 1px black }
.dashboard th { border: solid 1px black }
-</style>
-</head><body><table class="dashboard" width="100%" border=1>
-<tr><th rowspan=2><a href="hpc_index.html">module</a></th><th colspan=3><a href="hpc_index_fun.html">Top Level Definitions</a></th><th colspan=3><a href="hpc_index_alt.html">Alternatives</a></th><th colspan=3><a href="hpc_index_exp.html">Expressions</a></th></tr><tr><th>%</th><th colspan=2>covered / total</th><th>%</th><th colspan=2>covered / total</th><th>%</th><th colspan=2>covered / total</th></tr><tr>
-<td> <tt>module <a href="Main.hs.html">Main</a></tt></td>
-<td align="right">83%</td><td>5/6</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="83%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">58%</td><td>7/12</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="58%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">73%</td><td>73/100</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="73%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
-<tr></tr><tr style="background: #e0e0e0">
-<th align=left> Program Coverage Total</tt></th>
-<td align="right">83%</td><td>5/6</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="83%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">58%</td><td>7/12</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="58%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">73%</td><td>73/100</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="73%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
-</table></body></html>
-Writing: hpc_index_exp.html
+</style></head><body><table class="dashboard" width="100%" border="1"><tr><th rowspan="2"><a href="hpc_index.html">module</a></th><th colspan="3"><a href="hpc_index_fun.html">Top Level Definitions</a></th><th colspan="3"><a href="hpc_index_alt.html">Alternatives</a></th><th colspan="3"><a href="hpc_index_exp.html">Expressions</a></th></tr><tr><th>%</th><th colspan="2">covered / total</th><th>%</th><th colspan="2">covered / total</th><th>%</th><th colspan="2">covered / total</th></tr><tr><td> <code>module <a href="Main.hs.html">Main</a></code></td><td align="right">83%</td><td>5/6</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="83%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">58%</td><td>7/12</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="58%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">73%</td><td>73/100</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="73%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td></tr><tr></tr><tr style="background: #e0e0e0"><th align="left"> Program Coverage Total</th><td align="right">83%</td><td>5/6</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="83%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">58%</td><td>7/12</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="58%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">73%</td><td>73/100</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="73%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td></tr></table></body></html>Writing: hpc_index_exp.html
<html><head><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"><style type="text/css">table.bar { background-color: #f25913; }
td.bar { background-color: #60de51; }
td.invbar { background-color: #f25913; }
table.dashboard { border-collapse: collapse ; border: solid 1px black }
.dashboard td { border: solid 1px black }
.dashboard th { border: solid 1px black }
-</style>
-</head><body><table class="dashboard" width="100%" border=1>
-<tr><th rowspan=2><a href="hpc_index.html">module</a></th><th colspan=3><a href="hpc_index_fun.html">Top Level Definitions</a></th><th colspan=3><a href="hpc_index_alt.html">Alternatives</a></th><th colspan=3><a href="hpc_index_exp.html">Expressions</a></th></tr><tr><th>%</th><th colspan=2>covered / total</th><th>%</th><th colspan=2>covered / total</th><th>%</th><th colspan=2>covered / total</th></tr><tr>
-<td> <tt>module <a href="Main.hs.html">Main</a></tt></td>
-<td align="right">83%</td><td>5/6</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="83%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">58%</td><td>7/12</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="58%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">73%</td><td>73/100</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="73%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
-<tr></tr><tr style="background: #e0e0e0">
-<th align=left> Program Coverage Total</tt></th>
-<td align="right">83%</td><td>5/6</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="83%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">58%</td><td>7/12</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="58%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">73%</td><td>73/100</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="73%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
-</table></body></html>
-
+</style></head><body><table class="dashboard" width="100%" border="1"><tr><th rowspan="2"><a href="hpc_index.html">module</a></th><th colspan="3"><a href="hpc_index_fun.html">Top Level Definitions</a></th><th colspan="3"><a href="hpc_index_alt.html">Alternatives</a></th><th colspan="3"><a href="hpc_index_exp.html">Expressions</a></th></tr><tr><th>%</th><th colspan="2">covered / total</th><th>%</th><th colspan="2">covered / total</th><th>%</th><th colspan="2">covered / total</th></tr><tr><td> <code>module <a href="Main.hs.html">Main</a></code></td><td align="right">83%</td><td>5/6</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="83%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">58%</td><td>7/12</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="58%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">73%</td><td>73/100</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="73%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td></tr><tr></tr><tr style="background: #e0e0e0"><th align="left"> Program Coverage Total</th><td align="right">83%</td><td>5/6</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="83%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">58%</td><td>7/12</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="58%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">73%</td><td>73/100</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="73%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td></tr></table></body></html>
=====================================
testsuite/tests/hpc/simple/hpc001.stdout
=====================================
@@ -54,62 +54,26 @@ td.invbar { background-color: #f25913; }
table.dashboard { border-collapse: collapse ; border: solid 1px black }
.dashboard td { border: solid 1px black }
.dashboard th { border: solid 1px black }
-</style>
-</head><body><table class="dashboard" width="100%" border=1>
-<tr><th rowspan=2><a href="hpc_index.html">module</a></th><th colspan=3><a href="hpc_index_fun.html">Top Level Definitions</a></th><th colspan=3><a href="hpc_index_alt.html">Alternatives</a></th><th colspan=3><a href="hpc_index_exp.html">Expressions</a></th></tr><tr><th>%</th><th colspan=2>covered / total</th><th>%</th><th colspan=2>covered / total</th><th>%</th><th colspan=2>covered / total</th></tr><tr>
-<td> <tt>module <a href="Main.hs.html">Main</a></tt></td>
-<td align="right">100%</td><td>1/1</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="100%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">- </td><td>0/0</td><td width=100> </td><td align="right">75%</td><td>3/4</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="75%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
-<tr></tr><tr style="background: #e0e0e0">
-<th align=left> Program Coverage Total</tt></th>
-<td align="right">100%</td><td>1/1</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="100%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">- </td><td>0/0</td><td width=100> </td><td align="right">75%</td><td>3/4</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="75%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
-</table></body></html>
-Writing: hpc_index_fun.html
+</style></head><body><table class="dashboard" width="100%" border="1"><tr><th rowspan="2"><a href="hpc_index.html">module</a></th><th colspan="3"><a href="hpc_index_fun.html">Top Level Definitions</a></th><th colspan="3"><a href="hpc_index_alt.html">Alternatives</a></th><th colspan="3"><a href="hpc_index_exp.html">Expressions</a></th></tr><tr><th>%</th><th colspan="2">covered / total</th><th>%</th><th colspan="2">covered / total</th><th>%</th><th colspan="2">covered / total</th></tr><tr><td> <code>module <a href="Main.hs.html">Main</a></code></td><td align="right">100%</td><td>1/1</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="100%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">- </td><td>0/0</td><td width="100"> </td><td align="right">75%</td><td>3/4</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="75%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td></tr><tr></tr><tr style="background: #e0e0e0"><th align="left"> Program Coverage Total</th><td align="right">100%</td><td>1/1</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="100%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">- </td><td>0/0</td><td width="100"> </td><td align="right">75%</td><td>3/4</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="75%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td></tr></table></body></html>Writing: hpc_index_fun.html
<html><head><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"><style type="text/css">table.bar { background-color: #f25913; }
td.bar { background-color: #60de51; }
td.invbar { background-color: #f25913; }
table.dashboard { border-collapse: collapse ; border: solid 1px black }
.dashboard td { border: solid 1px black }
.dashboard th { border: solid 1px black }
-</style>
-</head><body><table class="dashboard" width="100%" border=1>
-<tr><th rowspan=2><a href="hpc_index.html">module</a></th><th colspan=3><a href="hpc_index_fun.html">Top Level Definitions</a></th><th colspan=3><a href="hpc_index_alt.html">Alternatives</a></th><th colspan=3><a href="hpc_index_exp.html">Expressions</a></th></tr><tr><th>%</th><th colspan=2>covered / total</th><th>%</th><th colspan=2>covered / total</th><th>%</th><th colspan=2>covered / total</th></tr><tr>
-<td> <tt>module <a href="Main.hs.html">Main</a></tt></td>
-<td align="right">100%</td><td>1/1</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="100%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">- </td><td>0/0</td><td width=100> </td><td align="right">75%</td><td>3/4</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="75%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
-<tr></tr><tr style="background: #e0e0e0">
-<th align=left> Program Coverage Total</tt></th>
-<td align="right">100%</td><td>1/1</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="100%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">- </td><td>0/0</td><td width=100> </td><td align="right">75%</td><td>3/4</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="75%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
-</table></body></html>
-Writing: hpc_index_alt.html
+</style></head><body><table class="dashboard" width="100%" border="1"><tr><th rowspan="2"><a href="hpc_index.html">module</a></th><th colspan="3"><a href="hpc_index_fun.html">Top Level Definitions</a></th><th colspan="3"><a href="hpc_index_alt.html">Alternatives</a></th><th colspan="3"><a href="hpc_index_exp.html">Expressions</a></th></tr><tr><th>%</th><th colspan="2">covered / total</th><th>%</th><th colspan="2">covered / total</th><th>%</th><th colspan="2">covered / total</th></tr><tr><td> <code>module <a href="Main.hs.html">Main</a></code></td><td align="right">100%</td><td>1/1</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="100%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">- </td><td>0/0</td><td width="100"> </td><td align="right">75%</td><td>3/4</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="75%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td></tr><tr></tr><tr style="background: #e0e0e0"><th align="left"> Program Coverage Total</th><td align="right">100%</td><td>1/1</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="100%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">- </td><td>0/0</td><td width="100"> </td><td align="right">75%</td><td>3/4</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="75%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td></tr></table></body></html>Writing: hpc_index_alt.html
<html><head><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"><style type="text/css">table.bar { background-color: #f25913; }
td.bar { background-color: #60de51; }
td.invbar { background-color: #f25913; }
table.dashboard { border-collapse: collapse ; border: solid 1px black }
.dashboard td { border: solid 1px black }
.dashboard th { border: solid 1px black }
-</style>
-</head><body><table class="dashboard" width="100%" border=1>
-<tr><th rowspan=2><a href="hpc_index.html">module</a></th><th colspan=3><a href="hpc_index_fun.html">Top Level Definitions</a></th><th colspan=3><a href="hpc_index_alt.html">Alternatives</a></th><th colspan=3><a href="hpc_index_exp.html">Expressions</a></th></tr><tr><th>%</th><th colspan=2>covered / total</th><th>%</th><th colspan=2>covered / total</th><th>%</th><th colspan=2>covered / total</th></tr><tr>
-<td> <tt>module <a href="Main.hs.html">Main</a></tt></td>
-<td align="right">100%</td><td>1/1</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="100%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">- </td><td>0/0</td><td width=100> </td><td align="right">75%</td><td>3/4</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="75%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
-<tr></tr><tr style="background: #e0e0e0">
-<th align=left> Program Coverage Total</tt></th>
-<td align="right">100%</td><td>1/1</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="100%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">- </td><td>0/0</td><td width=100> </td><td align="right">75%</td><td>3/4</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="75%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
-</table></body></html>
-Writing: hpc_index_exp.html
+</style></head><body><table class="dashboard" width="100%" border="1"><tr><th rowspan="2"><a href="hpc_index.html">module</a></th><th colspan="3"><a href="hpc_index_fun.html">Top Level Definitions</a></th><th colspan="3"><a href="hpc_index_alt.html">Alternatives</a></th><th colspan="3"><a href="hpc_index_exp.html">Expressions</a></th></tr><tr><th>%</th><th colspan="2">covered / total</th><th>%</th><th colspan="2">covered / total</th><th>%</th><th colspan="2">covered / total</th></tr><tr><td> <code>module <a href="Main.hs.html">Main</a></code></td><td align="right">100%</td><td>1/1</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="100%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">- </td><td>0/0</td><td width="100"> </td><td align="right">75%</td><td>3/4</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="75%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td></tr><tr></tr><tr style="background: #e0e0e0"><th align="left"> Program Coverage Total</th><td align="right">100%</td><td>1/1</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="100%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">- </td><td>0/0</td><td width="100"> </td><td align="right">75%</td><td>3/4</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="75%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td></tr></table></body></html>Writing: hpc_index_exp.html
<html><head><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"><style type="text/css">table.bar { background-color: #f25913; }
td.bar { background-color: #60de51; }
td.invbar { background-color: #f25913; }
table.dashboard { border-collapse: collapse ; border: solid 1px black }
.dashboard td { border: solid 1px black }
.dashboard th { border: solid 1px black }
-</style>
-</head><body><table class="dashboard" width="100%" border=1>
-<tr><th rowspan=2><a href="hpc_index.html">module</a></th><th colspan=3><a href="hpc_index_fun.html">Top Level Definitions</a></th><th colspan=3><a href="hpc_index_alt.html">Alternatives</a></th><th colspan=3><a href="hpc_index_exp.html">Expressions</a></th></tr><tr><th>%</th><th colspan=2>covered / total</th><th>%</th><th colspan=2>covered / total</th><th>%</th><th colspan=2>covered / total</th></tr><tr>
-<td> <tt>module <a href="Main.hs.html">Main</a></tt></td>
-<td align="right">100%</td><td>1/1</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="100%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">- </td><td>0/0</td><td width=100> </td><td align="right">75%</td><td>3/4</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="75%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
-<tr></tr><tr style="background: #e0e0e0">
-<th align=left> Program Coverage Total</tt></th>
-<td align="right">100%</td><td>1/1</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="100%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">- </td><td>0/0</td><td width=100> </td><td align="right">75%</td><td>3/4</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="75%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
-</table></body></html>
-
+</style></head><body><table class="dashboard" width="100%" border="1"><tr><th rowspan="2"><a href="hpc_index.html">module</a></th><th colspan="3"><a href="hpc_index_fun.html">Top Level Definitions</a></th><th colspan="3"><a href="hpc_index_alt.html">Alternatives</a></th><th colspan="3"><a href="hpc_index_exp.html">Expressions</a></th></tr><tr><th>%</th><th colspan="2">covered / total</th><th>%</th><th colspan="2">covered / total</th><th>%</th><th colspan="2">covered / total</th></tr><tr><td> <code>module <a href="Main.hs.html">Main</a></code></td><td align="right">100%</td><td>1/1</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="100%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">- </td><td>0/0</td><td width="100"> </td><td align="right">75%</td><td>3/4</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="75%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td></tr><tr></tr><tr style="background: #e0e0e0"><th align="left"> Program Coverage Total</th><td align="right">100%</td><td>1/1</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="100%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">- </td><td>0/0</td><td width="100"> </td><td align="right">75%</td><td>3/4</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="75%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td></tr></table></body></html>
=====================================
testsuite/tests/partial-sigs/should_fail/T10999.stderr
=====================================
@@ -20,10 +20,11 @@ T10999.hs:8:28: error: [GHC-39999]
Relevant bindings include g :: [b1] (bound at T10999.hs:8:1)
Probable fix: use a type annotation to specify what ‘b1’ should be.
Potentially matching instances:
+ instance Ord a => Ord (Set.Intersection a)
+ -- Defined in ‘Data.Set.Internal’
instance Ord a => Ord (Set.Set a) -- Defined in ‘Data.Set.Internal’
- instance Ord Ordering -- Defined in ‘GHC.Internal.Classes’
- ...plus 24 others
- ...plus four instances involving out-of-scope types
+ ...plus 25 others
+ ...plus three instances involving out-of-scope types
(use -fprint-potential-instances to see them all)
• In the second argument of ‘($)’, namely ‘f ()’
In the second argument of ‘($)’, namely ‘Set.toList $ f ()’
=====================================
testsuite/tests/rebindable/DoRestrictedM.hs
=====================================
@@ -77,7 +77,7 @@ instance MN2 SMPlus a where
fail x = SMPlus $ Set.empty
instance Prelude.Ord b => MN3 SMPlus a b where
- m >>= f = SMPlus (Set.fold (Set.union . unSM . f) Set.empty (unSM m))
+ m >>= f = SMPlus (Set.foldr (Set.union . unSM . f) Set.empty (unSM m))
-- We cannot forget the Ord constraint, because the typechecker
-- will complain (and tell us exactly what we have forgotten).
=====================================
utils/haddock/haddock-library/haddock-library.cabal
=====================================
@@ -47,7 +47,7 @@ common ghc-options
build-depends:
, base >= 4.10 && < 4.22
- , containers ^>= 0.4.2.1 || ^>= 0.5.0.0 || ^>= 0.6.0.1 || ^>= 0.7
+ , containers >= 0.4.2.1 && < 0.9
, text ^>= 1.2.3.0 || ^>= 2.0 || ^>= 2.1
, parsec ^>= 3.1.13.0
=====================================
utils/hpc
=====================================
@@ -1 +1 @@
-Subproject commit d1780eb21c1e5a1227fff80c8d325d5142f04255
+Subproject commit 5923da3fe77993b7afc15b5163cffcaa7da6ecf5
=====================================
utils/hsc2hs
=====================================
@@ -1 +1 @@
-Subproject commit 2fab2f4cdffef12afe561ef03f5ebdace7dbae67
+Subproject commit 044e04f14ff886456837b9784b2972af71c66494
=====================================
utils/iserv/iserv.cabal.in
=====================================
@@ -34,7 +34,7 @@ Executable iserv
base >= 4 && < 5,
binary >= 0.7 && < 0.11,
bytestring >= 0.10 && < 0.13,
- containers >= 0.5 && < 0.8,
+ containers >= 0.5 && < 0.9,
deepseq >= 1.4 && < 1.6,
ghci == @ProjectVersionMunged@
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6d12060faf48ece7262b3a642cbf192…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6d12060faf48ece7262b3a642cbf192…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/boot-lib-testing] 2 commits: check-submodules: initial commit
by Ben Gamari (＠bgamari) 12 Jun '25
by Ben Gamari (＠bgamari) 12 Jun '25
12 Jun '25
Ben Gamari pushed to branch wip/boot-lib-testing at Glasgow Haskell Compiler / GHC
Commits:
c0a4c9c9 by Ben Gamari at 2025-06-12T14:04:00-04:00
check-submodules: initial commit
- - - - -
795105ee by Ben Gamari at 2025-06-12T14:04:00-04:00
gitlab-ci: Add boot library linting steps
- - - - -
15 changed files:
- .gitlab-ci.yml
- + utils/check-submodules/LICENSE
- + utils/check-submodules/README.mkd
- + utils/check-submodules/app/Main.hs
- + utils/check-submodules/check-submodules.cabal
- + utils/check-submodules/flake.lock
- + utils/check-submodules/flake.nix
- + utils/check-submodules/hie.yaml
- + utils/check-submodules/src/CheckTags.hs
- + utils/check-submodules/src/CheckVersions.hs
- + utils/check-submodules/src/Git.hs
- + utils/check-submodules/src/Hackage.hs
- + utils/check-submodules/src/Package.hs
- + utils/check-submodules/src/Packages.hs
- + utils/check-submodules/src/Pretty.hs
Changes:
=====================================
.gitlab-ci.yml
=====================================
@@ -205,6 +205,25 @@ not-interruptible:
- if: $NIGHTLY
when: always
+.nix:
+ image: nixos/nix:2.25.2
+ variables:
+ LANG: "C.UTF-8"
+ before_script:
+ - echo "experimental-features = nix-command flakes" >> /etc/nix/nix.conf
+ # Note [Nix-in-Docker]
+ # ~~~~~~~~~~~~~~~~~~~~
+ # The nixos/nix default config is max-jobs=1 and cores=$(logical
+ # cores num) which doesn't play nice with our $CPUS convention. We
+ # fix it before invoking any nix build to avoid oversubscribing
+ # while allowing a reasonable degree of parallelism.
+ # FIXME: Disabling build-users-group=nixbld is a workaround for a Nix-in-Docker issue. See
+ # https://gitlab.haskell.org/ghc/head.hackage/-/issues/38#note_560487 for
+ # discussion.
+ - echo "cores = $CPUS" >> /etc/nix/nix.conf
+ - echo "max-jobs = $CPUS" >> /etc/nix/nix.conf
+ - nix run nixpkgs#gnused -- -i -e 's/ nixbld//' /etc/nix/nix.conf
+
############################################################
# Validate jobs
@@ -255,6 +274,24 @@ typecheck-testsuite:
- mypy testsuite/driver/runtests.py
dependencies: []
+lint-boot-tags:
+ extends: [.lint, .nix]
+ script:
+ - nix run ./utils/check-submodules# -- check-tags
+ rules:
+ - if: $RELEASE_JOB
+ allow_failure: false
+ - allow_failure: true
+
+lint-boot-versions:
+ extends: [.lint, .nix]
+ script:
+ - nix run ./utils/check-submodules# -- check-versions
+ rules:
+ - if: $RELEASE_JOB
+ allow_failure: false
+ - allow_failure: true
+
# We allow the submodule checker to fail when run on merge requests (to
# accommodate, e.g., haddock changes not yet upstream) but not on `master` or
# Marge jobs.
@@ -292,26 +329,11 @@ lint-author:
- *drafts-can-fail-lint
lint-ci-config:
- image: nixos/nix:2.25.2
- extends: .lint
+ extends: [.lint, .nix]
# We don't need history/submodules in this job
variables:
GIT_DEPTH: 1
GIT_SUBMODULE_STRATEGY: none
- before_script:
- - echo "experimental-features = nix-command flakes" >> /etc/nix/nix.conf
- # Note [Nix-in-Docker]
- # ~~~~~~~~~~~~~~~~~~~~
- # The nixos/nix default config is max-jobs=1 and cores=$(logical
- # cores num) which doesn't play nice with our $CPUS convention. We
- # fix it before invoking any nix build to avoid oversubscribing
- # while allowing a reasonable degree of parallelism.
- # FIXME: Disabling build-users-group=nixbld is a workaround for a Nix-in-Docker issue. See
- # https://gitlab.haskell.org/ghc/head.hackage/-/issues/38#note_560487 for
- # discussion.
- - echo "cores = $CPUS" >> /etc/nix/nix.conf
- - echo "max-jobs = $CPUS" >> /etc/nix/nix.conf
- - nix run nixpkgs#gnused -- -i -e 's/ nixbld//' /etc/nix/nix.conf
script:
- nix run .gitlab/generate-ci#generate-jobs
# 1 if .gitlab/generate_jobs changed the output of the generated config
=====================================
utils/check-submodules/LICENSE
=====================================
@@ -0,0 +1,30 @@
+Copyright (c) 2024, Ben Gamari
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Ben Gamari nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
=====================================
utils/check-submodules/README.mkd
=====================================
@@ -0,0 +1,16 @@
+# check-submodules
+
+This is a utilities used in GHC CI to verify the consistency and
+up-to-date-ness of GHC's boot library dependencies. Specifically
+we verify that:
+
+ * the referenced commits are released on Hackage
+ * that the Hackage version has not been deprecated
+ * that there is not a more recent version in the same major series
+
+## Usage
+
+In the GHC tree:
+```bash
+nix run ./utils/check-submodules#
+```
=====================================
utils/check-submodules/app/Main.hs
=====================================
@@ -0,0 +1,15 @@
+module Main (main) where
+
+import CheckVersions
+import CheckTags
+import System.Environment (getArgs)
+
+main :: IO ()
+main = do
+ args <- getArgs
+ case args of
+ ["check-versions"] -> checkVersions
+ ["check-tags"] -> checkTags
+ ["summarize"] -> summarize
+ ["email"] -> maintainerEmails >>= putStrLn
+ _ -> fail "invalid mode (valid modes: check-versions, check-tags, summarize, email)"
=====================================
utils/check-submodules/check-submodules.cabal
=====================================
@@ -0,0 +1,50 @@
+cabal-version: 3.0
+name: check-submodules
+version: 0.1.0.0
+-- synopsis:
+-- description:
+homepage: https://gitlab.haskell.org/ghc/ghc
+license: BSD-3-Clause
+license-file: LICENSE
+author: Ben Gamari
+maintainer: ben(a)smart-cactus.org
+copyright: (c) 2024 Ben Gamari
+category: Development
+build-type: Simple
+-- extra-source-files:
+
+common warnings
+ ghc-options: -Wall
+
+executable check-submodules
+ import: warnings
+ main-is: Main.hs
+ build-depends: base,
+ check-submodules
+ hs-source-dirs: app
+ default-language: Haskell2010
+
+library
+ import: warnings
+ exposed-modules: Git,
+ Hackage,
+ CheckVersions,
+ CheckTags,
+ Packages,
+ Package,
+ Pretty
+ build-depends: base,
+ wreq,
+ aeson,
+ bytestring,
+ text,
+ transformers,
+ prettyprinter,
+ prettyprinter-ansi-terminal,
+ filepath,
+ microlens,
+ containers,
+ typed-process,
+ Cabal
+ hs-source-dirs: src
+ default-language: Haskell2010
=====================================
utils/check-submodules/flake.lock
=====================================
@@ -0,0 +1,58 @@
+{
+ "nodes": {
+ "flake-utils": {
+ "inputs": {
+ "systems": "systems"
+ },
+ "locked": {
+ "lastModified": 1731533236,
+ "narHash": "sha256-l0KFg5HjrsfsO/JpG+r7fRrqm12kzFHyUHqHCVpMMbI=",
+ "owner": "numtide",
+ "repo": "flake-utils",
+ "rev": "11707dc2f618dd54ca8739b309ec4fc024de578b",
+ "type": "github"
+ },
+ "original": {
+ "owner": "numtide",
+ "repo": "flake-utils",
+ "type": "github"
+ }
+ },
+ "nixpkgs": {
+ "locked": {
+ "lastModified": 1734083684,
+ "narHash": "sha256-5fNndbndxSx5d+C/D0p/VF32xDiJCJzyOqorOYW4JEo=",
+ "path": "/nix/store/0xbni69flk8380w0apw4h640n37wn1i9-source",
+ "rev": "314e12ba369ccdb9b352a4db26ff419f7c49fa84",
+ "type": "path"
+ },
+ "original": {
+ "id": "nixpkgs",
+ "type": "indirect"
+ }
+ },
+ "root": {
+ "inputs": {
+ "flake-utils": "flake-utils",
+ "nixpkgs": "nixpkgs"
+ }
+ },
+ "systems": {
+ "locked": {
+ "lastModified": 1681028828,
+ "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=",
+ "owner": "nix-systems",
+ "repo": "default",
+ "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e",
+ "type": "github"
+ },
+ "original": {
+ "owner": "nix-systems",
+ "repo": "default",
+ "type": "github"
+ }
+ }
+ },
+ "root": "root",
+ "version": 7
+}
=====================================
utils/check-submodules/flake.nix
=====================================
@@ -0,0 +1,26 @@
+{
+ description = "GHC boot library linting";
+
+ inputs.flake-utils.url = "github:numtide/flake-utils";
+
+ outputs = { self, nixpkgs, flake-utils }:
+ flake-utils.lib.eachDefaultSystem (system:
+ let pkgs = nixpkgs.legacyPackages.${system}; in
+ {
+ packages = rec {
+ check-submodules = pkgs.haskellPackages.callCabal2nix "generate-ci" ./. {};
+ default = check-submodules;
+ };
+
+ devShells.default = self.packages.${system}.default.env;
+
+ apps = rec {
+ check-submodules = flake-utils.lib.mkApp {
+ drv = self.packages.${system}.check-submodules;
+ };
+ default = check-submodules;
+ };
+ }
+ );
+}
+
=====================================
utils/check-submodules/hie.yaml
=====================================
@@ -0,0 +1,2 @@
+cradle:
+ cabal:
=====================================
utils/check-submodules/src/CheckTags.hs
=====================================
@@ -0,0 +1,68 @@
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
+
+module CheckTags
+ ( checkTags
+ ) where
+
+import Data.List (isPrefixOf, isSuffixOf)
+import Git qualified
+import Package (Package(..))
+import Packages (packages)
+import Pretty
+import Control.Monad (unless)
+
+findReleaseTag :: Git.GitRepo -> Package -> IO (Maybe Git.Tag)
+findReleaseTag repo pkg = do
+ allTags <- Git.reachableTags repo "HEAD"
+ case filter (\tag -> pkgIsReleaseTag pkg tag || isGhcTag tag) allTags of
+ [] -> return Nothing
+ tag:_ -> return (Just tag)
+
+isGhcTag :: Git.Tag -> Bool
+isGhcTag tag = "-ghc" `isSuffixOf` tag
+
+checkTag :: Git.GitRepo -> Package -> IO (Maybe Doc)
+checkTag repo pkg = do
+ mb_tag <- findReleaseTag repo pkg
+ case mb_tag of
+ Nothing -> return $ Just "No release tags found"
+ Just tag -> checkChanges repo tag
+
+-- | Check whether the tag only deviates from HEAD in trivial ways.
+checkChanges :: Git.GitRepo -> Git.Ref -> IO (Maybe Doc)
+checkChanges repo tag = do
+ files <- Git.changedFiles repo tag "HEAD"
+ case filter (not . okayChange) files of
+ [] -> return Nothing
+ badFiles -> do
+ described <- Git.describeRef repo "HEAD"
+ let msg = vsep
+ [ "Tag" <+> ppCommit (pretty tag) <+> "differs from" <+> ppCommit (pretty described) <+> "in:"
+ , bulletList fileList
+ ]
+ maxFiles = 5
+ fileList
+ | n > 0 =
+ take maxFiles (map pretty badFiles) ++
+ ["... and" <+> pretty n <+> "other" <+> plural "file" "files" n]
+ | otherwise = map pretty badFiles
+ where n = length badFiles - maxFiles
+ return $ Just msg
+
+okayChange :: FilePath -> Bool
+okayChange path
+ | "." `isPrefixOf` path = True
+ | ".gitignore" `isSuffixOf` path = True
+ | otherwise = False
+
+checkTags :: IO ()
+checkTags = do
+ let ghcRepo = Git.GitRepo "."
+ errs <- mapM (\pkg -> (pkg,) <$> checkTag (Git.submoduleIn ghcRepo (pkgPath pkg)) pkg) packages
+ putDoc $ bulletList
+ [ severityIcon Error <+> ppPackage pkg <> ":" <+> err
+ | (pkg, Just err) <- errs
+ ]
+ unless (null errs) $ fail "Tag issues above"
=====================================
utils/check-submodules/src/CheckVersions.hs
=====================================
@@ -0,0 +1,82 @@
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
+
+module CheckVersions
+ ( checkVersions
+ , summarize
+ , maintainerEmails
+ ) where
+
+import Control.Monad (forM_)
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Writer
+import Data.Function (on)
+import Data.List (intercalate, sort, nubBy)
+import Data.Map.Strict qualified as M
+import Data.Text qualified as T
+import Data.Version
+import Distribution.Types.PackageName qualified as C
+import System.Exit
+
+import Hackage (getVersions, PackageState (..))
+import Pretty
+import Package
+import Packages
+
+isPvpCompatible :: Version -> Version -> Bool
+isPvpCompatible a b =
+ take 2 (versionBranch a) == take 2 (versionBranch b)
+
+updateVersion :: M.Map Version PackageState -> Version -> Maybe Version
+updateVersion available v
+ | [] <- compatible = Nothing
+ | otherwise = Just $ maximum compatible
+ where
+ compatible =
+ [ v'
+ | (v', Normal) <- M.assocs available -- non-deprecated versions available via Hackage...
+ , v' > v -- that are newer than the submodule...
+ , v' `isPvpCompatible` v -- and are compatible with the submodule
+ ]
+
+checkPackage :: Package -> WriterT [(Severity, Doc)] IO ()
+checkPackage pkg = do
+ v <- liftIO $ getPackageVersion pkg
+ available <- liftIO $ getVersions (pkgName pkg)
+
+ case M.lookup v available of
+ Nothing -> tellMsg Error $ "Version" <+> ppVersion v <+> "is not on Hackage"
+ Just Deprecated -> tellMsg Error $ "Version" <+> ppVersion v <+> "has been deprecated"
+ Just Normal -> return ()
+
+ case updateVersion available v of
+ Nothing -> return ()
+ Just v' -> tellMsg Warning $ "Shipping with" <+> ppVersion v <+> "but newer version" <+> ppVersion v' <+> "is available"
+
+tellMsg :: Severity -> Doc -> WriterT [(Severity, Doc)] IO ()
+tellMsg sev msg = tell [(sev, msg)]
+
+summarizeSubmodules :: [Package] -> IO ()
+summarizeSubmodules pkgs = forM_ pkgs $ \pkg -> do
+ v <- getPackageVersion pkg
+ putStrLn $ " " <> C.unPackageName (pkgName pkg) <> " " <> showVersion v <> " @ " <> pkgPath pkg
+
+maintainerEmails :: IO String
+maintainerEmails = do
+ maintainers <- concat <$> mapM getPackageMaintainers packages
+ return $ intercalate ", " $ map (T.unpack . contactRecipient) $ nubBy ((==) `on` contactEmail) $ sort maintainers
+
+summarize :: IO ()
+summarize =
+ summarizeSubmodules packages
+
+checkVersions :: IO ()
+checkVersions = do
+ errs <- mapM (\pkg -> map (pkg, ) <$> execWriterT (checkPackage pkg)) packages
+ putDoc $ bulletList
+ [ severityIcon sev <+> ppPackage pkg <> ":" <+> err
+ | (pkg, (sev, err)) <- concat errs
+ ]
+ exitWith $ if null errs then ExitSuccess else ExitFailure 1
+
=====================================
utils/check-submodules/src/Git.hs
=====================================
@@ -0,0 +1,52 @@
+{-# LANGUAGE ImportQualifiedPost #-}
+
+module Git
+ ( GitRepo(..)
+ , submoduleIn
+
+ , Ref
+ , describeRef
+ , submoduleCommit
+ , Tag
+ , reachableTags
+ , changedFiles
+ ) where
+
+import System.Process.Typed
+import Data.ByteString.Lazy.Char8 qualified as BSL
+import System.FilePath ((</>))
+
+newtype GitRepo = GitRepo { gitRepoPath :: FilePath }
+
+submoduleIn :: GitRepo -> FilePath -> GitRepo
+submoduleIn (GitRepo path) submod =
+ GitRepo $ path </> submod
+
+type Ref = String
+type Tag = String
+
+runGit :: GitRepo -> [String] -> IO BSL.ByteString
+runGit (GitRepo path) args = do
+ readProcessStdout_ $ setWorkingDir path (proc "git" args)
+
+describeRef :: GitRepo -> Ref -> IO String
+describeRef repo ref =
+ head . lines . BSL.unpack <$> runGit repo ["describe", "--always", ref]
+
+-- | Get the commit of the given submodule.
+submoduleCommit :: GitRepo -> FilePath -> IO Ref
+submoduleCommit repo submodule = do
+ out <- runGit repo ["submodule", "status", submodule]
+ case BSL.words $ BSL.drop 1 out of
+ commit:_ -> return $ BSL.unpack commit
+ _ -> fail "Unrecognized output from `git submodule status`"
+
+-- | Get the most recent tags reacheable from the given commit.
+reachableTags :: GitRepo -> Ref -> IO [Tag]
+reachableTags repo ref =
+ reverse . map BSL.unpack . BSL.lines <$> runGit repo ["tag", "--sort=taggerdate", "--merged", ref]
+
+changedFiles :: GitRepo -> Ref -> Ref -> IO [FilePath]
+changedFiles repo a b = do
+ map BSL.unpack . BSL.lines <$> runGit repo ["diff", "--name-only", a, b]
+
=====================================
utils/check-submodules/src/Hackage.hs
=====================================
@@ -0,0 +1,32 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Hackage
+ ( PackageState(..)
+ , getVersions
+ ) where
+
+import qualified Data.Map.Strict as M
+import Lens.Micro
+import Network.Wreq
+import Distribution.Types.PackageName
+import qualified Data.Aeson as JSON
+import Data.Version
+
+data PackageState = Normal | Deprecated
+ deriving (Show)
+
+instance JSON.FromJSON PackageState where
+ parseJSON = JSON.withText "package state" $ \case
+ "normal" -> pure Normal
+ "deprecated" -> pure Deprecated
+ _ -> fail "unknown PackageState"
+
+getVersions :: PackageName -> IO (M.Map Version PackageState)
+getVersions pn = do
+ r <- asJSON =<< getWith opts url
+ maybe (fail "getVersions: failed") pure (r ^? responseBody)
+ where
+ opts = defaults & header "Accept" .~ ["application/json"]
+ url = "https://hackage.haskell.org/package/" <> unPackageName pn
+
=====================================
utils/check-submodules/src/Package.hs
=====================================
@@ -0,0 +1,62 @@
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Package
+ ( Contact(..)
+ , parseContact
+ , contactRecipient
+
+ , Package(..)
+ , getPackageVersion
+ , getPackageMaintainers
+ ) where
+
+import Data.ByteString qualified as BS
+import Data.Text qualified as T
+import Data.Version
+import Distribution.PackageDescription.Parsec qualified as C
+import Distribution.Types.GenericPackageDescription qualified as C
+import Distribution.Types.PackageDescription qualified as C
+import Distribution.Types.PackageId qualified as C
+import Distribution.Types.PackageName (PackageName)
+import Distribution.Types.PackageName qualified as C
+import Distribution.Types.Version qualified as C
+import Distribution.Utils.ShortText qualified as C
+import System.FilePath
+
+data Contact = Contact { contactName, contactEmail :: T.Text }
+ deriving (Eq, Ord, Show)
+
+parseContact :: T.Text -> Contact
+parseContact t
+ | '<' `T.elem` t =
+ let (name,email) = T.break (== '<') t
+ in Contact (T.strip name) (T.strip $ T.takeWhile (/= '>') $ T.drop 1 email)
+ | otherwise = Contact "" t
+
+contactRecipient :: Contact -> T.Text
+contactRecipient (Contact name email)
+ | T.null name = email
+ | otherwise = name <> " <" <> email <> ">"
+
+data Package = Package { pkgName :: PackageName
+ , pkgPath :: FilePath
+ , pkgIsReleaseTag :: String -> Bool
+ }
+
+getPackageDescription :: Package -> IO C.PackageDescription
+getPackageDescription pkg = do
+ Just gpd <- C.parseGenericPackageDescriptionMaybe <$> BS.readFile (pkgPath pkg </> C.unPackageName (pkgName pkg) <.> "cabal")
+ return $ C.packageDescription gpd
+
+getPackageMaintainers :: Package -> IO [Contact]
+getPackageMaintainers pkg =
+ map (parseContact . T.strip . T.filter (/= '\n')) . T.splitOn ","
+ . T.pack . C.fromShortText . C.maintainer
+ <$> getPackageDescription pkg
+
+getPackageVersion :: Package -> IO Version
+getPackageVersion pkg =
+ Data.Version.makeVersion . C.versionNumbers . C.pkgVersion . C.package
+ <$> getPackageDescription pkg
+
=====================================
utils/check-submodules/src/Packages.hs
=====================================
@@ -0,0 +1,54 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Packages (packages) where
+
+import Package
+import Data.Char (isDigit)
+import qualified Distribution.Types.PackageName as C
+import Data.List
+
+packages :: [Package]
+packages =
+ [ stdPackage "file-io" "libraries/file-io"
+ , stdPackage "hsc2hs" "utils/hsc2hs"
+ , Package "Cabal" "libraries/Cabal/Cabal" (isPrefixTag "Cabal-")
+ , Package "Cabal-syntax" "libraries/Cabal/Cabal-syntax" (isPrefixTag "Cabal-syntax-")
+ , stdPackage "bytestring" "libraries/bytestring"
+ , stdPackage "binary" "libraries/binary"
+ , stdPackage "array" "libraries/array"
+ , stdPackage "containers" "libraries/containers/containers"
+ , stdPackage "deepseq" "libraries/deepseq"
+ , stdPackage "directory" "libraries/directory"
+ , stdPackage "filepath" "libraries/filepath"
+ , stdPackage "haskeline" "libraries/haskeline"
+ , stdPackage "hpc" "libraries/hpc"
+ , stdPackage "mtl" "libraries/mtl"
+ , stdPackage "parsec" "libraries/parsec"
+ , stdPackage "pretty" "libraries/pretty"
+ , stdPackage "process" "libraries/process"
+ , stdPackage "terminfo" "libraries/terminfo"
+ , stdPackage "text" "libraries/text"
+ , stdPackage "time" "libraries/time"
+ , stdPackage "unix" "libraries/unix"
+ , stdPackage "exceptions" "libraries/exceptions"
+ , stdPackage "semaphore-compat" "libraries/semaphore-compat"
+ , stdPackage "stm" "libraries/stm"
+ , stdPackage "Win32" "libraries/Win32"
+ , stdPackage "xhtml" "libraries/xhtml"
+ ]
+
+stdPackage :: C.PackageName -> FilePath -> Package
+stdPackage name path = Package name path stdIsReleaseTag
+
+looksLikeVersion :: String -> Bool
+looksLikeVersion =
+ all (\c -> isDigit c || c == '.')
+
+isPrefixTag :: String -> String -> Bool
+isPrefixTag prefix tag
+ | Just rest <- prefix `stripPrefix` tag = looksLikeVersion rest
+ | otherwise = False
+
+stdIsReleaseTag :: String -> Bool
+stdIsReleaseTag tag =
+ isPrefixTag "v" tag || isPrefixTag "" tag
=====================================
utils/check-submodules/src/Pretty.hs
=====================================
@@ -0,0 +1,57 @@
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Pretty
+ ( module Prettyprinter
+ , Doc
+ , mkMsg
+ , Severity(..)
+ , severityIcon
+ , bulletList
+ , ppCommit
+ , ppPackage
+ , ppVersion
+ , ppHeading
+ , putDoc
+ ) where
+
+import Data.Version
+import Package
+import Prettyprinter hiding (Doc)
+import Prettyprinter qualified as PP
+import Prettyprinter.Render.Terminal
+import Distribution.Types.PackageName qualified as C
+
+type Doc = PP.Doc AnsiStyle
+
+ppPackage :: Package -> Doc
+ppPackage =
+ annotate (color Green) . pretty . C.unPackageName . pkgName
+
+ppVersion :: Version -> Doc
+ppVersion v =
+ annotate (color Blue) $ pretty $ showVersion v
+
+ppCommit :: Doc -> Doc
+ppCommit =
+ annotate (color Blue)
+
+ppHeading :: Doc -> Doc
+ppHeading =
+ annotate bold . ("#" <+>)
+
+bullet :: Doc
+bullet = "‣"
+
+bulletList :: [Doc] -> Doc
+bulletList xs = vcat [ " " <> bullet <+> align x | x <- xs ]
+
+data Severity = Info | Warning | Error
+
+severityIcon :: Severity -> Doc
+severityIcon Info = annotate (color Blue) "ℹ" -- "🔵"
+severityIcon Warning = "🟡"
+severityIcon Error = annotate (color Red) "✗" -- "🔴"
+
+mkMsg :: Severity -> Doc -> Doc
+mkMsg s msg = severityIcon s <+> msg
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e425a69329d4842fd0726c6630e82c…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e425a69329d4842fd0726c6630e82c…
You're receiving this email because of your account on gitlab.haskell.org.
1
0